What makes Outlook crashing after executing CreateProcessWithLogonW ? - crash

I have an Outlook 2016 (64-bit) running next vba code, and when the function exits, Outlook crashes. The api executes fine and I see notepad launched under an other user.
Sub TestRunAs()
If User_RunAs("jonny", "JonnysPassword", "lvd.be", "c:\windows\notepad.exe") Then
MsgBox ("Ok, executed!")
End If
End Sub
This is the function;
Public Function User_RunAs(ByVal sUserName As String, ByVal sPassword As String, ByVal sDomain As String, ByVal sCommand As String) As Boolean
Dim lReturn As Long
Dim sApplication As String
Dim sDirectory As String
Dim tPInfo As PROCESS_INFORMATION
Dim tStart As STARTUPINFO
'/* default struct
sApplication = vbNullString
sDirectory = vbNullString
tStart.Cb = LenB(tStart)
tStart.dwFlags = 0&
lReturn = CreateProcessWithLogonW(StrPtr(sUserName), StrPtr(sDomain), StrPtr(sPassword), &H1, _
0&, StrPtr(sCommand), _
DEFAULT_LOGON, 0&, StrPtr(sDirectory), _
tStart, tPInfo)
' 1st row LongPtr LongPtr LongPtr Long
' 2nd row Long LongPtr
' 3rd row Long Long LongPtr
' 4th row Structure Structure
'/* success
If Not lReturn = 0 Then
User_RunAs = True
End If
'/* cleanup
If tPInfo.hProcess <> 0 Then
CloseHandle tPInfo.hThread
CloseHandle tPInfo.hProcess
End If
End Function
The definition is as follow;
'Types used by function User_RunAs
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 Long
lpDesktop As Long
lpTitle As Long
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 Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Private Declare PtrSafe Function CreateProcessWithLogonW Lib "advapi32" (ByVal lpUserName As LongPtr, ByVal lpDomain As LongPtr, ByVal lpPassword As LongPtr, ByVal dwLogonFlags As Long, _
ByVal lpApplicationName As Long, ByVal lpCommandLine As LongPtr, _
ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As LongPtr, _
ByRef lpStartupInfo As STARTUPINFO, ByRef lpProcessInfo As PROCESS_INFORMATION) As Long
Even when quiting the function just after the api call, Outlook crashes with next report;

When reading the MS documentation about compatibility on different bit version I found that on structures passed the Long must be replaced by LongPtr. See https://learn.microsoft.com/en-us/previous-versions/office/developer/office-2010/ee691831(v=office.14)
E.g. The passed structure
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessId As Long
dwThreadId As Long
End Type
must now be;
Private Type PROCESS_INFORMATION
hProcess As LongPtr
hThread As LongPtr
dwProcessId As LongPtr
dwThreadId As LongPtr
End Type

Related

Determine when a shelled process ends in VBA

