This function is getting me crazy! I am trying to use SetWindwosHookEx to avoid some keystrokes from the user, but I can't make it work properly.
I have been looking around many code on the web but I don't understand why it is not working for me. Firstly, it was because I was using Excel 2010 (64 bit) and my code wasn't for it, but now I don't know.
Basically, I have created a simple code which shows me a message when I pull "g" but what it is happening is Excel crashes when a pull any key. It doesn't crash when I run the code step by step but if I pull "g" the message appears three times!
This is my code:
#If Win64 Then
Public Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As LongPtr
Public Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As LongPtr, ByVal lpFn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As LongPtr) As LongPrt
Public Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As LongPtr, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Public Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
Public Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As LongPtr
Public Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As LongPtr) As Integer
Private hWndPPT As LongPtr
Private HookHandle As LongPtr
'ADICIONAL
Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" (ByVal hDlg As LongPrt, ByVal nIDDlgItem As LongPtr, ByVal wMsg As LongPtr, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As LongPtr) As LongPtr
#Else
Public Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Public 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
Public Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Public Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Public Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private hWndPPT As Long
Private HookHandle As Long
'ADICIONAL
Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam 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
#End If
'Constants to be used in our API functions
'Private Const EM_SETPASSWORDCHAR = &HCC
'Private Const WH_CBT = 5
Private Const WH_KEYBOARD = 2
'Private Const HCBT_ACTIVATE = 5
Private Const HC_ACTION = 0
'Private hHook As Long
Public Sub RemoveHook()
UnhookWindowsHookEx (HookHandle)
End Sub
Sub SetHook()
#If Win64 Then
Dim lThreadID As LongPtr
Dim lngModHwnd As LongPtr
#Else
Dim lThreadID As Long
Dim lngModHwnd As Long
#End If
lThreadID = GetCurrentThreadId
lngModHwnd = GetModuleHandle(vbNullString)
'Set a local hook
HookHandle = SetWindowsHookEx(WH_KEYBOARD, AddressOf NewProc, 0, lThreadID)
End Sub
Public Function NewProc(ByVal lngCode As LongPtr, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
If lngCode < HC_ACTION Then
NewProc = CallNextHookEx(HookHandle, lngCode, wParam, lParam)
Exit Function
End If
If wParam = 71 Then
'MsgBox "g"
'NewProc = 1
wParam = 70
'Exit Function
End If
'This line will ensure that any other hooks that may be in place are
'called correctly.
CallNextHookEx HookHandle, lngCode, wParam, lParam
End Function
The correct declarations for 64bit would be:
Public Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
Public Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpFn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Public Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Public Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
Public Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
Public Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Declare PtrSafe Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
I can't actually see how the code you posted would run at all on 64bit.
Related
I recently changed Windows.
When I run my VBA code I get the following message:
'Place this code in a Module
Private Declare Function FindWindowA Lib "USER32" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLongA Lib "USER32" _
(ByVal hWnd As Long, _
ByVal nIndex As Long) As Long
Private Declare Function SetWindowLongA Lib "USER32" _
(ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
You should add a precompile If statement to work with Win 32 and 64.
The code below will make this work in Windows 32 and 64 bit systems.
Option Explicit
#If Win64 Then
Private Declare PtrSafe Function FindWindowA Lib "USER32" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function GetWindowLongA Lib "USER32" _
(ByVal hWnd As Long, _
ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetWindowLongA Lib "USER32" _
(ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
#Else
Private Declare Function FindWindowA Lib "USER32" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLongA Lib "USER32" _
(ByVal hWnd As Long, _
ByVal nIndex As Long) As Long
Private Declare Function SetWindowLongA Lib "USER32" _
(ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
#End If
I have declared SetTimer in my VB code (under Windows 10 64-bit and Excel 64-bit) as follows:
#If Win64 Then ' 64-bit Windows
' ---------------
#If VBA7 Then ' 64-bit Excel:
' -------------
Public Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, _
ByVal nIDEvent As LongPtr, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As LongPtr) As LongPtr
Public settimer_result As LongPtr ' Result value of SetTimer.
Public Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, _
ByVal nIDEvent As LongPtr) As Long
Public killtimer_result As Long ' Result value of KillTimer.
...
Public Const timer_interval As Long = 1000
...
It works fine, when I run the program, but as soon as I set a break point to debug, Excel crashes at this statement:
settimer_result = SetTimer(0&, 0&, timer_interval, AddressOf TimerProc)
I have also tried with LongLong instead of LongPtr, but it still crashes.
Would really appreciate any help on this.
You seem to misunderstand the meaning of the conditional compilation constants.
Win64 is not "64-bit Windows", it tells you the bitness of the Office.
VBA7 is not "64-bit Office", it tells you whether the Office is new enough to support the LongPtr type and the PtrSafe keyword, regardless of the bitness.
Thus, the correct declaration would be
#If VBA7 Then
Public Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, _
ByVal nIDEvent As LongPtr, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As LongPtr) As LongPtr
Public Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, _
ByVal nIDEvent As LongPtr) As Long
Public settimer_result As LongPtr ' Result value of SetTimer.
#Else
Public Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long
Public settimer_result As Long ' Result value of SetTimer.
#End If
Public killtimer_result As Long ' Result value of KillTimer.
Note that you do not need to use #If Win64.
If your TimerProc sub has correct arguments (LongPtr, Long, LongPtr, Long), then it might very well be that the IDE is unable to keep receiving the timer callbacks while a break point is set, so it crashes.
this is a shortcut API that allows you to access directly to the name box in Excel. Since I've changed to a 64-bit version I cannot make it to work. The error displayed is Type mismatch.
Private Declare PtrSafe Function FindWindow Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function FindWindowEx Lib "USER32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
Public Declare PtrSafe Function SendMessageA Lib "USER32" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Sub NameBox_Shortcut()
Dim hWnd As LongLong
Const NUL = vbNullString
Const EXCEL_WINDOW = "XLMAIN"
Const FORMULABAR_LEFT_HALF = "EXCEL;"
Const NAMEBOX = "COMBOBOX"
Const WM_LBUTTONDOWN = &H201
Const WM_LBUTTONUP = &H202
hWnd = FindWindowEx(FindWindowEx(FindWindow(EXCEL_WINDOW, NUL), 0, FORMULABAR_LEFT_HALF, NUL), 0, NAMEBOX, NUL)
SendMessageA hwnd, WM_LBUTTONDOWN, 0&, 0&
SendMessageA hwnd, WM_LBUTTONUP, 0&, 0&
End Sub
Edit: Updated the code.
declare your variable as longptr will solve your problem :
Dim hWnd As LongPtr
I am working on converting some very old VBA code to run on AutoCAD 2014. I have so far converted everything but there is an issue with the forms (they are modeless and require an activation callback to modify the window propertis). The following is the VBA6 source code:
IN THE FORM:
Private Sub UserForm_Activate()
#If ACAD2000 = 0 Then
If Not bPopup Then
Call EnumWindows(AddressOf EnumWindowsProc, vbNull)
Call SubClass
bPopup = True
End If
#End If
End Sub
MODULE (named modModeLessFormFocus):
Option Explicit
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private ThisHwnd As Long
Public Const GWL_STYLE = -16
Public Const WS_POPUP = &H80000000
Function EnumWindowsProc(ByVal hwnd As Long, ByVal lParam As Long) As Integer
Dim title As String * 32
Call GetWindowText(hwnd, ByVal title, 32)
If InStr(title, "About") Then
ThisHwnd = hwnd
EnumWindowsProc = False
ElseIf InStr(title, "Preferences") Then
ThisHwnd = hwnd
EnumWindowsProc = False
ElseIf InStr(title, "Display Block Attributes") Then
ThisHwnd = hwnd
EnumWindowsProc = False
Else
EnumWindowsProc = True
End If
End Function
Public Function SubClass() As Long
Dim Flags As Long
Flags = GetWindowLong(ThisHwnd, GWL_STYLE)
Flags = Flags Xor WS_POPUP
SetWindowLong ThisHwnd, GWL_STYLE, Flags
End Function
The error I get when running is a "Type Mismatch" in UserForm_Activate on 'AddressOf EnumWindowsProc.' I have tried to convert it to 64bit using PtrSafe and PtrLong but inevitably it fails and the program crashes.
If anyone is smart enough to convert this or point me in the right direction I would be very appreciative.
Thanks
I found the API for 64-bit VBA7 in http://www.jkp-ads.com/articles/apideclarations.asp
#If VBA7 Then
#If Win64 Then
Private Declare PtrSafe Function GetWindowLongPtr Lib "USER32" Alias "GetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
#Else
Private Declare PtrSafe Function GetWindowLongPtr Lib "USER32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
#End If
Private Declare PtrSafe Function GetWindowText Lib "USER32" Alias "GetWindowTextA" _
(ByVal hWnd As LongPtr, ByVal lpString As String, _
ByVal cch As LongPtr) As Long
#Else
Private Declare Function GetWindowLongPtr Lib "USER32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function GetWindowText Lib "USER32" Alias "GetWindowTextA" _
(ByVal hWnd As Long, ByVal lpString As String, _
ByVal cch As Long) As Long
#End If
You can also look at http://msdn.microsoft.com/en-us/library/aa383663(VS.85).aspx for the updated API
I am new to vb.net (framework 4) and visual studio is giving me warnings on the following declarations.
Private Declare Auto Function EnumChildWindows Lib "user32" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Auto Function FindWindow Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As IntPtr
Private Declare Auto Function GetWindowText Lib "user32" (ByVal hwnd As IntPtr, ByVal lpString As String, ByVal cch As IntPtr) As IntPtr
Private Declare Auto Function keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Integer, ByVal dwExtraInfo As Integer) As Boolean
Private Declare Auto Function SendMessage Lib "user32" (ByVal hWnd As IntPtr, ByVal Msg As UInteger, ByVal wParam As IntPtr, ByVal lParam As IntPtr) As IntPtr
Private Declare Auto Function SetForegroundWindow Lib "user32" (ByVal hWnd As IntPtr) As Boolean
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Integer)
and more importantly how do I find out the correct declaration in future?
It looks like you are converting a vb6 app. All these functions have .net Equivalents, use them.
I cannot imagine you getting a warning from these declarations. But yes, EnumChildWindows is wrong and impossible to use in a VB.NET program. Fix:
Private Delegate Function EnumChildCallback(ByVal hWnd As IntPtr, ByVal lparam As IntPtr) As Boolean
Private Declare Auto Function EnumChildWindows Lib "user32" (ByVal hWndParent As IntPtr, ByVal lpEnumFunc As EnumChildCallback, ByVal lParam As IntPtr) As Boolean
The cch argument of GetWindowText is wrong, it is Integer. The rest are good.
Pinvoke.net is a reasonable decent resource for these declarations. Or you could use the P/Invoke Interop Assistant tool. Neither of them are perfect, only SO is.