Attribute VB_Name = "Pong"
' To insert PONG into an existing Excel97 spreadsheet:
' From Excel, select Tools, Macro, then Visual Basic Editor.
' From the VB Editor, select Insert, then Module.
' From the VB Editor, select Insert, then File. Select this
' file from the resulting browse window. You can now save
' your spreadsheet and close it. The next time you open
' your spreadsheet, pressing F12 will start PONG and
' pressing Escape will stop it.
' PONG does not affect any data on your spreadsheet.

Option Explicit
Private Declare Function GetCurrentVbaProject _
  Lib "vba332.dll" Alias "EbGetExecutingProj" _
 (hProject As Long) As Long
Private Declare Function GetFuncID Lib "vba332.dll" Alias "TipGetFunctionId" _
 (ByVal hProject As Long, ByVal strFunctionName As String, _
 ByRef strFunctionId As String) As Long
Private Declare Function GetAddr _
 Lib "vba332.dll" Alias "TipGetLpfnOfFunctionId" _
 (ByVal hProject As Long, ByVal strFunctionId As String, _
 ByRef lpfn As Long) As Long
Private Declare Function SetTimer Lib "user32" _
 (ByVal hwnd As Long, ByVal nIDEvent As Long, _
 ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" _
 (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

Private lngTimerId As Long
Dim Paddle As Shape
Dim Ball As Shape
Dim nVertical As Integer
Dim nHorizontal As Integer
Dim nSpeed As Integer

Sub Auto_Open()
    Application.OnKey "{F12}", "StartPong"
End Sub

Sub Auto_Close()
    On Error Resume Next
    Timer_Terminate
    Paddle.Delete
    Ball.Delete
End Sub

Sub StartPong()
Attribute StartPong.VB_ProcData.VB_Invoke_Func = " \n14"
Dim nLeft As Integer
Dim nTop As Integer
Dim nWidth As Integer
Dim nHeight As Integer
    'Draw the paddle
    nLeft = ActiveWindow.UsableWidth - 100
    nTop = ActiveWindow.UsableHeight - 30
    nWidth = 50
    nHeight = 10
    Set Paddle = ActiveSheet.Shapes.AddShape(1, nLeft, nTop, nWidth, nHeight)
    Paddle.Fill.ForeColor.SchemeColor = 8
    'Draw the ball
    nLeft = CInt(ActiveWindow.UsableWidth / 2) - 20
    nTop = 0
    nWidth = 15
    nHeight = 15
    Set Ball = ActiveSheet.Shapes.AddShape(9, nLeft, nTop, nWidth, nHeight)
    Ball.Fill.ForeColor.SchemeColor = 8
    'Define keys
    Application.OnKey "{ESC}", "EndPong"
    Application.OnKey "{RIGHT}", "MoveRight"
    Application.OnKey "{LEFT}", "MoveLeft"
    Application.OnKey "{F12}"
    'Set speed
    nVertical = 10   'Ball Vertical
    nHorizontal = 10 'Ball Horizontal
    nSpeed = 18      'Paddle Horizontal
    'Start the ball movement timer
    Timer_Initialize (15) 'Ball will be moved every 15 milliseconds
    'Now we wait for events to move things
End Sub

Sub MoveBall()
Attribute MoveBall.VB_ProcData.VB_Invoke_Func = " \n14"
Dim nLeft As Integer
Dim nTop As Integer
    With Ball
        'Move Horizontal
        .Left = .Left + nHorizontal
        'Move vertical
        .Top = .Top + nVertical
        'Bounce horizontal
        nLeft = .Left
        If nLeft > (ActiveWindow.UsableWidth - 50) Then
            nHorizontal = -1 * Abs((nHorizontal))
        End If
        If nLeft < 20 Then
            nHorizontal = Abs(nHorizontal)
        End If
        'Bounce vertical
        nTop = .Top
        If nTop > (ActiveWindow.UsableHeight - 50) Then
            nVertical = -1 * (Abs(nVertical))
            'Did Paddle hit it?
            If (.Left + (.Width / 2)) > Paddle.Left And _
               (.Left + (.Width / 2)) < (Paddle.Left + Paddle.Width) Then
                'Paddle hit the ball
                If (.Left + (.Width / 2)) < (Paddle.Left + (Paddle.Width / 3)) Then
                    'Ball hit paddle on left third; apply english
                    nHorizontal = nHorizontal - 5
                    If nHorizontal < -15 Then nHorizontal = -15
                End If
                If (.Left + (.Width / 2)) > (Paddle.Left + (2 * Paddle.Width / 3)) Then
                    'Ball hit paddle on right third
                    nHorizontal = nHorizontal + 5
                    If nHorizontal > 15 Then nHorizontal = 15
                End If
            Else
                Beep 'missed
                'Move the paddle in case window was resized
                Paddle.Top = ActiveWindow.UsableHeight - 30
            End If
        End If
        If nTop < 20 Then
            nVertical = Abs(nVertical)
        End If
        
    End With
End Sub

Sub EndPong()
Attribute EndPong.VB_ProcData.VB_Invoke_Func = " \n14"
    Timer_Terminate
    Application.OnKey "{ESC}"
    Application.OnKey "{RIGHT}"
    Application.OnKey "{LEFT}"
    Application.OnKey "{F12}", "StartPong"
    Paddle.Delete
    Ball.Delete
End Sub


Sub MoveRight()
Attribute MoveRight.VB_ProcData.VB_Invoke_Func = " \n14"
    Paddle.Left = Paddle.Left + nSpeed
    If Paddle.Left > (Application.UsableWidth - 30 - Paddle.Width) Then
        Paddle.Left = Application.UsableWidth - 30 - Paddle.Width
    End If
End Sub

Sub MoveLeft()
Attribute MoveLeft.VB_ProcData.VB_Invoke_Func = " \n14"
    Paddle.Left = Paddle.Left - nSpeed
    If Paddle.Left < 0 Then
        Paddle.Left = 0
    End If
End Sub

Public Function AddrOf(strFuncName As String) As Long
'Returns a function pointer of a VBA public function given its name.
'AddrOf code from Microsoft Office Developer magazine
'http://www.informant.com/mod/index.htm
Dim hProject As Long
Dim lngResult As Long
Dim strID As String
Dim lpfn As Long
Dim strFuncNameUnicode As String
Const NO_ERROR = 0
    ' The function name must be in Unicode, so convert it.
    strFuncNameUnicode = StrConv(strFuncName, vbUnicode)
    ' Get the current VBA project
    Call GetCurrentVbaProject(hProject)
    ' Make sure we got a project handle
    If hProject <> 0 Then
        ' Get the VBA function ID
        lngResult = GetFuncID(hProject, strFuncNameUnicode, strID)
        If lngResult = NO_ERROR Then
            ' Get the function pointer.
            lngResult = GetAddr(hProject, strID, lpfn)
            If lngResult = NO_ERROR Then
                AddrOf = lpfn
            End If
        End If
    End If
End Function

Private Sub TimerProc(ByVal hwnd&, ByVal lngMsg&, ByVal lngTimerId&, ByVal lngTime&)
    Call MoveBall
End Sub

Sub Timer_Initialize(Optional vInterval As Variant)
Dim lngInterval As Long
    lngInterval = CLng(vInterval)
    If lngInterval = 0 Then lngInterval = 60 '60 milliseconds just a bit longer than a "tick"
    lngTimerId = SetTimer(0, 0, lngInterval, AddrOf("TimerProc"))
    If lngTimerId = 0 Then
        MsgBox "Unable to initialize a new timer!"
    End If
End Sub

Sub Timer_Terminate()
    If lngTimerId <> 0 Then
        Call KillTimer(0, lngTimerId)
    End If
End Sub