I need to shell out to a web browser, login to a website and then return to the VBA code and continue processing. I have tried the code at https://learn.microsoft.com/en-us/office/vba/access/concepts/windows-api/determine-when-a-shelled-process-ends but this does not work with MS Edge (or Opera, Chrome or Firefox). I have tried calling the executable directly as "C:\Program Files (x86)\Microsoft\Edge\Application\msedge.exe" but this still does not work.
I had to change the functions to PtrSafe.
The code runs ok but when it gets to the lines
' Wait for the shelled application to finish:
Do
ReturnValue = WaitForSingleObject(proc.hProcess, 0)
DoEvents
Loop Until ReturnValue <> 258
The return value is 0 even though Edge is still open so it does not wait.
I am running MS-Access 2016 on Window 10 64 bit
CODE:
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 Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
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 LongPtr, ByVal dwMilliseconds As Long, ByVal bAlertable As Long) As Long
Private Declare PtrSafe Function CreateProcessA Lib "kernel32" (ByVal _
lpApplicationName As LongPtr, ByVal lpCommandLine As String, ByVal _
lpProcessAttributes As LongPtr, ByVal lpThreadAttributes As LongPtr, _
ByVal bInheritHandles As LongPtr, ByVal dwCreationFlags As LongPtr, _
ByVal lpEnvironment As LongPtr, ByVal lpCurrentDirectory As LongPtr, _
lpStartupInfo As STARTUPINFO, lpProcessInformation As _
PROCESS_INFORMATION) As Long
Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal _
hObject As LongPtr) As Long
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&
Public Sub ExecCmd(cmdline As String)
Dim proc As PROCESS_INFORMATION
Dim start As STARTUPINFO
Dim ReturnValue As Integer
' Initialize the STARTUPINFO structure:
start.cb = Len(start)
' Start the shelled application:
ReturnValue = CreateProcessA(0&, cmdline$, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)
' Wait for the shelled application to finish:
Do
ReturnValue = WaitForSingleObject(proc.hProcess, 1, 0)
DoEvents
Loop Until ReturnValue <> 258
ReturnValue = CloseHandle(proc.hProcess)
End Sub
Please, change the two used Type declarations as following and CreateProcess should return a LongPtr:
Private Type STARTUPINFO
cb As Long
padding1 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
padding2 As Long
lpReserved2 As LongPtr '!!!
hStdInput As LongPtr '!!!
hStdOutput As LongPtr '!!!
hStdError As LongPtr '!!!
End Type
Private Type PROCESS_INFORMATION
hProcess As LongPtr '!!!
hThread As LongPtr '!!!
dwProcessID As Long
dwThreadID As Long
End Type
Private Declare PtrSafe Function CreateProcessA Lib "kernel32" (ByVal _
lpApplicationName As LongPtr, ByVal lpCommandLine As String, ByVal _
lpProcessAttributes As LongPtr, ByVal lpThreadAttributes As LongPtr, _
ByVal bInheritHandles As LongPtr, ByVal dwCreationFlags As LongPtr, _
ByVal lpEnvironment As LongPtr, ByVal lpCurrentDirectory As LongPtr, _
lpStartupInfo As STARTUPINFO, lpProcessInformation As _
PROCESS_INFORMATION) As LongPtr '!!!
Then, (in the used Sub) Dim ReturnValue As Integer should be changed in Dim ReturnValue As LongPtr.
Please, test it and send some feedback.
I tested for Edge application and it waits for process termination.

CreateProcess with CREATE_SUSPENDED cannot be ResumeThread-ed

