|
-
Nov 8th, 2016, 12:19 PM
#1
[vba] Ways for improvement of MS Office window subclassing
Hi,
I know this is a bad idea to subclass Word / Excel windows (because many reasons, at least these), but anyway I want to have such one (e.g. for RegisterHotkey to have an opportunity to redefine some internal hotkeys to obtain a more convenient tools for editing text).
Enough words. I rewrote a little bit a code based on Jaafar Tribak source.
My edits related to simplify code. Also I added safe UnSubclass with help of 'The Trick'. But I don't very familiar with subclassing in general.
For people, who worked with subclassing (like fafalone project) and still intrested,
what do you think, how can we improve this code to be more safely?
For now, it's for MS Excel only:
Thisworkbook
Code:
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'unsubclass the window.
'flag = False
Call UnSubClassExcel(Application.hWnd)
End Sub
Private Sub Workbook_Open()
'let's subclass the main
'excel application window.
Call Safe_Subclass(Application.hWnd)
End Sub
Module1.bas
Code:
'Forked by Alex Dragokas
'Thanks for safe UnSubclassing example goes to 'The Trick'.
'Copyrights:
'MS Excel Subclassing by Jaafar Tribak - http://www.mrexcel.com/forum/general-excel-discussion-other-questions/420673-challenging-problem-how-make-excel-subclassing-safe-stable.html#post2082195
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.dll" 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 ShowWindow Lib "user32.dll" (ByVal hWnd As Long, ByVal nCmdShow 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 RegisterHotKey Lib "user32.dll" (ByVal hWnd As Long, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
Private Declare Function UnregisterHotKey Lib "user32.dll" (ByVal hWnd As Long, ByVal id As Long) As Long
Private Const GWL_WNDPROC As Long = -4&
Private Const WM_USER As Long = &H400&
'Classes
Private Const VBE_CLASS_NAME As String = "wndclass_desked_gsk"
'UnSubclassing
Private Const WM_SYSCOMMAND As Long = &H112&
Private Const SC_CLOSE As Long = &HF060&
Dim lOldWinProc As Long
Dim lVBEhwnd As Long
Sub Safe_Subclass(hWnd As Long)
Static IsSubclassed As Boolean
'don't subclass the window twice !
If IsSubclassed Then
Exit Sub
Else
IsSubclassed = True
End If
'retrieve the VBE hwnd.
lVBEhwnd = FindWindow(VBE_CLASS_NAME, vbNullString)
'stop and reset the VBE first to safely proceed with our subclassing
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 owr app
'from the timer callback function.
'if subclassing is not installed within
'the timer callback, app. will crash !
Application.OnTime Now + TimeValue("00:00:01"), "TimerProc"
End Sub
Sub UnSubClassExcel(hWnd As Long)
'remove the subclass and cleanup.
SetWindowLong hWnd, GWL_WNDPROC, lOldWinProc
lOldWinProc = 0
Release
End Sub
Public Sub TimerProc()
'hide the VBE.
ShowWindow lVBEhwnd, 0&
'and at last we can now safely subclass our target window.
lOldWinProc = SetWindowLong(Application.hWnd, GWL_WNDPROC, AddressOf WindowProc)
RegHotKey
End Sub
Private Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Const WM_HOTKEY As Long = &H312&
Select Case uMsg
Case WM_SYSCOMMAND
If wParam = SC_CLOSE Then
Release
WindowProc = 0
Call UnSubClassExcel(Application.hWnd)
PostMessage hWnd, WM_SYSCOMMAND, SC_CLOSE, lParam
End If
Case WM_HOTKEY
If wParam = 1 Then
Debug.Print "Key is pressed: " & wParam
End If
End Select
WindowProc = CallWindowProc(lOldWinProc, hWnd, uMsg, wParam, lParam)
End Function
Sub RegHotKey()
Const MOD_CONTROL As Long = 2&
Const MOD_SHIFT As Long = 4&
Const MOD_ALT As Long = 1&
Const VK_RETURN As Long = &HD&
Const VK_NUMPAD0 As Long = &H60&
Dim lret&
lret = RegisterHotKey(Application.hWnd, 1, MOD_SHIFT, VK_RETURN)
Debug.Print "RegisterHotKey = " & lret
End Sub
Sub Release()
UnregisterHotKey Application.hWnd, 1
End Sub
To use, click Ctrl + Shift + Enter, and you'll get a msg in immediate window.
Thanks in advance,
Alex.
Tags for this Thread
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|