Running EXCEL 2016 16.0.9126.2282 64-bit on Windows 10
I have an Excel App that uses VBA to run external program and capture the output and it worked fine on Excel 32-bit.
I had to update the program to work with Win64/VBA7 but now the call to GetStartupInfo crashes Excel.
I have tried everything but cannot find out why Excel is crashing.
I created a small app to show the problem.
Create a Module and paste the code below.
Execute the RunProcess subroutine and Excel will crash on the line "GetStartupInfo tStartupInfo"
Any help is greatly appreciated.
I have an Excel App that uses VBA to run external program and capture the output and it worked fine on Excel 32-bit.
I had to update the program to work with Win64/VBA7 but now the call to GetStartupInfo crashes Excel.
I have tried everything but cannot find out why Excel is crashing.
I created a small app to show the problem.
Create a Module and paste the code below.
Execute the RunProcess subroutine and Excel will crash on the line "GetStartupInfo tStartupInfo"
Any help is greatly appreciated.
Code:
Option Explicit
Private Const WAIT_INFINITE As Long = (-1&)
Private Const STARTF_USESHOWWINDOW As Long = &H1
Private Const STARTF_USESTDHANDLES As Long = &H100
Private Const SW_HIDE As Long = 0&
Private Const SW_SHOWNORMAL As Long = 1&
Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As LongPtr
bInheritHandle As Long
End Type
Type PROCESS_INFORMATION
hProcess As LongPtr
hThread As LongPtr
dwProcessId As Long
dwThreadId As Long
End Type
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 Declare PtrSafe Function CreatePipe Lib "kernel32" (phReadPipe As LongPtr, phWritePipe As LongPtr, lpPipeAttributes As SECURITY_ATTRIBUTES, ByVal nSize As Long) As Long
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 Long
Private Declare PtrSafe Function ReadFile Lib "kernel32" (ByVal hFile As LongPtr, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long
Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As LongPtr, ByVal dwMilliseconds As Long) As Long
Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As LongPtr, lpExitCode As Long) As Long
Private Declare PtrSafe Sub GetStartupInfo Lib "kernel32" Alias "GetStartupInfoA" (ByRef lpStartupInfo As STARTUPINFO)
Private Declare PtrSafe Function GetFileSize Lib "kernel32" (ByVal hFile As LongPtr, lpFileSizeHigh As Long) As Long
Sub RunProcess()
Dim tSA_CreatePipe As SECURITY_ATTRIBUTES
Dim tSA_CreateProcessPrc As SECURITY_ATTRIBUTES
Dim tSA_CreateProcessThrd As SECURITY_ATTRIBUTES
Dim tSA_CreateProcessPrcInfo As PROCESS_INFORMATION
Dim tStartupInfo As STARTUPINFO
Dim bRead As Long
Dim abytBuff() As Byte
Dim lngResult As Long
Dim szFullCommand As String
Dim lngExitCode As Long
Dim lngSizeOf As Long
Dim msg As String
Dim hRead As LongPtr
Dim hWrite As LongPtr
tSA_CreatePipe.nLength = Len(tSA_CreatePipe)
tSA_CreatePipe.lpSecurityDescriptor = 0&
tSA_CreatePipe.bInheritHandle = True
tSA_CreateProcessPrc.nLength = Len(tSA_CreateProcessPrc)
tSA_CreateProcessThrd.nLength = Len(tSA_CreateProcessThrd)
If (CreatePipe(hRead, hWrite, tSA_CreatePipe, 0&) <> 0&) Then
With tStartupInfo
.cb = LenB(tStartupInfo)
.lpReserved = vbNullString
.cbReserved2 = 0
.lpReserved2 = 0&
End With
GetStartupInfo tStartupInfo
With tStartupInfo
.hStdOutput = hWrite
.hStdError = hWrite
' .dwFlags = STARTF_USESTDHANDLES
.dwFlags = STARTF_USESHOWWINDOW Or STARTF_USESTDHANDLES
.wShowWindow = SW_HIDE
End With
szFullCommand = "cmd.exe /C dir"
lngResult = CreateProcess(0&, szFullCommand, tSA_CreateProcessPrc, tSA_CreateProcessThrd, True, 0&, ByVal 0&, vbNullString, tStartupInfo, tSA_CreateProcessPrcInfo)
If (lngResult <> 0&) Then
lngResult = WaitForSingleObject(tSA_CreateProcessPrcInfo.hProcess, 10000) ' for this test program wait 1 Sec instead of WAIT_INFINITE
lngSizeOf = GetFileSize(hRead, 0&)
If (lngSizeOf > 0) Then
ReDim abytBuff(lngSizeOf - 1)
If ReadFile(hRead, abytBuff(0), UBound(abytBuff) + 1, bRead, ByVal 0&) Then
msg = StrConv(abytBuff, vbUnicode)
End If
End If
Call GetExitCodeProcess(tSA_CreateProcessPrcInfo.hProcess, lngExitCode)
CloseHandle tSA_CreateProcessPrcInfo.hThread
CloseHandle tSA_CreateProcessPrcInfo.hProcess
If (lngExitCode <> 0&) Then
Debug.Print "Success"
Debug.Print msg
End If
CloseHandle hWrite
CloseHandle hRead
Else
Debug.Print "CreateProcess Failed, Code: " & Err.LastDllError
End If
End If
End Sub
