VBA Excel, Game Component? - excel

Question

I was researching different components of VBA and APIs and came across a website that proposes a personalized API that runs the game Pong within a spreadsheet that contains certain subs and functions. The instance used was with Windows/Excel version 97 and is stated to not be compatible with the 2000 version (and, I am assuming, the current version). I was wondering if any VBA-savvy individuals who thought this was worth doing could let me know whether this is a function capable of implementing under the current iteration of Excel, and if so, what the workaround would be?
When I use the following code below, I get a run-time error declaring that
vba332.dll is missing
the debugger highlights the 9th line of the Public Function AddrOf which states:Call GetCurrentVbaProject (hProject) is the error line and (hProject) when hovered on is 0, which I am assuming is also a problem as it is supposed to be getting a value other than 0 to move forward...
According to some reading that I have found, the newer version of the referenced .dll would be something like:
vbe7.dll
But when I have substituted that line within this string of codes, it still does not return any data for the Declare Function.
This seemed like a fun API to play around with, but I could not devise a way to upgrade it to the current Excel version. The code:
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()
Timer_Terminate
On Error Resume Next
Paddle.Delete
Ball.Delete
End Sub
Sub StartPong()
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()
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()
Timer_Terminate
Application.OnKey "{ESC}"
Application.OnKey "{RIGHT}"
Application.OnKey "{LEFT}"
Application.OnKey "{F12}", "StartPong"
Paddle.Delete
Ball.Delete
End Sub
Sub MoveRight()
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()
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
Thanks!

Answer 1

In later versions of Office, "TipGetLpfnOfFunctionId" is exposed as AddressOf.
And since you can use AddressOf directly to get the address of a function, you don't need "TipGetFunctionId" nor all the "addrof" code.
Sub Timer_Initialize(Optional vInterval As Variant)
Dim lngInterval As Long
lngInterval = CLng(vInterval)
If lngInterval = 0 Then lngInterval = 60
lngTimerId = SetTimer(0, 0, lngInterval, AddressOf TimerProc)
If lngTimerId = 0 Then
MsgBox "Unable to initialize a new timer!"
End If
End Sub
Note the unique syntax of the "AddressOf" operator: it's not a function.