Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,621
- Office Version
- 2016
- Platform
- Windows
Hi all,
I have long looked for code that makes the mousewheel scroll the VBE code panes but I could only find some external programmes or dlls written in C.
with a bit of trial and error and a couple of tricks, i have put together this code done purely with VBA as you can see which I hope will be stable enough and will work accross different excel,OS versions.
Proceedings :
Just add the 2 parts of the below code to a normal workbook and save it as an AddIn (.xla) and set its IsAddin Property to TRUE in the Property window.
Once the addin is installed, the MouseWheel should hopefully work inside the VBA editor.
Code :
1- Put this code in a Standard module :
2- And this code is to be placed in the Workbook module :
A word of caution. Although the code worked fine for me and seemed stable , it may not be the same for other systems so please save your work before testing it !
Any comments & suggestions most welcome.
Tested on excel2003 XP.
Regards.
I have long looked for code that makes the mousewheel scroll the VBE code panes but I could only find some external programmes or dlls written in C.
with a bit of trial and error and a couple of tricks, i have put together this code done purely with VBA as you can see which I hope will be stable enough and will work accross different excel,OS versions.
Proceedings :
Just add the 2 parts of the below code to a normal workbook and save it as an AddIn (.xla) and set its IsAddin Property to TRUE in the Property window.
Once the addin is installed, the MouseWheel should hopefully work inside the VBA editor.
Code :
1- Put this code in a Standard module :
Code:
Option Explicit
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
Private Declare Function GetWindowLong Lib "user32" _
Alias "GetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
Private Declare Function GetClassName Lib "user32" _
Alias "GetClassNameA" _
(ByVal hwnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount 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 Type POINTAPI
X As Long
Y As Long
End Type
Private Type MSLLHOOKSTRUCT
pt As POINTAPI
mouseData As Long
flags As Long
time 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_VSCROLL As Long = &H115
Private Const SB_LINEUP As Long = 0
Private Const SB_LINEDOWN As Long = 1
Private Const SB_ENDSCROLL As Long = 8
Private lMouseHook As Long
Public oNewApp As Application
Sub SetMouseHook()
If lMouseHook <> 1 Then
lMouseHook = SetWindowsHookEx _
(WH_MOUSE_LL, _
AddressOf LowLevelMouseProc, GetAppInstance, 0)
End If
End Sub
Sub UnHookMouse()
UnhookWindowsHookEx lMouseHook
lMouseHook = 0
End Sub
Private Function LowLevelMouseProc _
(ByVal nCode As Long, ByVal wParam As Long, _
ByRef lParam As MSLLHOOKSTRUCT) As Long
Dim RetVal As Long, lpClassName As String
Dim lTargetWndhwnd As Long, lVertSBhwnd As Long
On Error Resume Next
If (nCode = HC_ACTION) Then
If wParam = WM_MOUSEWHEEL Then
lTargetWndhwnd = WindowFromPoint(lParam.pt.X, lParam.pt.Y)
lpClassName = Space(256)
RetVal = GetClassName(lTargetWndhwnd, lpClassName, 256)
If UCase(Left$(lpClassName, RetVal)) _
= UCase("vbaWindow") Then
LowLevelMouseProc = True
lVertSBhwnd = FindWindowEx _
(lTargetWndhwnd, 0, "ScrollBar", vbNullString)
lVertSBhwnd = FindWindowEx _
(lTargetWndhwnd, lVertSBhwnd, "ScrollBar", vbNullString)
If lParam.mouseData > 0 Then 'mousewheel up.
PostMessage _
lTargetWndhwnd, WM_VSCROLL, 2, lVertSBhwnd
Else
PostMessage _
lTargetWndhwnd, WM_VSCROLL, 3, lVertSBhwnd
End If
PostMessage _
lTargetWndhwnd, WM_VSCROLL, SB_ENDSCROLL, lVertSBhwnd
End If
End If
End If
LowLevelMouseProc = _
CallNextHookEx(lMouseHook, nCode, wParam, ByVal lParam)
End Function
Private Function GetAppInstance() As Long
GetAppInstance = GetWindowLong _
(FindWindow("XLMAIN", Application.Caption), GWL_HINSTANCE)
End Function
Sub CreateServerApp()
If Len(Dir("C:\Ghost.xls")) = 0 Then
ThisWorkbook.SaveCopyAs "C:\Ghost.xls"
Set oNewApp = New Application
With oNewApp
.IgnoreRemoteRequests = True
.Workbooks.Open "C:\Ghost.xls"
.EnableEvents = False
.Visible = False
.Run "Ghost.xls!SetMouseHook"
End With
End If
End Sub2- And this code is to be placed in the Workbook module :
Code:
Option Explicit
Private Sub Workbook_AddinInstall()
MsgBox "VBE MouseWheel installed", vbInformation
End Sub
Private Sub Workbook_AddinUninstall()
MsgBox "VBE MouseWheel Uninstalled", vbInformation
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
If ThisWorkbook.IsAddin Then
With oNewApp
.Run "Ghost.xls!UnHookMouse"
.IgnoreRemoteRequests = False
.Workbooks("Ghost.xls").Close False
.Quit
End With
If Len(Dir("C:\Ghost.xls")) <> 0 Then
Kill (("C:\Ghost.xls"))
End If
End If
End Sub
Private Sub Workbook_Open()
If ThisWorkbook.IsAddin Then
Call UnHookMouse
Call CreateServerApp
End If
End SubA word of caution. Although the code worked fine for me and seemed stable , it may not be the same for other systems so please save your work before testing it !
Any comments & suggestions most welcome.
Tested on excel2003 XP.
Regards.
