I'm trying to use Waitable Timer objects in VBA, as I want to call something asynchronously with a delay of under 1 second (so no Application.OnTime) and with arguments (so no SetTimer API)
I haven't found someone attempting this anywhere else so I'm having to do it all from scratch, but I think it should be feasible. Here are the API declarations:
Public Declare Function CreateWaitableTimer Lib "kernel32" Alias "CreateWaitableTimerA" ( _
ByVal lpTimerAttributes As Long, _
ByVal manualReset As Boolean, _
ByVal lpTimerName As Long) As Long
'The A meaning Ansi not Unicode https://jeffpar.github.io/kbarchive/kb/145/Q145727/
Public Declare Function SetWaitableTimer Lib "kernel32" ( _
timerHandle As Long, _
lpDueTime As fileTime, _
lPeriod As Long, _
pfnCompletionRoutine As Long, _
lpArgToCompletionRoutine As Long, _
fResume As Boolean) As Boolean
Which references a fileTime (struct)
'see https://social.msdn.microsoft.com/Forums/sqlserver/en-US/a28a32c6-df4e-41b9-94ce-6260812dd92f/problem-trying-to-run-32-bit-vba-program-on-a-64-bit-machine?forum=exceldev
Public Type fileTime
dwLowDateTime As Long
dwHighDateTime As Long
End Type
I am calling the API like this:
'[...]
args = 1234 'public args As Long so it doesn't go out of scope while the timer is waiting
Dim timerHandle As Long
timerHandle = CreateWaitableTimer(0, False, 0)
Debug.Print GetSystemErrorMessageText(Err.LastDllError)
If Not SetWaitableTimer(timerHandle, absoluteDueTime, 0, AddressOf TimerCallbacks.pointerProc, VarPtr(args), False) Then
Debug.Print "Error: "; GetSystemErrorMessageText(Err.LastDllError)
End If
GetSystemErrorMessageText comes from Chip Pearson. absoluteDueTime is a fileTime variable which is set to Now + 1 second earlier in the procedure.
I'm getting in the immediate window:
0 - The operation completed successfully.
Error: 6 - The handle is invalid.
Meaning that CreateWaitableTimer appears to work but SetWaitableTimer does not.
FWIW TimerCallbacks.pointerProc looks like:
Public Sub pointerProc(ByVal argPtr As Long, ByVal timerLowValue As Long, ByVal timerHighValue As Long)
Debug.Print "pointerProc called"; Time
End Sub
(but I don't think that's where the error is...)
Oh, the problem is with the implicit byRef of everything:
Public Declare Function SetWaitableTimer Lib "kernel32" ( _
timerHandle As Long, _
lpDueTime As fileTime, _
lPeriod As Long, _
pfnCompletionRoutine As Long, _
lpArgToCompletionRoutine As Long, _
fResume As Boolean) As Boolean
Pointers must be passed byVal or they are immediately deferenced? Is this correct:
Public Declare Function SetWaitableTimer Lib "kernel32" ( _
byVal timerHandle As Long, _
byRef lpDueTime As fileTime, _
byRef lPeriod As Long, _
byVal pfnCompletionRoutine As Long, _
byVal lpArgToCompletionRoutine As Long, _
byRef fResume As Boolean) As Boolean
Not sure if all the byRefs are necessary
Related
I have an Excel VBA project I'm in the process of adapting for 64-bit Office. In one part, I make calls to MultiByteToWideChar() using any of 20 or so different code pages. (So StrConv is not an alternative.)
This has been working for me for years in 32-bit Office using the following declare:
Declare Function MultiByteToWideChar Lib "kernel32" ( _
ByVal codepage As Long, _
ByVal dwFlags As Long, _
lpMultiByteStr As Any, _
ByVal cbMultiByte As Long, _
ByVal lpWideCharStr As Long, _
ByVal cchWideChar As Long _
) As Long
'params: UINT, DWORD, LPCSTR, int, LPWSTR, int
'return: int
But my adaptation to 64-bit is not: I get wrong results (e.g. an empty string where a non-empty string is expected), and frequent crashes. I'm using a declare that I got from the Microsoft-provided Win32API_PtrSafe.TXT file. (Of course, it could have bugs.)
So, I'm guessing something is not right in the declare statement or in how I'm making the call.
Here's a minimal sample that repro's:
'Windows API declarations
Public Const MB_PRECOMPOSED = &H1 'use precomposed chars
Declare PtrSafe Function MultiByteToWideChar Lib "kernel32" ( _
ByVal CodePage As Long, _
ByVal dwFlags As Long, _
ByVal lpMultiByteStr As String, _
ByVal cchMultiByte As Long, _
ByVal lpWideCharStr As String, _
ByVal cchWideChar As Long _
) As Long
'params: UINT, DWORD, LPCSTR, int, LPWSTR, int
'return: int
' My function that calls MultiByteToWideChar
Private Function EncodedStringByteArrayToString(abStringData() As Byte, lngArrLen As Long, CodePage As Long) As String
Dim lngStrLen As Long, str As String
lngStrLen = MultiByteToWideChar(CodePage, MB_PRECOMPOSED, ByVal VarPtr(abStringData(1)), lngArrLen, 0&, 0)
str = String(lngStrLen, " ")
lngStrLen = MultiByteToWideChar(CodePage, MB_PRECOMPOSED, ByVal VarPtr(abStringData(1)), lngArrLen, StrPtr(str), lngStrLen)
EncodedStringByteArrayToString = str
End Function
' Sample routine to produce repro
Private Sub TestMB2WCBug()
Dim abStringData(1 To 9) As Byte
Dim resultString As String
abStringData(1) = 67
abStringData(2) = 111
abStringData(3) = 112
abStringData(4) = 121
abStringData(5) = 114
abStringData(6) = 105
abStringData(7) = 103
abStringData(8) = 104
abStringData(9) = 116
resultString = EncodedStringByteArrayToString(abStringData(), 9, 10000)
End Sub
This has been working for me for years in 32-bit Office
It could not possibly work with the Declare that you have shown.
MultiByteToWideChar expects an LPWSTR as the output buffer. VB performs automatic conversion from Unicode to ANSI when passing strings into Declared functions, so there is no way that the function would receive a pointer to a wide string buffer when lpWideCharStr is declared As String. At best, it would receive a buffer that is large enough so no buffer overflow would occur, and then VB would perform conversion back to Unicode when returning from the function, so you will end up with a double-unicode string.
lpMultiByteStr is not a string either, it's an array of bytes in some encoding.
The code inside EncodedStringByteArrayToString seems to know all that, because it correctly passes a byte array for lpMultiByteStr and an StrPtr for lpWideCharStr. This could have not happened with the current declaration of MultiByteToWideChar.
The declaration that is assumed by the code in EncodedStringByteArrayToString is:
Declare PtrSafe Function MultiByteToWideChar Lib "kernel32" ( _
ByVal CodePage As Long, _
ByVal dwFlags As Long, _
ByVal lpMultiByteStr As LongPtr, _
ByVal cchMultiByte As Long, _
ByVal lpWideCharStr As LongPtr, _
ByVal cchWideChar As Long _
) As Long
Apparently you had that before, so just put it back.
I'm having some problems with converting this API call into 64 bit accessible call from VBA.
API declaration
Private Declare PtrSafe Function DispCallFunc Lib "OleAut32.dll" ( _
ByVal pvInstance As Long, _
ByVal oVft As Long, _
ByVal cc As Long, _
ByVal vtReturn As Integer, _
ByVal cActuals As Long, _
ByVal prgvt As Long, _
ByVal prgpvarg As Long, _
ByVal pvargResult As Long _
) As Long
Client code
Public Sub Main()
' On this line I get "compile error: type mismatch" because AddressOf method
' returns LongPtr but DispCallFunc expects Long.
DispCallFunc 0, AddressOf Foo, CLng(4), VbVarType.vbEmpty, 0, 0, 0, 0
End Sub
Private Sub Foo()
Debug.Print 100
End Sub
I tried to change Long to LongPtr in DispCallFunc but every time I make that change to the API and run macro, Excel freezes.
The DispCallFunc function is declared like this:
HRESULT DispCallFunc(
void *pvInstance,
ULONG_PTR oVft,
CALLCONV cc,
VARTYPE vtReturn,
UINT cActuals,
VARTYPE *prgvt,
VARIANTARG **prgpvarg,
VARIANT *pvargResult
);
pvInstance is a pointer [input]
oVft is a pointer [input]
cc is a 32-bit integer [input]
vtReturn is a 16-bit integer [input]
cActuals is a 32-bit integer [input]
prgvt is an array of 16-bit integers (so a pointer) [input]
prgpvarg is an array of pointer on VARIANTs (so a pointer) [input]
pvargResult is a pointer on a VARIANT, so a byref VBA's Variant [output]
So, for VBA:
Private Declare PtrSafe Function DispCallFunc Lib "OleAut32.dll" ( _
ByVal pvInstance As LongPtr, _
ByVal oVft As LongPtr, _
ByVal cc As Long, _
ByVal vtReturn As Integer, _
ByVal cActuals As Long, _
ByVal prgvt As LongPtr, _
ByVal prgpvarg As LongPtr, _
ByRef pvargResult As Variant) As Long
What I'm trying to do:
I'm trying to copy text to the clipboard then paste into excel while keeping all the formatting.
The only way I have found to stop excel from spreading the text across many cells and keep formatting like bullet points etc is after copying to the clipboard, to paste it directly into the formula bar.
How I'm attempting it:
I'm using Win API to get the handle of the formula bar.
Then sending a WM_PASTE message to the window to paste what's on the clipboard.
Then sending a WM_SETFOCUS message to the window ready to receive the return key.
Then sending a WM_KEYDOWN message for the return key.
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 hwndParent As Long, _
ByVal hwndChildAfter As Long, _
ByVal lpszClass As String, _
ByVal lpszWindow As String) As Long
Private Declare Function SendMessage _
Lib "user32.dll" _
Alias "SendMessageA" _
(ByVal hWnd As Long, _
ByVal Msg As Long, _
ByVal wParam As Long, _
ByRef lParam As Any) _
As Long
Declare Function PostMessage _
Lib "user32" _
Alias "PostMessageA" ( _
ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Declare Function SetForegroundWindow _
Lib "user32" _
(ByVal hWnd As Long) As Long
Private Const WM_CUT As Long = &H300
Private Const WM_COPY As Long = &H301
Private Const WM_PASTE As Long = &H302
Private Const WM_CLEAR As Long = &H303
Private Const WM_UNDO As Long = &H304
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const VK_F5 As Long = &H74
Private Const VK_RETURN As Long = &HD
Private Const WM_CHAR As Long = &H102
Private Const WM_SETFOCUS As Long = &H7
Private Const WM_KILLFOCUS As Long = &H8
Private Const WM_IME_SETCONTEXT As Long = &H281
Public Sub pasteClipboard()
hwndMain = Application.hWnd: Debug.Print hwndMain
hwndFormulaBar = FindWindowEx(Application.hWnd, ByVal 0&, "EXCEL<", vbNullString): Debug.Print hwndFormulaBar
hwndDesk = FindWindowEx(Application.hWnd, ByVal 0&, "XLDESK", vbNullString): Debug.Print hwndDesk
hwndSheet = FindWindowEx(hwndDesk, ByVal 0&, "EXCEL7", vbNullString): Debug.Print hwndSheet
RetVal = SendMessage(hwndFormulaBar, WM_PASTE, 0, ByVal 0)
Debug.Print SendMessage(hwndFormulaBar, WM_SETFOCUS, 0, 0)
Debug.Print SendMessage(hwndFormulaBar, WM_IME_SETCONTEXT, &H0, &H0)
Debug.Print SendMessage(hwndFormulaBar, WM_KEYDOWN, VK_RETURN, &H0)
End Sub
The Problem:
This all works up until when I send the return key to finish editing the cell which is what I'd like to happen. Instead it puts a carriage return in the text box which makes a lot of sense but not the result I wanted.
I've looked at the formula window with Spy++ and watched what happens when I type something in the window and hit return - when the return key is hit it finishes editing the cell.
The only two commands I'm not using that show up in Spy++ are WM_IME_SETCONTEXT and WM_IME_NOTIFY but in all honesty I'm not sure what these two commands do.
I tried using the WM_IME_SETCONTEXT above thinking I may have to change it before sending the return key but the results didn't change.
Any solutions?
If anyone can point me in the right direction of how to send a message that will finish editing the cell (doesn't have to be the return key, that was just my first thought) that would be great.
Many Thanks
Thank you for all the comments.
#Rita Han - MSFT The application.SendKeys worked as long as the focus was not the VBE window which is great!
In Windows 7, the following Excel VBA 7.1 snippet successfully launches the On-Screen Keyboard (OSK.EXE) but the value of the dwProcessID member retrieved from the 'proc' (process information) parameter (passed ByRef) does not match that, or any other PID, displayed by task manager.
Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long ' Integer doesn't work either
dwThreadID As Long
End Type
Declare 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, _
ByRef lpStartupInfo As STARTUPINFO, ByRef lpProcessInformation As _
PROCESS_INFORMATION) As Long
Dim proc As PROCESS_INFORMATION
Dim start As STARTUPINFO
start.cb = Len(start)
If CreateProcessA(0, "OSK.EXE", 0, 0, 1, NORMAL_PRIORITY_CLASS, 0, 0, start,
proc) <> 0 Then
WaitForInputIdle proc.hProcess, INFINITE
MsgBox CStr(proc.dwProcessID), vbInformation, "Process ID" ' Wrong for
OSK, but correct for Notepad and Calc
CloseHandle (proc.hProcess)
CloseHandle (proc.hThread)
End If
For OSK, it seems that the proc.hProcess value is incorrect. I checked the process ID value of proc.dwProcessID against the PID listed for OSK in Task Manager, and they don't match. Indeed, proc.dwProcessID isn't listed for any process (even in Process Explorer), so it seems that the PROCESS_INFORMATION Type is not receiving correct outputs.
Everything works fine for NOTEPAD and CALC though. Equivilent code compiled in VB.NET behaves properly with OSK, so what's different about VBA that causes CreateProcessA to work incorrectly with OSK?
Thanks in advance,
John.
It could be that the executable you are launching (OSK.EXE) execute another process or does some job and exit very quickly so when you look in process explorer you cannot find anything.
If the code inside the "if" is not executed I would try to get the error with GetLastError call.
I think you are encountering issues like https://learn.microsoft.com/en-us/office/vba/language/concepts/getting-started/64-bit-visual-basic-for-applications-overview.
Long is not a good replacement for pointers, in this case should be
Type PROCESS_INFORMATION
hProcess As LongPtr
hThread As LongPtr
dwProcessID As Long
dwThreadID As Long
End Type
Declare Function CreateProcessA Lib "kernel32" (ByVal _
lpApplicationName As LongPtr, ByVal lpCommandLine As String, ByVal _
lpProcessAttributes As LongPtr, ByVal lpThreadAttributes As LongPtr, _
ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
ByVal lpEnvironment As LongPtr, ByVal lpCurrentDirectory As LongPtr, _
ByRef lpStartupInfo As STARTUPINFO, ByRef lpProcessInformation As _
PROCESS_INFORMATION) As Long
See also https://www.jkp-ads.com/articles/apideclarations.asp
I am currently making some VBA code applicable for the new win7 machines on the job. This means that many function has to be added with the new 64-bit compatibility. I am currently following the guidelines from this homepage. I find them very useful and implemented following:
#If VBA7 Then
Declare PtrSafe Function CreateProcess Lib "kernel32" 'More code, see below.
#Else
Declare Function CreateProcess Lib "kernel32" 'More code, see below.
#EndIf
however, currently VBA is giving me following error message when I save my code:
NOTE: The code above contains the code described in the previous mentioned link: from jkp-ads. The error appears in the Declare PtrSafe Function CreateProcess Lib "kernel32" Alias "CreateProcessA". The full code can be found here.
What am I missing here?
Thanks!
Update
My full code:
Option Explicit
Const INFINITE = &HFFFF
Const STARTF_USESHOWWINDOW = &H1
Private Enum enSW
SW_HIDE = 0
SW_NORMAL = 1
SW_MAXIMIZE = 3
SW_MINIMIZE = 6
End Enum
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessId As Long
dwThreadId As Long
End Type
Private Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Byte
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Enum enPriority_Class
NORMAL_PRIORITY_CLASS = &H20
IDLE_PRIORITY_CLASS = &H40
HIGH_PRIORITY_CLASS = &H80
End Enum
#If VBA7 Then
private Declare PtrSafe Function CreateProcess Lib "kernel32" _
Alias "CreateProcessA" (ByVal lpApplicationName As String, _
ByVal lpCommandLine As String, _
lpProcessAttributes As SECURITY_ATTRIBUTES, _
lpThreadAttributes As SECURITY_ATTRIBUTES, _
ByVal bInheritHandles As Long, _
ByVal dwCreationFlags As Long, _
lpEnvironment As Any, _
ByVal lpCurrentDriectory As String, _
lpStartupInfo As STARTUPINFO, _
lpProcessInformation As PROCESS_INFORMATION) As LongPtr
#Else
Declare Function CreateProcess Lib "kernel32" _
Alias "CreateProcessA" (ByVal lpApplicationName As String, _
ByVal lpCommandLine As String, _
lpProcessAttributes As SECURITY_ATTRIBUTES, _
lpThreadAttributes As SECURITY_ATTRIBUTES, _
ByVal bInheritHandles As Long, _
ByVal dwCreationFlags As Long, _
lpEnvironment As Any, _
ByVal lpCurrentDriectory As String, _
lpStartupInfo As STARTUPINFO, _
lpProcessInformation As PROCESS_INFORMATION) As Long
#End If
Now, I want to emphasize a few things. First, I am running Excel 2003 and Windows XP 32bit. In addition to this I have not attempted to run the code yet. Why you may ask. The reason is simple. The editor comes up with a compile error before I am able to do anything. This Compile error can be seen in the picture above this piece of code. I have taken a screenshot of some of the code and especially where the compile error occurs. This is how it looks:
UpdateUpdate: Just found this article from MS support. It appears that the resolution is following: "To resolve this issue, ignore the "Compile error" and run the VBA code in the 64-bit version of the Office 2010 program." I still hope some solution exist though.
Further to my comment below your question (which you have ignored... by mistake I guess?) I believe you are getting that error because you have not specified all the parameters correctly.
Try this and it will compile just fine.
Const INFINITE = &HFFFF
Const STARTF_USESHOWWINDOW = &H1
Private Enum enSW
SW_HIDE = 0
SW_NORMAL = 1
SW_MAXIMIZE = 3
SW_MINIMIZE = 6
End Enum
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessId As Long
dwThreadId As Long
End Type
Private Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Byte
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Enum enPriority_Class
NORMAL_PRIORITY_CLASS = &H20
IDLE_PRIORITY_CLASS = &H40
HIGH_PRIORITY_CLASS = &H80
End Enum
#If VBA7 Then
Declare PtrSafe Function CreateProcess Lib "kernel32" _
Alias "CreateProcessA" (ByVal lpApplicationName As String, _
ByVal lpCommandLine As String, _
lpProcessAttributes As SECURITY_ATTRIBUTES, _
lpThreadAttributes As SECURITY_ATTRIBUTES, _
ByVal bInheritHandles As Long, _
ByVal dwCreationFlags As Long, _
lpEnvironment As Any, _
ByVal lpCurrentDriectory As String, _
lpStartupInfo As STARTUPINFO, _
lpProcessInformation As PROCESS_INFORMATION) As LongPtr
#Else
Declare Function CreateProcess Lib "kernel32" _
Alias "CreateProcessA" (ByVal lpApplicationName As String, _
ByVal lpCommandLine As String, _
lpProcessAttributes As SECURITY_ATTRIBUTES, _
lpThreadAttributes As SECURITY_ATTRIBUTES, _
ByVal bInheritHandles As Long, _
ByVal dwCreationFlags As Long, _
lpEnvironment As Any, _
ByVal lpCurrentDriectory As String, _
lpStartupInfo As STARTUPINFO, _
lpProcessInformation As PROCESS_INFORMATION) As Long
#End If
This is not a solution, but a path of investigation.
It looks like the compiler is looking at the stuff under #If VBA7 Then. But this shouldn't be happening at all in Excel 2003.
Try replacing whatever is under #If VBA7 Then with garbage, and add one declaration in the #Else part, e.g.
#If VBA7 Then
ksjdhfg lkjsdh fgkjh,dlgf sldjkgflsd g 'obvious syntax error
#Else
Const vOlder As String = "older VBA"
Declare Function CreateProcess Lib "kernel32" '... keep this part as it was
#End If
Then try to run this to see if it compiles:
Sub tester()
Debug.Print vOlder
End Sub
This should compile and run fine in Excel 2003 since it has an older version of VBA than 7.0. The stuff below #If VBA7 Then should get completely ignored (regardless of any syntax errors or anything else) and the stuff under #Else, e.g. vOlder, should be accessible.
Let us know if this helps you trace the error.