在Windows 10 64位上的最新版本Excel中，自定义消息框代码失败，但未发出警告_Excel_Vba

在Windows 10 64位上的最新版本Excel中，自定义消息框代码失败，但未发出警告

excel vba

在Windows 10 64位上的最新版本Excel中，自定义消息框代码失败，但未发出警告,excel,vba,Excel,Vba,所以我在excel中使用这个自定义消息框按钮类已有几年了。今天运行代码时，它只是崩溃了，没有警告或消息。这段代码在运行Windows7时完全有效，我们公司今天决定在没有任何警告的情况下将所有人移动到Windows10。。。最初的开发者在网站上说他将其更新为64位，所以我认为这与Windows10有关原始网站已关闭，但您仍然可以使用way back机器访问内容和代码示例工作簿也可以下载，为方便起见，我还添加了链接模块代码： modMsgbox Option Explicit Priva

所以我在excel中使用这个自定义消息框按钮类已有几年了。今天运行代码时，它只是崩溃了，没有警告或消息。这段代码在运行Windows7时完全有效，我们公司今天决定在没有任何警告的情况下将所有人移动到Windows10。。。最初的开发者在网站上说他将其更新为64位，所以我认为这与Windows10有关

原始网站已关闭，但您仍然可以使用way back机器访问内容和代码

示例工作簿也可以下载，为方便起见，我还添加了链接

模块代码： modMsgbox

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 Long
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As LongPtr
    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 Long
    Private Declare PtrSafe Function SetDlgItemText Lib "user32" Alias "SetDlgItemTextA" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As LongPtr, ByVal lpString As String) As LongPtr
#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 Long
    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 Long
#End If

Private m_hWnd As Long

Public Property Get hWndApplication() As Long
    If m_hWnd = 0 Then
        If Application.Name = "Microsoft Access" Then
             m_hWnd = FindWindow("OMain", vbNullString)
        ElseIf Application.Name = "Microsoft Word" Then
            m_hWnd = FindWindow("OpusApp", vbNullString)
        ElseIf 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 Long, _
                                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
                    If Len(cM.ButtonText1) > 0 And Len(cM.ButtonText2) > 0 And Len(cM.ButtonText3) > 0 Then
                        If cM.UseCancel Then
                            SetDlgItemText wParam, IDYES, cM.ButtonText1
                            SetDlgItemText wParam, IDNO, cM.ButtonText2
                            SetDlgItemText wParam, IDCANCEL, cM.ButtonText3
                        Else
                            SetDlgItemText wParam, IDABORT, cM.ButtonText1
                            SetDlgItemText wParam, IDRETRY, cM.ButtonText2
                            SetDlgItemText wParam, IDIGNORE, cM.ButtonText3
                        End If

                    ElseIf Len(cM.ButtonText1) > 0 And Len(cM.ButtonText2) Then
                        If cM.UseCancel Then
                            SetDlgItemText wParam, IDOK, cM.ButtonText1
                            SetDlgItemText wParam, IDCANCEL, cM.ButtonText2
                        Else
                            SetDlgItemText wParam, IDYES, cM.ButtonText1
                            SetDlgItemText wParam, IDNO, cM.ButtonText2
                        End If
                    Else
                        SetDlgItemText wParam, IDOK, cM.ButtonText1
                    End If
                    lProcHook = cM.ProcHook
                End If
            End If
            RemovePropPointer
            If lProcHook <> 0 Then UnhookWindowsHookEx lProcHook
    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, 4
        Set ObjectFromPtr = obj
        CopyMemory obj, 0&, 4
    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 RemoveProp hWndApplication, "ObjPtr"
End Sub

创建消息框的简单代码

