Freigeben über

More Updates for the VB6/VBA MouseWheelFix

  • Artikel

Here's an update to my old post on this VB6 addin.  Thanks to Louis for point out an issue where the code windows can actually scroll out of the view within the VB6 MDI child window. The source for the KB article hasn't been updated but you can replace the following function:

Function EnumChildProc(ByVal lhWnd As Long, ByVal lParam As Long) _
As Long
Dim RetVal As Long
Dim WinClassBuf As String * 255, WinTitleBuf As String * 255
Dim WinClass As String, WinTitle As String
Dim WinRect As RECT
Dim WinWidth As Long, WinHeight As Long

   RetVal = GetClassName(pthWnd, WinClassBuf, 255)
WinClass = StripNulls(WinClassBuf) ' remove extra Nulls & spaces
RetVal = GetWindowText(lhWnd, WinTitleBuf, 255)
WinTitle = StripNulls(WinTitleBuf)

' see the Windows Class and Title for each Child Window enumerated
Debug.Print " hWnd = " & Hex(lhWnd) & " Child Class = "; WinClass; ", Title = "; WinTitle
' You can find any type of Window by searching for its WinClass
Dim lret As Long
Dim i As Long

' Since we can have split windows we need to figure out which scroll bar to move.
' We can do this by comparing the Y position of the cursor against the vertical scrollbars
' that are children of the current window
Dim wi As WINDOWINFO
wi.cbSize = Len(wi)
If GetWindowInfo(lhWnd, wi) And WinClass <> "MDIClient" Then
If IsVerticalScrollBar(lhWnd) = True And wi.rcWindow.Top < YPos And wi.rcWindow.Bottom > YPos Then ' TextBox Window

If Delta > 0 Then ' Scroll Up
Do While i < Delta * lLineNumbers
lret = PostMessage(pthWnd, WM_VSCROLL, SB_LINEUP, lhWnd)
i = i + 1
Loop
Else ' Scroll Down
Do While i > Delta * lLineNumbers
lret = PostMessage(pthWnd, WM_VSCROLL, SB_LINEDOWN, lhWnd)
i = i - 1
Loop
End If
ElseIf IsHorizontalScrollBar(lhWnd) = True Then
If Delta > 0 Then ' Scroll Left
Do While i < Delta * lLineNumbers
lret = PostMessage(pthWnd, WM_HSCROLL, SB_LINELEFT, lhWnd)
i = i + 1
Loop
Else ' Scroll Right
Do While i > Delta * lLineNumbers
lret = PostMessage(pthWnd, WM_HSCROLL, SB_LINERIGHT, lhWnd)
i = i - 1
Loop
End If
End If
End If

EnumChildProc = bHook ' Continue enumerating the windows based on whether we are hooking or not

' It's possible that the addin has already been requested to unload and in such a case we will call free library on ourselves
' to reduce our ref count since we incremented it on our own so we can do a clean shutdown
If Not bHook Then
If Not FreeLibrary(hLib) Then
Debug.Print "Unable to FreeLibrary: " & Err.Number & vbCrLf & Err.LastDllError
End If
End If

End Function

Comments

  • Anonymous
    February 14, 2005
    Thank you, that seems to work fine now. The code windows no longer suddenly vanish.