I'm stuck using WINAPI's CreateProcess with CREATE_SUSPENDED and ResumeThread from VBA.
I would like to start a process (and receive it's Process ID) and be able to suspend and resume its main thread (depending on a more complicated scheme considering the resource utilisation use of my computer - not detailed here). I came up with the below code and have the following problems:
LastDllError is 18 after calling CreateProcess although the return
value is nonzero. What does this mean?
ResumeThread fails with ERROR_INVALID_HANDLE, and does not resume
it. What is wrong here?
My code:
Option Explicit
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle 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 PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessId As Long
dwThreadId As Long
End Type
Private Const CREATE_SUSPENDED As Long = 4
Private Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" ( _
ByVal lpApplicationName As String, _
ByVal lpCommandLine As String, _
ByRef lpProcessAttributes As SECURITY_ATTRIBUTES, _
ByRef lpThreadAttributes As SECURITY_ATTRIBUTES, _
ByVal bInheritHandles As Long, _
ByVal dwCreationFlags As Long, _
ByRef lpEnvironment As Any, _
ByVal lpCurrentDirectory As String, _
ByRef lpStartupInfo As STARTUPINFO, _
ByRef lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function SuspendThread Lib "kernel32" (hThread As Long) As Long
Private Declare Function ResumeThread Lib "kernel32" (hThread As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function DebugActiveProcess Lib "kernel32" (ByVal dwProcessId As Long) As Long
Private Declare Function DebugActiveProcessStop Lib "kernel32" (ByVal dwProcessId As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Function WinApi_CreateProcess(strCommandLine As String, Optional strCurrentDirectory As String = vbNullString) As Long
If strCurrentDirectory = vbNullString Then
strCurrentDirectory = ThisWorkbook.Path
End If
Dim sap As SECURITY_ATTRIBUTES: sap.nLength = Len(sap)
Dim sat As SECURITY_ATTRIBUTES: sat.nLength = Len(sat)
Dim si As STARTUPINFO: si.cb = Len(si)
Dim pi As PROCESS_INFORMATION
Debug.Print Err.LastDllError ' 0 => ERROR_SUCCESS
Dim dwResult As Long: dwResult = CreateProcess(vbNullString, strCommandLine, sap, sat, 0, CREATE_SUSPENDED, 0, strCurrentDirectory, si, pi)
Debug.Print Err.LastDllError ' 18 => ERROR_NO_MORE_FILES (but dwResult <> 0 => Success)
If dwResult = 0 Then
WinApi_CreateProcess = 0: Exit Function
End If
CloseHandle pi.hProcess
Debug.Print Err.LastDllError ' 0 => ERROR_SUCCESS
Dim dwSuspendCount As Long: dwSuspendCount = ResumeThread(pi.hThread)
Debug.Print dwSuspendCount ' -1
If dwSuspendCount = -1 Then
Debug.Print Err.LastDllError ' 6 => ERROR_INVALID_HANDLE
CloseHandle pi.hThread
WinApi_CreateProcess = 0: Exit Function
Else
Debug.Print Err.LastDllError ' Not this branch
CloseHandle pi.hThread
WinApi_CreateProcess = pi.dwProcessId: Exit Function
End If
End Function
After modify all pointer types to LongPtr instead of Long, I can use the sample to reproduce your problem with 64-bit Excel. You could also refer to the statement here
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As LongPtr
bInheritHandle 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 LongPtr
hStdInput As LongPtr
hStdOutput As LongPtr
hStdError As LongPtr
End Type
Private Type PROCESS_INFORMATION
hProcess As LongPtr
hThread As LongPtr
dwProcessId As Long
dwThreadId As Long
End Type
Then I get true result for CreateProcess and ERROR_INVALID_HANDLE error for ResumeThread, I found that ResumeThread parameter did not declare with ByVal(the same as SuspendThread). After add ByVal, the sample works for me.
Declare PtrSafe Function SuspendThread Lib "kernel32" (ByVal hThread As LongPtr) As Long
Declare PtrSafe Function ResumeThread Lib "kernel32" (ByVal hThread As LongPtr) As Long
LastDllError is 18 after calling CreateProcess although the return value is nonzero. What does this mean?
It means you are using Err.LastDllError incorrectly. If CreateProcess() succeeds (returns non-zero), the value of Err.LastDllError is indeterminate, so just ignore it. Its value will be meaningful only if CreateProcess() fails (returns zero).
ResumeThread fails with ERROR_INVALID_HANDLE, and does not resume it. What is wrong here?
You are checking the return value of ResumeThread() incorrectly, so you are checking Err.LastDllError at the wrong time, again.
Per the ResumeThread() documentation:
If the function succeeds, the return value is the thread's previous suspend count.
If the function fails, the return value is (DWORD) -1. To get extended error information, call GetLastError.
In this case, you are checking the return value of ResumeThread() against 0, but the process was created in a suspended state, so its main thread's suspend count would be 1, and so ResumeThread() should be returning 1 if the thread is successfully resumed, but you are treating that as a failure condition instead of a success condition.
You need to change this:
If ResumeThread(pi.hThread) <> 0 Then
To this:
If ResumeThread(pi.hThread) = -1 Then
And clean up your use of Err.LastDllError, eg:
Public Function WinApi_CreateProcess(strCommandLine As String, Optional strCurrentDirectory As String = vbNullString) As Long
If strCurrentDirectory = vbNullString Then
strCurrentDirectory = ThisWorkbook.Path
End If
Dim sap As SECURITY_ATTRIBUTES: sap.nLength = Len(sap)
Dim sat As SECURITY_ATTRIBUTES: sat.nLength = Len(sat)
Dim si As STARTUPINFO: si.cb = Len(si)
Dim pi As PROCESS_INFORMATION
Dim dwResult As Long: dwResult = CreateProcess(vbNullString, strCommandLine, sap, sat, 0, CREATE_SUSPENDED, 0, strCurrentDirectory, si, pi)
If dwResult = 0 Then
Debug.Print Err.LastDllError
WinApi_CreateProcess = 0: Exit Function
End If
CloseHandle pi.hProcess
Dim dwSuspendCount As Long: dwSuspendCount = ResumeThread(pi.hThread)
If dwSuspendCount = -1 Then
Debug.Print Err.LastDllError
CloseHandle pi.hThread
WinApi_CreateProcess = 0: Exit Function
End If
CloseHandle pi.hThread
WinApi_CreateProcess = pi.dwProcessId
End Function
But, you really don't need to create a process suspended and then resume it just to grab its process ID. Get rid of CREATE_SUSPENDED and ResumeThread() altogether, you don't actually need them in this situation:
Public Function WinApi_CreateProcess(strCommandLine As String, Optional strCurrentDirectory As String = vbNullString) As Long
If strCurrentDirectory = vbNullString Then
strCurrentDirectory = ThisWorkbook.Path
End If
Dim sap As SECURITY_ATTRIBUTES: sap.nLength = Len(sap)
Dim sat As SECURITY_ATTRIBUTES: sat.nLength = Len(sat)
Dim si As STARTUPINFO: si.cb = Len(si)
Dim pi As PROCESS_INFORMATION
Dim dwResult As Long: dwResult = CreateProcess(vbNullString, strCommandLine, sap, sat, 0, 0, 0, strCurrentDirectory, si, pi)
If dwResult = 0 Then
Debug.Print Err.LastDllError
WinApi_CreateProcess = 0: Exit Function
End If
CloseHandle pi.hThread
CloseHandle pi.hProcess
WinApi_CreateProcess = pi.dwProcessId
End Function

VBA ShellWait API 32 and 64 bit compatibility

I have the following code that I tried to make compatible for 32 and 64 bit (Access 2010+).
Option Compare Database
Option Explicit
'This code was originally written by Terry Kreft.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code Courtesy of
'Terry Kreft
Private Const STARTF_USESHOWWINDOW& = &H1
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&
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 Long
hStdInput As LongPtr
hStdOutput As LongPtr
hStdError As LongPtr
End Type
Private Type PROCESS_INFORMATION
hProcess As LongPtr
hThread As LongPtr
dwProcessID As Long
dwThreadID As Long
End Type
'Added
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As LongPtr
bInheritHandle As Long
End Type
Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" (ByVal _
hHandle As LongPtr, ByVal dwMilliseconds As Long) As Long
'Type not defined
Declare PtrSafe Function CreateProcessA Lib "kernel32" _
(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
' Original
'Private 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, _
lpStartupInfo As STARTUPINFO, lpProcessInformation As _
PROCESS_INFORMATION) As Long
Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal _
hObject As LongPtr) As Long
Public Sub ShellWait(Pathname As String, Optional WindowStyle As Long)
Dim proc As PROCESS_INFORMATION
Dim start As STARTUPINFO
Dim ret As Long
' Initialize the STARTUPINFO structure:
With start
.cb = Len(start)
If Not IsMissing(WindowStyle) Then
.dwFlags = STARTF_USESHOWWINDOW
.wShowWindow = WindowStyle
End If
End With
' Start the shelled application:
ret& = CreateProcessA(0&, Pathname, 0&, 0&, 1&, _
NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc) 'TEST SECURITY_ATTRIBUTES Data Types
' Wait for the shelled application to finish:
ret& = WaitForSingleObject(proc.hProcess, INFINITE) ' TEST proc.hProcess is LongPtr
ret& = CloseHandle(proc.hProcess) ' TEST proc.hProcess is LongPtr
End Sub
Public Function GetExecutableForFile(strFileName As String) As String
Dim lngRetval As LongPtr
Dim strExecName As String * 255
lngRetval = FindExecutable(strFileName, vbNullString, strExecName)
GetExecutableForFile = Left$(strExecName, InStr(strExecName, Chr$(0)) - 1)
End Function
Sub RunIt(strNewFullPath As String)
Dim exeName As String
exeName = GetExecutableForFile(strNewFullPath)
Shell exeName & " " & Chr(34) & strNewFullPath & Chr(34), vbNormalFocus
End Sub
I already tinkered with it from this site by adding LongPtr where I believe it should of been. I also added SECURITY_ATTRIBUTES type that wasn't in the original code.
I am getting a compile error on the following line under the ShellWait sub:
ret& = CreateProcessA(0&, Pathname, 0&, 0&, 1&, _
NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)
The error is on the third parameter and says: "ByRef Argument Type Mismatched"
Originally the SECURITY_ATTRIBUTES were type Long.
If I change back to LongPtr the error is gone, but does not work when I try the command ShellWait "clac.exe"
I get no error message when debugging line by line. Nothing happens.
I am testing in 64 bit Access first.
There are a few issues to tackle here.
First, the API function should return a LongPtr. You'll need to change that in your function declare statment. You'll also need to change your ret variable to a LongPtr.
Second, the reason for the type mismatch is because your parameter value 0& is not of type SECURITY_ATTRIBUTES. You must build a SECURITY_ATTRIBUTES type and pass that in as a parameter.
EDIT:
Here is all the code I have in a module that is compiling just fine. Just want to see if I can help understand why you are still getting the compiler error:
Option Explicit
'This code was originally written by Terry Kreft.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code Courtesy of
'Terry Kreft
Private Const STARTF_USESHOWWINDOW& = &H1
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&
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 Long
hStdInput As LongPtr
hStdOutput As LongPtr
hStdError As LongPtr
End Type
Private Type PROCESS_INFORMATION
hProcess As LongPtr
hThread As LongPtr
dwProcessID As Long
dwThreadID As Long
End Type
'Added
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As LongPtr
bInheritHandle As Long
End Type
Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" (ByVal _
hHandle As LongPtr, ByVal dwMilliseconds As Long) As Long
'Type not defined
Declare PtrSafe Function CreateProcessA Lib "kernel32" _
(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
' Original
'Private 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, _
lpStartupInfo As STARTUPINFO, lpProcessInformation As _
PROCESS_INFORMATION) As Long
Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal _
hObject As LongPtr) As Long
Public Sub ShellWait(Pathname As String, Optional WindowStyle As Long)
Dim proc As PROCESS_INFORMATION
Dim start As STARTUPINFO
Dim ret As LongPtr
'Not used, but needed
Dim si1 As SECURITY_ATTRIBUTES
Dim si2 As SECURITY_ATTRIBUTES
' Initialize the STARTUPINFO structure:
With start
.cb = Len(start)
If Not IsMissing(WindowStyle) Then
.dwFlags = STARTF_USESHOWWINDOW
.wShowWindow = WindowStyle
End If
End With
'Set the structure size
si1.nLength = Len(si1)
si2.nLength = Len(si2)
' Start the shelled application:
ret = CreateProcessA(vbNullString, Pathname, si1, si2, False, _
NORMAL_PRIORITY_CLASS, 0&, vbNullString, start, proc) 'TEST SECURITY_ATTRIBUTES Data Types
' Wait for the shelled application to finish:
ret = WaitForSingleObject(proc.hProcess, INFINITE) ' TEST proc.hProcess is LongPtr
ret = CloseHandle(proc.hProcess) ' TEST proc.hProcess is LongPtr
End Sub

