|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
我把frm.LISTBOX1 改成了表名sheets("明细登记".LISTBOX1 , 为什么我该表格里面弹出的窗体还是不能滚动列表呢？期待老师的回复.
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 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
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 Long
Private mListBoxHwnd As Long
Private mbHook As Boolean
Public LISTBOX_Post_Flag As Integer
Public LISTBOX_Mouse_Flag As Integer
Sub HookListBoxScroll()
Dim lngAppInst As Long
Dim hwndUnderCursor As Long
Dim tPT As POINTAPI
GetCursorPos tPT
hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
If mListBoxHwnd <> hwndUnderCursor Then
UnhookListBoxScroll
mListBoxHwnd = hwndUnderCursor
lngAppInst = GetWindowLong(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 Long
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("明细登记").ListBox1.TopIndex = Sheets("明细登记").ListBox1.TopIndex - 1
If LISTBOX_Post_Flag = 1 And LISTBOX_Mouse_Flag = 2 Then PostMessage mListBoxHwnd, WM_KEYDOWN, VK_UP, 0
Else
If LISTBOX_Post_Flag = 1 And LISTBOX_Mouse_Flag = 1 Then Sheets("明细登记").ListBox1.TopIndex = Sheets("明细登记").ListBox1.TopIndex + 1
If LISTBOX_Post_Flag = 1 And LISTBOX_Mouse_Flag = 2 Then PostMessage mListBoxHwnd, WM_KEYDOWN, VK_DOWN, 0
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
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2021-2-19 09:11
楼主