Sub UnitTest1()
    Dim cC As clsMsgbox
    Dim iR As Integer

    Set cC = New clsMsgbox
    iR = cC.MessageBoxEx("Do you want to save the changes you made to whatever?", Exclamation + DefaultButton2, , "&Save", "Do&n't Save", "&Cancel")
    If iR = Button1 Then
        Debug.Print "Button1 Clicked"
    ElseIf iR = Button2 Then
        Debug.Print "Button2 Clicked"
    ElseIf iR = Button3 Then
        Debug.Print "Button3 Clicked"
    End If
end sub

我在IDE中设置了一个停止点，应用程序在类中的图片中崩溃。当注释掉该行时，代码起作用，但按钮没有指定的自定义标签

您对

MessageBoxA

函数的声明是错误的。对于Office 64位，它需要：

Declare PtrSafe Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hwnd As LongPtr, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long

hwnd

需要

LongPtr

和

wType

需要

Long

并且整个函数（返回值）也需要

Long

您可以在以下网址查阅：

检查你所有的其他声明，看起来也有其他一些错误

我希望我得到了一切，而不是监督什么。请查看：

modMsgBox

下载链接刚刚被更正a）这里可能没有人会从可疑来源下载启用宏的文件（这就是为什么您不能在SO上上载文件）和b）。请在问题本身中包含重现/理解问题所需的代码（并将其格式化为代码块），或提供问题的详细信息。当您说“应用程序崩溃”时，它是什么意思？Excel强制关闭吗？它是否显示任何错误消息或异常您的函数declare语句被注释掉了，因此它不起作用，如果您要使用它，我认为

hwnd

的类型应该是

LongPtr

而不是

Long

。它只是在没有警告的情况下关闭应用程序。让我发布类代码，这应该是唯一需要的代码。当我更正行时，我会尝试将它们转换为正确的类型。您建议它会给我类型不匹配，因此我假设代码中充斥着与之相关的问题，实际上是的，它充满了错误。由于使用了

Option Explicit

，您应该得到的第一个错误是在第行

m_hInstance=GetWindowLong（CLngPtr（hWndApplication），GWL_hInstance）

，因为没有声明

hWndApplication

。在使用变量之前，请确保将所有变量声明为正确的类型。我没有像使用VBA时那样编写原始代码。我对这个领域并不熟悉with@MatthewLozoya代码有点乱，我希望我现在就知道了。过来看。你必须确保everywhere是正确的类型。如果一个

LongPtr

和

Long

混淆，则它不起作用。特别是在类似于

CopyMemory obj，0&，4的情况下，函数将等待LongPtr
作为最后一个参数，以确保您需要执行CopyMemory obj，CLngPtr（0&），CLngPtr（4）
Declare PtrSafe Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hwnd As LongPtr, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long

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 Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As LongPtr)
    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 Long
#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 Long
    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 Long
#End If

#If Win64 Then
    Private m_hWnd As LongPtr
#Else
    Private m_hWnd As Long
#End If

#If Win64 Then
Public Property Get hWndApplication() As LongPtr
#Else
Public Property Get hWndApplication() As Long
#End If
    If m_hWnd = 0 Then
        If Application.Name = "Microsoft Access" Then
             m_hWnd = FindWindow("OMain", vbNullString)
        ElseIf Application.Name = "Microsoft Word" Then
            m_hWnd = FindWindow("OpusApp", vbNullString)
        ElseIf Application.Name = "Microsoft Excel" Then
            m_hWnd = FindWindow("XLMAIN", vbNullString)
        End If
    End If
    hWndApplication = m_hWnd
End Property

#If Win64 Then
Public Function MsgBoxHookProc(ByVal uMsg As Long, _
                                ByVal wParam As LongPtr, _
                                ByVal lParam As LongPtr) As LongPtr
#Else
Public Function MsgBoxHookProc(ByVal uMsg As Long, _
                                ByVal wParam As Long, _
                                ByVal lParam As Long) As Long
