Windows10 64位新版Excel中VBA自定义MsgBox无提示崩溃

API 探路者

2026-5-7

Fix for Custom VBA MsgBox Crashing on Windows 10

I've run into similar issues with legacy VBA hook-based solutions after upgrading to Windows 10—changes to window management and security constraints often break older code that relies on low-level user32 APIs. Let's break down the fixes needed to get your custom MsgBox working again:

Key Issues in Your Code

Missing End If in RemovePropPointer: This syntax error was likely causing silent crashes before the hook even ran.
Commented-out SetProp Line: This line is critical for passing your clsMsgbox instance pointer to the hook procedure—without it, the hook can't access your custom button text.
Incorrect 64-bit Memory Handling: The original code copied only 4 bytes for object pointers on 64-bit systems, leading to memory corruption.
Win10 Window Activation Timing: The original hook logic needed minor adjustments to align with how Windows 10 creates and activates message boxes.

Fixed Code

1. Updated `modMsgbox` Module

Option Explicit
Private Const HCBT_ACTIVATE = 5
Private Const IDOK = 1
Private Const IDCANCEL = 2
Private Const IDABORT = 3
Private Const IDRETRY = 4
Private Const IDIGNORE = 5
Private Const IDYES = 6
Private Const IDNO = 7

#If Win64 Then
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Boolean
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Private Declare PtrSafe Function SetDlgItemText Lib "user32" Alias "SetDlgItemTextA" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal lpString As String) As Boolean
#Else
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Boolean
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function SetDlgItemText Lib "user32" Alias "SetDlgItemTextA" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal lpString As String) As Boolean
#End If

Private m_hWnd As LongPtr

Public Property Get hWndApplication() As LongPtr
    If m_hWnd = 0 Then
        If Application.Name = "Microsoft Excel" Then
            m_hWnd = FindWindow("XLMAIN", vbNullString)
        End If
    End If
    hWndApplication = m_hWnd
End Property

Public Function MsgBoxHookProc(ByVal uMsg As Long, _
                              ByVal wParam As LongPtr, _
                              ByVal lParam As Long) As Long
#If Win64 Then
    Dim lPtr As LongPtr
    Dim lProcHook As LongPtr
#Else
    Dim lPtr As Long
    Dim lProcHook As Long
#End If
    Dim cM As clsMsgbox
    
    Select Case uMsg
        Case HCBT_ACTIVATE
            lPtr = GetProp(hWndApplication, "ObjPtr")
            If (lPtr <> 0) Then
                Set cM = ObjectFromPtr(lPtr)
                If Not cM Is Nothing Then
                    ' Update button text based on the clsMsgbox instance
                    If Len(cM.ButtonText1) > 0 And Len(cM.ButtonText2) > 0 And Len(cM.ButtonText3) > 0 Then
                        If cM.UseCancel Then
                            Call SetDlgItemText(wParam, IDYES, cM.ButtonText1)
                            Call SetDlgItemText(wParam, IDNO, cM.ButtonText2)
                            Call SetDlgItemText(wParam, IDCANCEL, cM.ButtonText3)
                        Else
                            Call SetDlgItemText(wParam, IDABORT, cM.ButtonText1)
                            Call SetDlgItemText(wParam, IDRETRY, cM.ButtonText2)
                            Call SetDlgItemText(wParam, IDIGNORE, cM.ButtonText3)
                        End If
                    ElseIf Len(cM.ButtonText1) > 0 And Len(cM.ButtonText2) > 0 Then
                        If cM.UseCancel Then
                            Call SetDlgItemText(wParam, IDOK, cM.ButtonText1)
                            Call SetDlgItemText(wParam, IDCANCEL, cM.ButtonText2)
                        Else
                            Call SetDlgItemText(wParam, IDYES, cM.ButtonText1)
                            Call SetDlgItemText(wParam, IDNO, cM.ButtonText2)
                        End If
                    Else
                        If Len(cM.ButtonText1) > 0 Then
                            Call SetDlgItemText(wParam, IDOK, cM.ButtonText1)
                        End If
                    End If
                    lProcHook = cM.ProcHook
                End If
            End If
            RemovePropPointer
            If lProcHook <> 0 Then
                Call UnhookWindowsHookEx(lProcHook)
            End If
    End Select
    MsgBoxHookProc = False
End Function

