32位上能运行的宏程序在64位上出错了

ykcbf1100

试了一下，如果就单纯的把Declare改为Declare PtrSafe还会出现这样的错误提示。后面不知道如何改了。

阿黑123456

ykcbf1100 发表于 2023-3-17 15:25
试了一下，如果就单纯的把Declare改为Declare PtrSafe还会出现这样的错误提示。后面不知道如何改了。

是的，后面很多提示类型不匹配

阿黑123456

让GPT修改的，可以用！牛！哈哈哈
Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function FindWindow Lib "user32" _
                                    Alias "FindWindowA" ( _
                                                         ByVal lpClassName As String, _
                                                         ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function GetWindowLongPtr Lib "user32.dll" _
                                       Alias "GetWindowLongA" ( _
                                                               ByVal hwnd As LongPtr, _
                                                               ByVal nIndex As Long) As LongPtr
    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 CallNextHookEx Lib "user32" ( _
                                                      ByVal hHook As LongPtr, _
                                                      ByVal nCode As Long, _
                                                      ByVal wParam As LongPtr, _
                                                      lParam As Any) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
                                                           ByVal hHook As LongPtr) As LongPtr
    Private Declare PtrSafe Function PostMessage Lib "user32.dll" _
                                     Alias "PostMessageA" ( _
                                                           ByVal hwnd As LongPtr, _
                                                           ByVal wMsg As Long, _
                                                           ByVal wParam As LongPtr, _
                                                           ByVal lParam As LongPtr) As LongPtr
    Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
                                                       ByVal xPoint As Long, _
                                                       ByVal yPoint As Long) As LongPtr
    Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" ( _
                                                        ByRef lpPoint As POINTAPI) As LongPtr
#Else
    Private Declare Function FindWindow Lib "user32" _
                                    Alias "FindWindowA" ( _
                                                         ByVal lpClassName As String, _
                                                         ByVal lpWindowName As String) As Long
    Private Declare Function GetWindowLong Lib "user32.dll" _
                                       Alias "GetWindowLongA" ( _
                                                               ByVal hwnd As Long, _
                                                               ByVal nIndex As Long) 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 CallNextHookEx Lib "user32" ( _
                                                      ByVal hHook As Long, _
                                                      ByVal nCode As Long, _
                                                      ByVal wParam As Long, _
                                                      lParam As Any) As Long
    Private Declare Function UnhookWindowsHookEx Lib "user32" ( _
                                                           ByVal hHook As Long) As Long
    Private Declare Function PostMessage Lib "user32.dll" _
                                     Alias "PostMessageA" ( _
                                                           ByVal hwnd As Long, _
                                                           ByVal wMsg As Long, _
                                                           ByVal wParam As Long, _
                                                           ByVal lParam As Long) As Long
    Private Declare Function WindowFromPoint Lib "user32" ( _
                                                       ByVal xPoint As Long, _
                                                       ByVal yPoint As Long) As Long
    Private Declare Function GetCursorPos Lib "user32.dll" ( _
                                                        ByRef lpPoint As POINTAPI) As Long
#End If

Private Type POINTAPI
    x As Long
    Y As Long
End Type

Private Type MOUSEHOOKSTRUCT
    pt As POINTAPI
    hwnd As Long
    wHitTestCode As Long
    dwExtraInfo As Long
End Type

Private Const WH_MOUSE_LL As Long = 14
Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const HC_ACTION As Long = 0
Private Const GWL_HINSTANCE As Long = (-6)
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const VK_UP As Long = &H26
Private Const VK_DOWN As Long = &H28
Private Const WM_LBUTTONDOWN As Long = &H201

Private mLngMouseHook As LongPtr
Private mListBoxHwnd As LongPtr
Private mbHook As Boolean

Public LISTBOX_Post_Flag As Integer
Public LISTBOX_Mouse_Flag As Integer

Sub HookListBoxScroll()
    Dim lngAppInst As LongPtr
    Dim hwndUnderCursor As LongPtr
    Dim tPT As POINTAPI
   
    GetCursorPos tPT
    hwndUnderCursor = WindowFromPoint(tPT.x, tPT.Y)
   
    If mListBoxHwnd <> hwndUnderCursor Then
        UnhookListBoxScroll
        mListBoxHwnd = hwndUnderCursor
        lngAppInst = GetWindowLongPtr(mListBoxHwnd, GWL_HINSTANCE)
        
        PostMessage mListBoxHwnd, WM_LBUTTONDOWN, 0&, 0&
        
        If Not mbHook Then
            mLngMouseHook = SetWindowsHookEx( _
                                             WH_MOUSE_LL, _
                                             AddressOf MouseProc, _
                                             lngAppInst, _
                                             0)
            
            mbHook = mLngMouseHook <> 0
        End If
    End If
End Sub

Sub UnhookListBoxScroll()
    If mbHook Then
        UnhookWindowsHookEx mLngMouseHook
        mLngMouseHook = 0
        mListBoxHwnd = 0
        mbHook = False
    End If
End Sub

Private Function MouseProc( _
                           ByVal nCode As Long, ByVal wParam As Long, _
                           ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
    On Error GoTo errH    'Resume Next
   
    If (nCode = HC_ACTION) Then
        If WindowFromPoint(lParam.pt.x, lParam.pt.Y) = mListBoxHwnd Then
            If wParam = WM_MOUSEWHEEL Then
                MouseProc = True
               
                If lParam.hwnd > 0 Then
                    If LISTBOX_Post_Flag = 1 And LISTBOX_Mouse_Flag = 1 Then
                        Sheets("Sheet1").ListBox1.TopIndex = Sheets("Sheet1").ListBox1.TopIndex - 1
                    End If
                    
                    If LISTBOX_Post_Flag = 1 And LISTBOX_Mouse_Flag = 2 Then
                        PostMessage mListBoxHwnd, WM_KEYDOWN, VK_UP, 0
                    End If
                    
                Else
                    If LISTBOX_Post_Flag = 1 And LISTBOX_Mouse_Flag = 1 Then
                        Sheets("Sheet1").ListBox1.TopIndex = Sheets("Sheet1").ListBox1.TopIndex + 1
                    End If
                    
                    If LISTBOX_Post_Flag = 1 And LISTBOX_Mouse_Flag = 2 Then
                        PostMessage mListBoxHwnd, WM_KEYDOWN, VK_DOWN, 0
                    End If
                End If
               
                PostMessage mListBoxHwnd, WM_KEYUP, VK_UP, 0
               
                Exit Function
            End If
        Else
            UnhookListBoxScroll
        End If
    End If
   
    MouseProc = CallNextHookEx( _
                               mLngMouseHook, _
                               nCode, _
                               wParam, _
                               ByVal lParam)
   
    Exit Function

errH:
    UnhookListBoxScroll
End Function

wodewan

WH_MOUSE_LL As Long = 14  最好也改了，全局的，不卡吗？

阿黑123456

wodewan 发表于 2023-3-17 19:05
WH_MOUSE_LL As Long = 14  最好也改了，全局的，不卡吗？

好像不能滚动了。期望的功能是鼠标处于列表框区域时能随滚轮滚动。

ivccav

可参https://club.excelhome.net/forum.php?mod=viewthread&tid=1656964&extra=