#End If

    #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
                    If Len(cM.ButtonText1) > 0 And Len(cM.ButtonText2) > 0 And Len(cM.ButtonText3) > 0 Then
                        If cM.UseCancel Then
                            SetDlgItemText wParam, IDYES, cM.ButtonText1
                            SetDlgItemText wParam, IDNO, cM.ButtonText2
                            SetDlgItemText wParam, IDCANCEL, cM.ButtonText3
                        Else
                            SetDlgItemText wParam, IDABORT, cM.ButtonText1
                            SetDlgItemText wParam, IDRETRY, cM.ButtonText2
                            SetDlgItemText wParam, IDIGNORE, cM.ButtonText3
                        End If

                    ElseIf Len(cM.ButtonText1) > 0 And Len(cM.ButtonText2) Then
                        If cM.UseCancel Then
                            SetDlgItemText wParam, IDOK, cM.ButtonText1
                            SetDlgItemText wParam, IDCANCEL, cM.ButtonText2
                        Else
                            SetDlgItemText wParam, IDYES, cM.ButtonText1
                            SetDlgItemText wParam, IDNO, cM.ButtonText2
                        End If
                    Else
                        SetDlgItemText wParam, IDOK, cM.ButtonText1
                    End If
                    lProcHook = cM.ProcHook
                End If
            End If
            RemovePropPointer
            If lProcHook <> 0 Then UnhookWindowsHookEx lProcHook
    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, CLngPtr(4)
        Set ObjectFromPtr = obj
        CopyMemory obj, CLngPtr(0&), CLngPtr(4)
    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 RemoveProp hWndApplication, "ObjPtr"
End Sub

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 As Long = 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 Long
#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 Long
#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
    Dim lR As Long
    Dim lType As Long


    If Not m_hInstance > 0 Then Err.Raise vbObjectError + 1, m_sSource, "Instance handle not found"
    If Not m_hThreadID > 0 Then Err.Raise vbObjectError + 2, m_sSource, "Thread id not found"

    If Len(Me.Title) = 0 Then Me.Title = "Microsoft Excel"
    bCancel = Me.UseCancel

    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) Then
        lType = Me.Icon Or IIf(bCancel, vbOKCancel, vbYesNo)
    Else
        If Len(Me.ButtonText1) = 0 Then Me.ButtonText1 = "OK"
        lType = Me.Icon Or vbOKOnly
    End If

    m_lProcHook = SetWindowsHookEx(WH_CBT, _
                                   AddressOf MsgBoxHookProc, _
                                   m_hInstance, _
                                   m_hThreadID)


    'Private Declare PtrSafe Function MessageBoxA Lib "user32" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As LongPtr) As LongPtr
    'SetProp hWndApplication, "ObjPtr", PtrFromObject(Me)

    lR = MessageBoxA(hWndApplication, Me.Prompt, Me.Title, lType Or MB_TASKMODAL)

    If Len(Me.ButtonText1) > 0 And Len(Me.ButtonText2) > 0 And Len(Me.ButtonText3) > 0 Then
        If lR = IIf(bCancel, vbYes, vbAbort) Then
            MessageBox = Button1
        ElseIf lR = IIf(bCancel, vbNo, vbRetry) Then
            MessageBox = Button2
        ElseIf lR = IIf(bCancel, vbCancel, vbIgnore) Then
            MessageBox = Button3
        End If
    ElseIf Len(Me.ButtonText1) > 0 And Len(Me.ButtonText2) Then
        If lR = IIf(bCancel, vbOK, vbYes) Then
            MessageBox = Button1
        ElseIf lR = IIf(bCancel, vbCancel, vbNo) Then
            MessageBox = Button2
        End If
    Else
        If lR = vbOK Then
            MessageBox = Button1
        End If
    End If
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
#If Win64 Then
    Private Property Get PtrFromObject(ByRef obj As Object) As LongPtr
        PtrFromObject = ObjPtr(obj)
    End Property
#Else
    Private Property Get PtrFromObject(ByRef obj As Object) As Long
        PtrFromObject = ObjPtr(obj)
    End Property
#End If