#If Win64 Then
Private Property Get ObjectFromPtr(ByVal lPtr As LongPtr) As Object
    Dim obj As Object
    CopyMemory obj, lPtr, 8 ' Fixed for 64-bit: copy 8 bytes instead of 4
    Set ObjectFromPtr = obj
    CopyMemory obj, 0&, 8
End Property
#Else
Private Property Get ObjectFromPtr(ByVal lPtr As Long) As Object
    Dim obj As Object
    CopyMemory obj, lPtr, 4
    Set ObjectFromPtr = obj
    CopyMemory obj, 0&, 4
End Property
#End If

Public Sub RemovePropPointer()
#If Win64 Then
    Dim lPtr As LongPtr
#Else
    Dim lPtr As Long
#End If
    lPtr = GetProp(hWndApplication, "ObjPtr")
    If lPtr <> 0 Then
        Call RemoveProp(hWndApplication, "ObjPtr")
    End If ' Added missing End If
End Sub

2. Updated `clsMsgbox` Class

Option Explicit
Public Enum MessageBoxIcon
    NoIcon = 0
    Critical = &H10
    Question = &H20
    Exclamation = &H30
    Information = &H40
    DefaultButton1 = 0
    DefaultButton2 = &H100
    DefaultButton3 = &H200
End Enum
Public Enum MessageBoxReturn
    Unknown
    Button1
    Button2
    Button3
End Enum

Private Const m_sSource As String = "clsMsgbox"
Private Const GWL_HINSTANCE As Long = (-6)
Private Const WH_CBT = 5
Private Const MB_TASKMODAL = &H2000&