Detect when selected process has exited

How to detect when the selected process is closed in vb.net ? i tried all codes in google, but it still fails.
here's the code :
Private Sub Process1_Exited(ByVal sender As System.Object,
ByVal e As System.EventArgs) Handles Process1.Exited
MessageBox.Show("exited")
End Sub
but when the process is closed, there's nothing appear.
Process1_Exited is an event handler - you have to register it.
You may want to work with Process class. See Process.Exited.
Dim Process1 As New Process ' Getting a new object
Process1.StartInfo.FileName = "" ' Setting up the file path
Process1.EnableRaisingEvents = True ' Enabling raising events
AddHandler Process1.Exited, AddressOf Process1_Exited ' Registering your event handler
Process1.Start() ' Starting the process
Private Sub Process1_Exited(ByVal sender As Object, ByVal e As System.EventArgs)
' Process exited
End Sub
Add these Win32 declarations
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 Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadID As Long
End Type
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _
hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CreateProcessA Lib "kernel32" (ByVal _
lpApplicationName As String, 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 String, _
lpStartupInfo As STARTUPINFO, lpProcessInformation As _
PROCESS_INFORMATION) As Long
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, lpExitCode As Long) As Long
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&
Public Function ExecCmd(cmdline$)
Dim proc As PROCESS_INFORMATION
Dim start As STARTUPINFO
' Initialize the STARTUPINFO structure:
start.cb = Len(start)
' Start the shelled application:
ret& = CreateProcessA(vbNullString, cmdline$, 0&, 0&, 1&, _
NORMAL_PRIORITY_CLASS, 0&, vbNullString, start, proc)
' Wait for the shelled application to finish:
ret& = WaitForSingleObject(proc.hProcess, INFINITE)
Call GetExitCodeProcess(proc.hProcess, ret&)
Call CloseHandle(proc.hThread)
Call CloseHandle(proc.hProcess)
ExecCmd = ret&
End Function
Sub Your_Sub_To_Wait_For_Exit()
Dim retval As Long
retval = ExecCmd("notepad.exe")
MsgBox "Process Finished, Exit Code " & retval
End Sub
The MsgBox statement following the ExecCmd() function is not executed because the WaitForSingleObject() function prevents it. The message box does not appear until Notepad is closed when the user chooses Exit from Notepad's File menu (ALT, F, X)

