VBA Excel，游戏组件？
我正在研究VBA和API的不同组件，并且遇到了一个网站 ，该网站提出了一个个性化的API，在一个电子表格中运行Pong游戏，该游戏包含特定的子目录和function。 使用的实例是Windows / Excel版本97，并声明不兼容2000版本（和，我假设，当前版本）。 我想知道是否有谁认为这是值得做的VBA精明的个人可以让我知道这是否是一个函数能够实现在当前迭代的Excel下，如果是的话，这个解决方法是什么？
当我使用下面的代码时，我得到一个运行时错误声明
vba332.dll丢失
debugging器将突出显示Public Function AddrOf的第9行，其中指出：
Call GetCurrentVbaProject (hProject)
是错误行和(hProject)当徘徊在0 ，我假设也是一个问题，因为它应该得到一个值不是0向前移动…
根据我发现的一些阅读，引用的.dll的较新版本会是这样的：
vbe7.dll
但是当我在这段代码中replace那行时，它仍然不会为Declare Function返回任何数据。
这似乎是一个有趣的API玩，但我不能想出一种方法来升级到当前的Excel版本。 代码：
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
谢谢！
在更高版本的Office中，“TipGetLpfnOfFunctionId”显示为AddressOf。
由于您可以直接使用AddressOf来获取函数的地址，所以不需要“TipGetFunctionId”也不需要所有的“addrof”代码。
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
请注意“AddressOf”运算符的唯一语法：它不是一个函数。