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.
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 found a previous thread that shows how to get all open windows and their names using C# : get the titles of all open windows
However, I need to do this in VBA: does anyone know if that's possible?
Thank you so much.
Best regards
Here's a scrape from this microsoft answer by Andreas Killer that uses EnumWindows() which did the trick for me:
Option Explicit
#If Win64 Then
Private Declare PtrSafe Function GetWindowTextLengthA Lib "user32" ( _
ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" ( _
ByVal hWnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" ( _
ByVal hWnd As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function EnumWindows Lib "user32" ( _
ByVal lpEnumFunc As LongPtr, ByVal lParam As LongPtr) As Long
#Else
Private Declare Function GetWindowTextLengthA Lib "user32" ( _
ByVal hWnd 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
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" ( _
ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function EnumWindows Lib "user32" ( _
ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
#End If
Private Sub debug_ListWindows()
ListWindows
End Sub
Private Function ListWindows()
EnumWindows AddressOf EnumFindWindowLikeProc, 0
End Function
#If Win64 Then
Private Function EnumFindWindowLikeProc(ByVal hWnd As LongPtr, ByVal lParam As Long) As Long
#Else
Private Function EnumFindWindowLikeProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
#End If
If IsWindowVisible(hWnd) Then
If Len(Trim(WindowTitle(hWnd))) > 0 Then
Debug.Print WindowTitle(hWnd)
End If
End If
EnumFindWindowLikeProc = 1
End Function
#If Win64 Then
Private Function IsWindowVisible(ByVal hWnd As LongPtr) As Boolean
#Else
Private Function IsWindowVisible(ByVal hWnd As Long) As Boolean
#End If
Const GWL_STYLE = -16 'Sets a new window style
Const WS_VISIBLE = &H10000000 'The window is initially visible
Dim lngStyle As Long
lngStyle = GetWindowLong(hWnd, GWL_STYLE)
IsWindowVisible = ((lngStyle And WS_VISIBLE) = WS_VISIBLE)
End Function
#If Win64 Then
Property Get WindowTitle(ByVal hWnd As LongPtr) As String
#Else
Property Get WindowTitle(ByVal hWnd As Long) As String
#End If
Dim Contents As String, i As Long
Contents = Space$(GetWindowTextLengthA(hWnd) + 1)
i = GetWindowText(hWnd, Contents, Len(Contents))
WindowTitle = Left$(Contents, i)
End Property
and here is a pretty truncated version that loops using GetWindow() which should work on sufficiently new office installations:
Option Explicit
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function GetWindowTextLengthA Lib "user32" ( _
ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" ( _
ByVal hWnd As LongPtr, ByVal lpString As String, _
ByVal cch As LongPtr) As Long
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" ( _
ByVal hWnd As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetWindow Lib "user32" ( _
ByVal hWnd As LongPtr, ByVal wCmd As Long) As LongPtr
Private Sub debug_ListWindows()
ListWindows
End Sub
Private Function ListWindows()
Const GWL_STYLE = -16 'Sets a new window style
Const WS_VISIBLE = &H10000000 'The window is initially visible
Const GW_HWNDNEXT = 2 'The retrieved handle identifies the window below the specified window in the Z order
Dim hWnd As LongPtr
hWnd = FindWindow(vbNullString, vbNullString)
While hWnd
Dim sTitle As String
sTitle = Space$(GetWindowTextLengthA(hWnd) + 1)
sTitle = Left$(sTitle, GetWindowText(hWnd, sTitle, Len(sTitle)))
If (GetWindowLong(hWnd, GWL_STYLE) And WS_VISIBLE) = WS_VISIBLE Then 'only list visible windows
If Len(Trim(sTitle)) > 0 Then 'ignore blank window titles
Debug.Print sTitle
End If
End If
hWnd = GetWindow(hWnd, GW_HWNDNEXT)
Wend
End Function
Sub ListWindows()
Dim wn As Excel.Window
For Each wn In Application.Windows
Debug.Print wn.Caption
Next wn
End Sub
if you wanted to activate any of them simply use:
wn.Activate
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.
I have a Photo Template that grabs photos from files and places them in their individual boxes in a word document. The file use to be a Word 2003 32-bit file that would only run in our old computer.
I have transformed the file to 64-bit to use in our new computers and saved it as a word-macro-enabled template.
This eliminated a bunch of problems I was having but the last bit is... at first it showed ambiguous name detected but after it shut down and restarted it started showing Compile Error: User-defined type not defined highlighting the first line of the code below and I can't find a solution after much research.
Please help, I really need this macro to work
Public Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" (ByRef lpbi As BROWSEINFO) As Long*
Public Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
'corrected
Public Declare PtrSafe Function SHGetSpecialFolderLocation Lib "shell32.dll" _
(ByVal hwndOwner As Long, ByVal nFolder As Long, ByRef pidl As Long) As Long
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadId As Long
End Type
Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" (ByVal _
hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare PtrSafe Function CreateProcessA Lib "kernel32" (ByVal _
lpApplicationName As Long, ByVal lpCommandLine As String, ByVal _
lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, _
lpStartupInfo As STARTUPINFO, lpProcessInformation As _
PROCESS_INFORMATION) As Long
Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal _
hObject As Long) As Long
Private Type FILETIME ' 8 Bytes
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Seems like you're missing a Type enumeration for the BROWSEINFO, see here for example:
http://www.jkp-ads.com/Articles/apideclarations.asp
#If VBA7 Then
Private Type BROWSEINFO
hOwner As LongPtr
pidlRoot As LongPtr
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As LongPtr
lParam As LongPtr
iImage As Long
End Type
Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As LongPtr
#Else
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As Long
#End If
Private Const BIF_RETURNONLYFSDIRS = &H1
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