Using RegOpenKeyEx to enumerate through registry on 64bit office/64 bit Windows

I've looked at various solutions for this to no avail. I posted this on another site, but no-one came up with the answer.
The main objective is to see if MySQL ODBC driver has been installed. I've been doing this by enumerating through the registry using RegOpenKeyEx. No problem using 32 bit Office on 64 Bit Windows.
But won't work on 64Bit Office on 64bit Windows.
The code below shows the many things I tried. When testing on 32 bit office, only the line with KEY_ALL_ACCESS works. Otherwise, none of the other lines work for either 32 or 64 bit.
And yes, on my 64Bit Office machine, the item ("MySQL ODBC 5.2 ANSI Driver") is in the registry located at: "HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\ODBCINST.INI"
Any ideas?
#If VBA7 Then
Declare PtrSafe Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" ( _
ByVal hkey As Long, ByVal dwIndex As Long, ByVal lpName As String, _
ByVal cbName As Long) As Long
Declare PtrSafe Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" ( _
ByVal hkey As Long, ByVal dwIndex As Long, ByVal lpName As String, _
lpcbName As Long, lpReserved As Long, ByVal lpClass As String, _
lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
Declare PtrSafe Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" ( _
ByVal hkey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
lpcbValueName As Long, lpReserved As Long, lpType As Long, _
lpData As Byte, lpcbData As Long) As Long
#else
Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" ( _
ByVal hkey As Long, ByVal dwIndex As Long, ByVal lpName As String, _
ByVal cbName As Long) As Long
Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" ( _
ByVal hkey As Long, ByVal dwIndex As Long, ByVal lpName As String, _
lpcbName As Long, lpReserved As Long, ByVal lpClass As String, _
lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" ( _
ByVal hkey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
lpcbValueName As Long, lpReserved As Long, lpType As Long, _
lpData As Byte, lpcbData As Long) As Long
#End If
Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Function CheckForMySQlDriverInstallTest() As Boolean
'*********BEGIN CODE HERE ********
Dim strKeyPath As String, key As String
Dim i As Long, lrc As Long
Dim hkey As Long, lRetval As Long
'Various key constants
Const KEY_ALL_ACCESS = &H3F
Const KEY_WOW64_64KEY As Long = &H100& '32 bit app to access 64 bit hive
Const KEY_WOW64_32KEY As Long = &H200& '64 bit app to access 32 bit hive
Const KEY_QUERY_VALUE = &H1
strKeyPath = "SOFTWARE\ODBC\ODBCINST.INI"
hkey = 0
'The line below works for 32bit office with the
' value of strKeyPath = "SOFTWARE\Wow6432Node\ODBC\ODBCINST.INI"
lRetval = RegOpenKeyEx(HKEY_LOCAL_MACHINE, strKeyPath, 0, KEY_ALL_ACCESS, hkey)
'None of these work for 32 or 64 Office regardless of the strKeyPath used
'lRetval = RegOpenKeyEx(HKEY_LOCAL_MACHINE, strKeyPath, 0, KEY_WOW64_64KEY, hkey)
'lRetval = RegOpenKeyEx(HKEY_LOCAL_MACHINE, strKeyPath, 0, KEY_WOW64_32KEY, hkey)
'lRetval = RegOpenKeyEx(HKEY_LOCAL_MACHINE, strKeyPath, 0, KEY_QUERY_VALUE, hkey)
If (lRetval = 0) Then
lrc = 0
i = 0
'Request all keys
While lrc = 0
lrc = EnumKey(hkey, i, key)
Debug.Print key
'If the version is found, set function to TRUE and exit
If InStr(1, key, "MySQL ODBC 5.2 ANSI Driver") > 0 Then
Exit Function
End If
If (lrc = 0) Then
i = i + 1
End If
Wend
End If
If (hkey <> 0) Then
RegCloseKey hkey
End If
End Function
Public Function EnumKey(ByVal hkey As Long, ByVal index As Long, ByRef key As String) As Long
Dim cch As Long
Dim lrc As Long
Dim ltype As Long
Dim lValue As Long
Dim szKeyName As String
cch = 260
szKeyName = String$(cch, 0)
lrc = RegEnumKey(hkey, index, szKeyName, cch)
If (lrc = 0) Then
key = Left$(szKeyName, InStr(szKeyName, Chr$(0)) - 1)
End If
EnumKey = lrc
End Function
Your pointer sized integers are all the wrong size under 64 bit. You have used Long, which is a 32 bit data type, but you need to use LongPtr, which is the same size as a pointer. From the documentation:
LongPtr (Long integer on 32-bit systems, LongLong integer on 64-bit systems) variables are stored as signed 32-bit (4-byte) numbers ranging in value from -2,147,483,648 to 2,147,483,647 on 32-bit systems; and signed 64-bit (8-byte) numbers ranging in value from -9,223,372,036,854,775,808 to 9,223,372,036,854,775,807 on 64-bit systems.
So, all the HKEY parameters, and all the pointers, need to be declared as LongPtr.
You really should not be using KEY_ALL_ACCESS. That won't succeed unless you are running elevated, and there's not need to elevate just to read out of HKLM. You need to combine the flags using bitwise or. You need to us
KEY_READ Or KEY_WOW64_64KEY
or
KEY_READ Or KEY_WOW64_32KEY
To wrap this up I've altered John original code so that it works on both 32bit and 64bit systems regarding 32bit and 64bit Office systems.
Since code sample formatting has issues with '#' replace '~!' by '#'.
Const HKEY_LOCAL_MACHINE = &H80000002
Const PROCESSOR_ARCHITECTURE_AMD64 = 9
~!If VBA7 Then
Declare PtrSafe Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" _
(ByVal hKey As LongPtr, ByVal lpSubKey As String, ByVal ulOptions As Long, _
ByVal samDesired As Long, phkResult As LongPtr) As Long
Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As LongPtr) As Long
Declare PtrSafe Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" ( _
ByVal hKey As LongPtr, ByVal dwIndex As Long, ByVal lpName As String, _
ByVal cbName As Long) As Long
Declare PtrSafe Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" ( _
ByVal hKey As LongPtr, ByVal dwIndex As Long, ByVal lpName As String, _
lpcbName As Long, lpReserved As Long, ByVal lpClass As String, _
lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
Declare PtrSafe Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" ( _
ByVal hKey As LongPtr, ByVal dwIndex As Long, ByVal lpValueName As String, _
lpcbValueName As Long, lpReserved As Long, lpType As Long, _
lpData As Byte, lpcbData As Long) As Long
Type SYSTEM_INFO
wProcessorArchitecture As Integer
wReserved As Integer
dwPageSize As Long
lpMinimumApplicationAddress As LongPtr
lpMaximumApplicationAddress As LongPtr
dwActiveProcessorMask As LongPtr
dwNumberOrfProcessors As Long
dwProcessorType As Long
dwAllocationGranularity As Long
wProcessorLevel As Integer
wProcessorRevision As Integer
End Type
Declare PtrSafe Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO)
Declare PtrSafe Function GetCurrentProcess Lib "kernel32" () As LongPtr
Declare PtrSafe Function IsWow64Process Lib "kernel32" ( _
ByVal hProcess As LongPtr, _
ByRef Wow64Process As Boolean) As Boolean
~!Else
Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" _
(ByVal lKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, _
ByVal samDesired As Long, phkResult As Long) As Long
Declare Function RegCloseKey Lib "advapi32" (ByVal lKey As Long) As Long
Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" ( _
ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, _
ByVal cbName As Long) As Long
Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" ( _
ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, _
lpcbName As Long, lpReserved As Long, ByVal lpClass As String, _
lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" ( _
ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
lpcbValueName As Long, lpReserved As Long, lpType As Long, _
lpData As Byte, lpcbData As Long) As Long
Type SYSTEM_INFO
wProcessorArchitecture As Integer
wReserved As Integer
dwPageSize As Long
lpMinimumApplicationAddress As Long
lpMaximumApplicationAddress As Long
dwActiveProcessorMask As Long
dwNumberOrfProcessors As Long
dwProcessorType As Long
dwAllocationGranularity As Long
dwReserved As Long
End Type
Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO)
Declare Function GetCurrentProcess Lib "kernel32" () As Long
Declare Function IsWow64Process Lib "kernel32" ( _
ByVal hProcess As Long, _
ByRef Wow64Process As Boolean) As Boolean
~!End If
Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Function CheckForMySQlDriverInstallTest() As Boolean
'*********BEGIN CODE HERE ********
Dim sKeyPath As String
Dim sKey As String
Dim i As Long
Dim lrc As Long
Dim lRetval As Long
~!If VBA7 Then
Dim hKey As LongPtr
~!Else
Dim hKey As Long
~!End If
'Various sKey constants
Const KEY_ALL_ACCESS = &H3F
Const KEY_WOW64_64KEY As Long = &H100& '32 bit app to access 64 bit hive
Const KEY_WOW64_32KEY As Long = &H200& '64 bit app to access 32 bit hive
Const KEY_QUERY_VALUE = &H1
~!If Win64 Then
'32 or 64 Office?
If IsOffice64Bit Then
sKeyPath = "SOFTWARE\ODBC\ODBCINST.INI"
Else
sKeyPath = "SOFTWARE\Wow6432Node\ODBC\ODBCINST.INI"
End If
~!Else
sKeyPath = "SOFTWARE\ODBC\ODBCINST.INI"
~!End If
lRetval = RegOpenKeyEx(HKEY_LOCAL_MACHINE, sKeyPath, 0, KEY_ALL_ACCESS, hKey)
'None of these work for 32 or 64 Office regardless of the sKeyPath used
'lRetval = RegOpenKeyEx(HKEY_LOCAL_MACHINE, sKeyPath, 0, KEY_WOW64_64KEY, hkey)
'lRetval = RegOpenKeyEx(HKEY_LOCAL_MACHINE, sKeyPath, 0, KEY_WOW64_32KEY, hkey)
'lRetval = RegOpenKeyEx(HKEY_LOCAL_MACHINE, sKeyPath, 0, KEY_QUERY_VALUE, hkey)
If (lRetval = 0) Then
lrc = 0
i = 0
'Request all keys
While lrc = 0
lrc = EnumKey(hKey, i, sKey)
Debug.Print sKey
'If the version is found, set function to TRUE and exit
If InStr(1, sKey, "MySQL ODBC 5.2 ANSI Driver") > 0 Then
Exit Function
End If
If (lrc = 0) Then
i = i + 1
End If
Wend
End If
If (hKey <> 0) Then
RegCloseKey hKey
End If
End Function
~!If VBA7 Then
Function EnumKey(ByVal hKey As LongPtr, ByVal index As Long, ByRef key As String) As Long
~!Else
Function EnumKey(ByVal hKey As Long, ByVal index As Long, ByRef key As String) As Long
~!End If
Dim lcch As Long
Dim lrc As Long
Dim ltype As Long
Dim lValue As Long
Dim szKeyName As String
lcch = 260
szKeyName = String$(lcch, 0)
lrc = RegEnumKey(hKey, index, szKeyName, lcch)
If (lrc = 0) Then
key = Left$(szKeyName, InStr(szKeyName, Chr$(0)) - 1)
End If
EnumKey = lrc
End Function
Function IsOffice64Bit() As Boolean
Dim lpSystemInfo As SYSTEM_INFO
Call GetSystemInfo(lpSystemInfo)
If lpSystemInfo.wProcessorArchitecture = PROCESSOR_ARCHITECTURE_AMD64 Then
Call IsWow64Process(GetCurrentProcess(), IsOffice64Bit)
IsOffice64Bit = Not IsOffice64Bit
End If
End Function