#If Win64 Then
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function MessageBoxA Lib "user32" (ByVal hwnd As LongPtr, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Boolean
#Else
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function MessageBoxA Lib "user32" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Boolean
#End If

Private m_sButtonText1 As String
Private m_sButtonText2 As String
Private m_sButtonText3 As String
Private m_sPrompt As String
Private m_sTitle As String
Private m_eIcon As MessageBoxIcon
Private m_bUseCancel As Boolean

#If Win64 Then
Private m_hInstance As LongPtr
Private m_lProcHook As LongPtr
#Else
Private m_hInstance As Long
Private m_lProcHook As Long
#End If
Private m_hThreadID As Long

Private Sub Class_Initialize()
#If Win64 Then
    m_hInstance = GetWindowLongPtr(hWndApplication, GWL_HINSTANCE)
#Else
    m_hInstance = GetWindowLong(hWndApplication, GWL_HINSTANCE)
#End If
    m_hThreadID = GetCurrentThreadId()
End Sub

Private Sub Class_Terminate()
    RemovePropPointer
End Sub

#If Win64 Then
Public Property Get ProcHook() As LongPtr
    ProcHook = m_lProcHook
End Property
#Else
Public Property Get ProcHook() As Long
    ProcHook = m_lProcHook
End Property
#End If

Public Property Get UseCancel() As Boolean
    UseCancel = m_bUseCancel
End Property
Public Property Let UseCancel(ByVal NewValue As Boolean)
    m_bUseCancel = NewValue
End Property

Public Property Let Prompt(ByVal NewValue As String)
    m_sPrompt = NewValue
End Property
Public Property Get Prompt() As String
    Prompt = m_sPrompt
End Property

Public Property Let Title(ByVal NewValue As String)
    m_sTitle = NewValue
End Property
Public Property Get Title() As String
    Title = m_sTitle
End Property

Public Property Let Icon(ByVal NewValue As MessageBoxIcon)
    m_eIcon = NewValue
End Property
Public Property Get Icon() As MessageBoxIcon
    Icon = m_eIcon
End Property

Public Property Let ButtonText1(ByVal NewValue As String)
    m_sButtonText1 = NewValue
End Property
Public Property Get ButtonText1() As String
    ButtonText1 = m_sButtonText1
End Property

Public Property Let ButtonText2(ByVal NewValue As String)
    m_sButtonText2 = NewValue
End Property
Public Property Get ButtonText2() As String
    ButtonText2 = m_sButtonText2
End Property

Public Property Let ButtonText3(ByVal NewValue As String)
    m_sButtonText3 = NewValue
End Property
Public Property Get ButtonText3() As String
    ButtonText3 = m_sButtonText3
End Property

Public Function MessageBox() As MessageBoxReturn
    Dim bCancel As Boolean
#If Win64 Then
    Dim lR As Long
    Dim lType As Long
#Else
    Dim lR As Long
    Dim lType As Long
#End If

    If m_hInstance = 0 Then
        Err.Raise vbObjectError + 1, m_sSource, "Instance handle not found"
    End If ' Added missing End If
    
    If m_hThreadID = 0 Then
        Err.Raise vbObjectError + 2, m_sSource, "Thread id not found"
    End If ' Added missing End If
    
    If Len(Me.Title) = 0 Then
        Me.Title = "Microsoft Excel"
    End If
    
    bCancel = Me.UseCancel
    
    ' Determine message box type based on button count
    If Len(Me.ButtonText1) > 0 And Len(Me.ButtonText2) > 0 And Len(Me.ButtonText3) > 0 Then
        lType = Me.Icon Or IIf(bCancel, vbYesNoCancel, vbAbortRetryIgnore)
    ElseIf Len(Me.ButtonText1) > 0 And Len(Me.ButtonText2) > 0 Then
        lType = Me.Icon Or IIf(bCancel, vbOKCancel, vbYesNo)
    Else
        If Len(Me.ButtonText1) = 0 Then
            Me.ButtonText1 = "OK"
        End If
        lType = Me.Icon Or vbOKOnly
    End If
    
    ' Set up hook
    m_lProcHook = SetWindowsHookEx(WH_CBT, AddressOf MsgBoxHookProc, m_hInstance, m_hThreadID)
    
    ' Store the class instance pointer (this was commented out before!)
    Call SetProp(hWndApplication, "ObjPtr", ObjPtr(Me))
    
    ' Show the message box
    lR = MessageBoxA(hWndApplication, Me.Prompt, Me.Title, lType Or MB_TASKMODAL)
    
    ' Map return value to our enum
    Select Case lR
        Case vbOK, vbYes, vbAbort
            MessageBox = Button1
        Case vbCancel, vbNo, vbRetry
            MessageBox = Button2
        Case vbIgnore
            MessageBox = Button3
        Case Else
            MessageBox = Unknown
    End Select
End Function

Public Function MessageBoxEx(ByVal Prompt As String, _
                            Optional Icon As MessageBoxIcon, _
                            Optional ByVal Title As String, _
                            Optional ByVal ButtonText1 As String, _
                            Optional ByVal ButtonText2 As String, _
                            Optional ByVal ButtonText3 As String) As MessageBoxReturn
    Me.Prompt = Prompt
    Me.Icon = Icon
    Me.Title = Title
    Me.ButtonText1 = ButtonText1
    Me.ButtonText2 = ButtonText2
    Me.ButtonText3 = ButtonText3
    MessageBoxEx = MessageBox
End Function

3. Updated Test Code

Sub UnitTest1()
    Dim cC As clsMsgbox
    Dim iR As MessageBoxReturn ' Changed to correct enum type
    
    Set cC = New clsMsgbox
    cC.UseCancel = True ' Explicitly set to use Cancel button set
    iR = cC.MessageBoxEx("Do you want to save the changes you made to whatever?", Exclamation + DefaultButton2, , "&Save", "Do&n't Save", "&Cancel")
    
    Select Case iR
        Case Button1
            Debug.Print "Button1 Clicked (Save)"
        Case Button2
            Debug.Print "Button2 Clicked (Don't Save)"
        Case Button3
            Debug.Print "Button3 Clicked (Cancel)"
        Case Unknown
            Debug.Print "Unknown Selection"
    End Select
End Sub

Critical Fixes Explained

Fixed 64-bit Memory Handling: Updated CopyMemory to copy 8 bytes for object pointers on 64-bit systems, eliminating memory corruption.
Restored SetProp Call: Re-enabled the line that stores the class instance pointer, which is essential for the hook to access custom button text.
Resolved Syntax Errors: Added missing End If statements that were causing silent crashes.
Updated API Declarations: Adjusted return types to match modern Windows API behavior, reducing unexpected errors.
Simplified Logic: Cleaned up return value mapping and button text assignment for better reliability on Windows 10.

This should resolve the crash issue and fully restore your custom message box functionality.

内容的提问来源于stack exchange，提问作者Matt

Windows10 64位新版Excel中VBA自定义MsgBox无提示崩溃

Key Issues in Your Code #

Fixed Code #

1. Updated modMsgbox Module #

2. Updated clsMsgbox Class #

3. Updated Test Code #