Skip to content

Instantly share code, notes, and snippets.

@sancarn

sancarn/README.MD

Created June 3, 2019 10:08
Show Gist options
  • Star 1 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save sancarn/d78c5332a9e15a9683ac1794a18d3021 to your computer and use it in GitHub Desktop.
Save sancarn/d78c5332a9e15a9683ac1794a18d3021 to your computer and use it in GitHub Desktop.
Download ZIP
Subclassing Excel
Raw
README.MD

Subclass excel

Original source:

https://www.mrexcel.com/forum/general-excel-discussion-other-questions/420673-challenging-problem-how-make-excel-subclassing-safe-stable.html

#' Todo:

Might want to make this class based with an event sink.

Public Event OnMessage(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) 

Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
  RaiseEvent OnMessage (hwnd,uMsg,wParam,lParam) 'Allows for spying of events
  WindowProc = CallWindowProc (lOldWinProc, hwnd, uMsg, wParam, lParam)
End Function
Raw
Subclass main window.cls
Option Explicit
Private Declare Function SetWindowLong Lib "user32.dll" _
Alias "SetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" _
Alias "CallWindowProcA" _
(ByVal lpPrevWndFunc As Long, _
ByVal hwnd As Long, _
ByVal MSG As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Declare Function FindWindow Lib "user32.dll" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function GetDesktopWindow Lib _
"user32.dll" () As Long
Private Declare Function ShowWindow Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal nCmdShow As Long) As Long
Private Declare Function SendMessage Lib "user32.dll" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByRef lParam As Any) 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 SetTimer Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long
Private Declare Function LockWindowUpdate Lib "user32.dll" _
(ByVal hwndLock As Long) As Long
Private Declare Function GetProp Lib "user32" _
Alias "GetPropA" _
(ByVal hwnd As Long, _
ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" _
Alias "SetPropA" _
(ByVal hwnd As Long, _
ByVal lpString As String, _
ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" _
Alias "RemovePropA" _
(ByVal hwnd As Long, _
ByVal lpString As String) As Long
Private Const GWL_WNDPROC As Long = -4
Private Const WM_USER As Long = &H400
Private Const WM_NCMOUSEMOVE As Long = &HA0
Private Const WM_SETREDRAW As Long = &HB
Private Const VBE_CLASS_NAME As String _
= "wndclass_desked_gsk"
Private Const EXCEL_CLASS_NAME As String _
= "XLMAIN"
Private lOldWinProc As Long
Private lVBEhwnd As Long
Sub Safe_Subclass(hwnd As Long)
'don't subclass the window twice !
If GetProp(GetDesktopWindow, "HWND") <> 0 Then
MsgBox "The Window is already Subclassed.", _
vbInformation
Exit Sub
End If
'store the target window hwnd as a desktop
'window for later use property.
SetProp GetDesktopWindow, "HWND", hwnd
'retrieve the VBE hwnd.
lVBEhwnd = FindWindow(VBE_CLASS_NAME, vbNullString)
'prevent flickering of the screen
'before posting messages to reset
'the VBE window.
LockWindowUpdate lVBEhwnd
'do the same with the desktop in the background.
SendMessage _
GetDesktopWindow, ByVal WM_SETREDRAW, ByVal 0&, 0&
'stop and reset the VBE first to safely
'proceed with our subclassing of xl.
PostMessage _
lVBEhwnd, ByVal WM_USER + &HC44, ByVal &H30, ByVal 0&
PostMessage _
lVBEhwnd, ByVal WM_USER + &HC44, ByVal &H33, ByVal 0&
PostMessage _
lVBEhwnd, ByVal WM_USER + &HC44, ByVal &H83, ByVal 0&
'run a one time timer and subclass xl
'from the timer callback function.
'if subclassing is not installed within
'the timer callback,xl will crash !
SetTimer GetProp(GetDesktopWindow, "HWND") _
, 0&, 1, AddressOf TimerProc
End Sub
Sub UnSubClassExcel(hwnd As Long)
'remove the subclass and cleanup.
SetWindowLong hwnd, GWL_WNDPROC, lOldWinProc
RemoveProp GetDesktopWindow, "HWND"
lOldWinProc = 0
End Sub
Private Function WindowProc _
(ByVal hwnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
'illustration example.
On Error Resume Next
Select Case uMsg
'increment cell A1 by 1
'when moving the mouse
'over the xl app title bar.
Case WM_NCMOUSEMOVE
Range("a1") = Range("a1") + 1
End Select
'allow other msgs default processing.
WindowProc = CallWindowProc _
(lOldWinProc, hwnd, uMsg, wParam, lParam)
End Function
Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long)
'we lost the hwnd stored in the lVBEhwnd var
'after reseting the VBE so let's retrieve it again.
lVBEhwnd = FindWindow(VBE_CLASS_NAME, vbNullString)
'we no longer need the timer.
KillTimer GetProp(GetDesktopWindow, "HWND"), 0&
'allow back drawing on the desktop.
SendMessage GetDesktopWindow, WM_SETREDRAW, ByVal 1, 0&
'hide the VBE.
ShowWindow lVBEhwnd, 0&
'unlock the window update.
LockWindowUpdate 0&
'and at last we can now safely
'subclass our target window.
lOldWinProc = SetWindowLong _
(GetProp(GetDesktopWindow, "HWND"), _
GWL_WNDPROC, AddressOf WindowProc)
End Sub
Raw
SubclassXL.bas
Option Explicit
Private Declare Function SetWindowLong Lib "user32.dll" _
Alias "SetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" _
Alias "CallWindowProcA" _
(ByVal lpPrevWndFunc As Long, _
ByVal hwnd As Long, _
ByVal MSG As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Declare Function FindWindow Lib "user32.dll" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function GetDesktopWindow Lib _
"user32.dll" () As Long
Private Declare Function ShowWindow Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal nCmdShow As Long) As Long
Private Declare Function SendMessage Lib "user32.dll" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByRef lParam As Any) 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 SetTimer Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long
Private Declare Function LockWindowUpdate Lib "user32.dll" _
(ByVal hwndLock As Long) As Long
Private Declare Function GetProp Lib "user32" _
Alias "GetPropA" _
(ByVal hwnd As Long, _
ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" _
Alias "SetPropA" _
(ByVal hwnd As Long, _
ByVal lpString As String, _
ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" _
Alias "RemovePropA" _
(ByVal hwnd As Long, _
ByVal lpString As String) As Long
Private Const GWL_WNDPROC As Long = -4
Private Const WM_USER As Long = &H400
Private Const WM_NCMOUSEMOVE As Long = &HA0
Private Const WM_SETREDRAW As Long = &HB
Private Const VBE_CLASS_NAME As String _
= "wndclass_desked_gsk"
Private Const EXCEL_CLASS_NAME As String _
= "XLMAIN"
Private lOldWinProc As Long
Private lVBEhwnd As Long
Sub Safe_Subclass(hwnd As Long)
'don't subclass the window twice !
If GetProp(GetDesktopWindow, "HWND") <> 0 Then
MsgBox "The Window is already Subclassed.", _
vbInformation
Exit Sub
End If
'store the target window hwnd as a desktop
'window for later use property.
SetProp GetDesktopWindow, "HWND", hwnd
'retrieve the VBE hwnd.
lVBEhwnd = FindWindow(VBE_CLASS_NAME, vbNullString)
'prevent flickering of the screen
'before posting messages to reset
'the VBE window.
LockWindowUpdate lVBEhwnd
'do the same with the desktop in the background.
SendMessage _
GetDesktopWindow, ByVal WM_SETREDRAW, ByVal 0&, 0&
'stop and reset the VBE first to safely
'proceed with our subclassing of xl.
PostMessage _
lVBEhwnd, ByVal WM_USER + &HC44, ByVal &H30, ByVal 0&
PostMessage _
lVBEhwnd, ByVal WM_USER + &HC44, ByVal &H33, ByVal 0&
PostMessage _
lVBEhwnd, ByVal WM_USER + &HC44, ByVal &H83, ByVal 0&
'run a one time timer and subclass xl
'from the timer callback function.
'if subclassing is not installed within
'the timer callback,xl will crash !
SetTimer GetProp(GetDesktopWindow, "HWND") _
, 0&, 1, AddressOf TimerProc
End Sub
Sub UnSubClassExcel(hwnd As Long)
'remove the subclass and cleanup.
SetWindowLong hwnd, GWL_WNDPROC, lOldWinProc
RemoveProp GetDesktopWindow, "HWND"
lOldWinProc = 0
End Sub
Private Function WindowProc _
(ByVal hwnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
'illustration example.
On Error Resume Next
Select Case uMsg
'increment cell A1 by 1
'when moving the mouse
'over the xl app title bar.
Case WM_NCMOUSEMOVE
Range("a1") = Range("a1") + 1
End Select
'allow other msgs default processing.
WindowProc = CallWindowProc _
(lOldWinProc, hwnd, uMsg, wParam, lParam)
End Function
Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long)
'we lost the hwnd stored in the lVBEhwnd var
'after reseting the VBE so let's retrieve it again.
lVBEhwnd = FindWindow(VBE_CLASS_NAME, vbNullString)
'we no longer need the timer.
KillTimer GetProp(GetDesktopWindow, "HWND"), 0&
'allow back drawing on the desktop.
SendMessage GetDesktopWindow, WM_SETREDRAW, ByVal 1, 0&
'hide the VBE.
ShowWindow lVBEhwnd, 0&
'unlock the window update.
LockWindowUpdate 0&
'and at last we can now safely
'subclass our target window.
lOldWinProc = SetWindowLong _
(GetProp(GetDesktopWindow, "HWND"), _
GWL_WNDPROC, AddressOf WindowProc)
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment