Converting 32 bit OleAut call into 64 bit in VBA - excel

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

Related

Call to MultiByteToWideChar() in 64-bit office gives wrong result

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.

Using Waitable Timer objects in VBA - invalid handle error

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

Obtaining Image File Dimensions From URL

I have this link:
https://s23527.pcdn.co/wp-content/uploads/2017/04/wine_speedlights_kit_lens.jpg.optimal.jpg
It is on Cell A2:
I want to get on Cell B2 the dimensions of the URL of this JPG
(I don't mind how to get it, it can be 1920 on cell B2 and 1080 on cell C2)
You will need to make an API call to URLDownloadToFile to download your image. In the below example, we will download to the temp folder C:\Temp\.
Once your image is downloaded, you will create a new Shell object, and ultimately use the .ExtendedProperty() property to grab your file dimensions
After you have finished downloading your file, you can go ahead and delete the temporary file using Kill().
The below method uses Early Binding. You will need to set a reference to
Microsoft Shell Controls And Automation
By going to Tools -> References in the VBE menu
Option Explicit
#If VBA7 Then
Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
(ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#Else
Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
(ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#End If
Sub test()
Const tmpDir$ = "C:\Temp\"
Const tmpFile$ = "tmpPicFile.jpg"
Debug.Print URLDownloadToFile(0, ActiveSheet.Range("A2").Value, tmpDir & tmpFile, 0, 0)
ActiveSheet.Range("B2").Value = getFileDimensions(tmpDir, tmpFile)
Kill tmpDir & tmpFile
End Sub
Private Function getFileDimensions(filePath$, fileName$) As String
With New Shell32.Shell
With .Namespace(filePath).ParseName(fileName)
getFileDimensions = .ExtendedProperty("Dimensions")
End With
End With
End Function

CreateProcess not retrieving correct PID for OSK

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

PtrSafe in Excel 2003 is giving me problems

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.

Resources