32位开发的VBA代码在64位环境下出现VarPtr Type Mismatch Error

我正在使用64位VBA，现有代码为32位环境开发版本。执行Public Function Hook() As Boolean函数时，VarPtr处出现Type Mismatch Error，原代码如下：

Option Explicit

Private Const PAGE_EXECUTE_READWRITE = &H40

Private Declare PtrSafe Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
        (Destination As Long, Source As Long, ByVal Length As Long)

Private Declare PtrSafe Function VirtualProtect Lib "kernel32" (lpAddress As Long, _
        ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long

Private Declare PtrSafe Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long

Private Declare PtrSafe Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, _
        ByVal lpProcName As String) As Long

Private Declare PtrSafe Function DialogBoxParam Lib "User32" Alias "DialogBoxParamA" (ByVal hInstance As Long, _
        ByVal pTemplateName As Long, ByVal hWndParent As Long, _
        ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer

Dim HookBytes(0 To 5) As Byte
Dim OriginBytes(0 To 5) As Byte
Dim pFunc As Long
Dim Flag As Boolean

Private Function GetPtr(ByVal Value As Long) As Long
    GetPtr = Value
End Function

Public Sub RecoverBytes()
    If Flag Then MoveMemory ByVal pFunc, ByVal VarPtr(OriginBytes(0)), 6
End Sub

Public Function Hook() As Boolean
    Dim TmpBytes(0 To 5) As Byte
    Dim p As Long
    Dim OriginProtect As Long

    Hook = False

    pFunc = GetProcAddress(GetModuleHandleA("user32.dll"), "DialogBoxParamA")

    If VirtualProtect(ByVal pFunc, 6, PAGE_EXECUTE_READWRITE, OriginProtect) <> 0 Then
        MoveMemory ByVal VarPtr(TmpBytes(0)), ByVal pFunc, 6
        If TmpBytes(0) <> &H68 Then
            MoveMemory ByVal VarPtr(OriginBytes(0)), ByVal pFunc, 6

            p = GetPtr(AddressOf MyDialogBoxParam)

            HookBytes(0) = &H68
            MoveMemory ByVal VarPtr(HookBytes(1)), ByVal VarPtr(p), 4
            HookBytes(5) = &HC3

            MoveMemory ByVal pFunc, ByVal VarPtr(HookBytes(0)), 6
            Flag = True
            Hook = True
        End If
    End If
End Function

问题原因 #

32位VBA中指针使用Long类型（4字节），但64位VBA中指针需要用LongPtr类型（8字节）。原代码中所有指针相关的变量、API参数都沿用了32位的Long类型，导致VarPtr返回的64位地址无法匹配Long变量，触发类型不匹配错误。此外，32位的跳转指令（&H68+4字节地址+&HC3）也不适用于64位系统，需要调整指令格式。

修正后的代码 #

Option Explicit

Private Const PAGE_EXECUTE_READWRITE = &H40

' 修正API声明：指针参数改为LongPtr类型
Private Declare PtrSafe Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
        (Destination As Any, Source As Any, ByVal Length As LongLong)

Private Declare PtrSafe Function VirtualProtect Lib "kernel32" (ByVal lpAddress As LongPtr, _
        ByVal dwSize As LongLong, ByVal flNewProtect As Long, ByVal lpflOldProtect As LongPtr) As Long

Private Declare PtrSafe Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As LongPtr

Private Declare PtrSafe Function GetProcAddress Lib "kernel32" (ByVal hModule As LongPtr, _
        ByVal lpProcName As String) As LongPtr

Private Declare PtrSafe Function DialogBoxParam Lib "User32" Alias "DialogBoxParamA" (ByVal hInstance As LongPtr, _
        ByVal pTemplateName As LongPtr, ByVal hWndParent As LongPtr, _
        ByVal lpDialogFunc As LongPtr, ByVal dwInitParam As LongPtr) As Integer

' 64位跳转指令需要14字节空间
Dim HookBytes(0 To 13) As Byte
Dim OriginBytes(0 To 13) As Byte
Dim pFunc As LongPtr
Dim Flag As Boolean

Private Function GetPtr(ByVal Value As LongPtr) As LongPtr
    GetPtr = Value
End Function

Public Sub RecoverBytes()
    If Flag Then MoveMemory ByVal pFunc, ByVal VarPtr(OriginBytes(0)), 14
End Sub

Public Function Hook() As Boolean
    Dim TmpBytes(0 To 13) As Byte
    Dim p As LongPtr
    Dim OriginProtect As LongPtr

    Hook = False

    pFunc = GetProcAddress(GetModuleHandleA("user32.dll"), "DialogBoxParamA")

    ' 申请14字节的可读写执行权限
    If VirtualProtect(pFunc, 14, PAGE_EXECUTE_READWRITE, OriginProtect) <> 0 Then
        MoveMemory ByVal VarPtr(TmpBytes(0)), ByVal pFunc, 14
        ' 检查是否已被Hook（64位跳转指令首字节为&HFF）
        If TmpBytes(0) <> &HFF Then
            MoveMemory ByVal VarPtr(OriginBytes(0)), ByVal pFunc, 14

            p = GetPtr(AddressOf MyDialogBoxParam)

            ' 64位跳转指令：JMP QWORD PTR [RIP+0]，后续8字节为目标地址
            HookBytes(0) = &HFF
            HookBytes(1) = &H25
            HookBytes(2) = &H00
            HookBytes(3) = &H00
            HookBytes(4) = &H00
            HookBytes(5) = &H00
            ' 写入目标函数地址（8字节）
            MoveMemory ByVal VarPtr(HookBytes(6)), ByVal VarPtr(p), 8

            ' 写入Hook指令
            MoveMemory ByVal pFunc, ByVal VarPtr(HookBytes(0)), 14
            Flag = True
            Hook = True
        End If
    End If
End Function

' 示例Hook回调函数（需根据实际需求实现）
Private Function MyDialogBoxParam(ByVal hInstance As LongPtr, ByVal pTemplateName As LongPtr, _
        ByVal hWndParent As LongPtr, ByVal lpDialogFunc As LongPtr, ByVal dwInitParam As LongPtr) As Integer
    ' 这里添加自定义逻辑
    ' 调用原函数（如果需要）
    MyDialogBoxParam = DialogBoxParam(hInstance, pTemplateName, hWndParent, lpDialogFunc, dwInitParam)
End Function

关键修改点 #

• 所有指针类型的变量（如pFunc、p）和API参数替换为LongPtr，适配64位8字节地址空间
• 调整HookBytes、OriginBytes、TmpBytes的长度为14字节，适配64位跳转指令的长度
• 修改MoveMemory的参数为As Any，避免类型匹配问题，同时长度参数改为LongLong
• 替换32位跳转指令为64位兼容的JMP QWORD PTR [RIP+0]指令，确保在64位系统中正确跳转
• 修正VirtualProtect的参数类型，确保权限修改操作正常执行

内容的提问来源于stack exchange，提问作者Devesh Kumar oe21m006