Attribute VB_Name = "modShellCommand"
Option Explicit


'=============================================================================================================
'
' modShellCommand Module
' ----------------------
'
' Created By  : Kevin Wilson
'               http://www.TheVBZone.com   ( The VB Zone )
'               http://www.TheVBZone.net   ( The VB Zone .net )
'
' Last Update : January 10, 2003
' Created On  : January 10, 2003
'
' VB Versions : 5.0 / 6.0
'
' Requires    : Security rights to execute the COMMAND.COM file (which must be located in your Windows search path)
'
' Description : This module allows you to execute "MS-DOS" style commands that you'd normally execute at a
'               command prompt (i.e. - IISRESET, PING 127.0.0.1, TRACERT 127.0.0.1, etc) and get back the
'               result text that would normally be printed to the command console.  This can be helpfull in
'               checking the return status of "MS-DOS" style commands.
'
'=============================================================================================================
'
' LEGAL:
'
' You are free to use this code as long as you keep the above heading information intact and unchanged. Credit
' given where credit is due.  Also, it is not required, but it would be appreciated if you would mention
' somewhere in your compiled program that that your program makes use of code written and distributed by
' Kevin Wilson (www.TheVBZone.com).  Feel free to link to this code via your web site or articles.
'
' You may NOT take this code and pass it off as your own.  You may NOT distribute this code on your own server
' or web site.  You may NOT take code created by Kevin Wilson (www.TheVBZone.com) and use it to create products,
' utilities, or applications that directly compete with products, utilities, and applications created by Kevin
' Wilson, TheVBZone.com, or Wilson Media.  You may NOT take this code and sell it for profit without first
' obtaining the written consent of the author Kevin Wilson.
'
' These conditions are subject to change at the discretion of the owner Kevin Wilson at any time without
' warning or notice.  Copyright© by Kevin Wilson.  All rights reserved.
'
'=============================================================================================================


' Enumeration - "C-Style" Boolean values
Public Enum BOOL
   FALSE_ = 0
   TRUE_ = 1
End Enum

' Constants - General
Private Const MAX_PATH As Long = 260

' Constants - OpenProcess(lngAccessType)
Private Const STANDARD_RIGHTS_REQUIRED = &HF0000 '
Private Const PROCESS_CREATE_PROCESS = &H80      ' Used internally.
Private Const PROCESS_CREATE_THREAD = &H2        ' Enables using the process handle in the CreateRemoteThread function to create a thread in the process.
Private Const PROCESS_DUP_HANDLE = &H40          ' Enables using the process handle as either the source or target process in the DuplicateHandle function to duplicate a handle.
Private Const PROCESS_QUERY_INFORMATION = &H400  ' Enables using the process handle in the GetExitCodeProcess and GetPriorityClass functions to read information from the process object.
Private Const PROCESS_SET_QUOTA = &H100          ' Enables using the process handl in the AssignProcessToJobObject and SetProcessWorkingSetSize functions to set memory limits.
Private Const PROCESS_SET_INFORMATION = &H200    ' Enables using the process handle in the SetPriorityClass function to set the priority class of the process.
Private Const PROCESS_TERMINATE = &H1            ' Enables using the process handle in the TerminateProcess function to terminate the process.
Private Const PROCESS_VM_OPERATION = &H8         ' Enables using the process handle in the VirtualProtectEx and WriteProcessMemory functions to modify the virtual memory of the process.
Private Const PROCESS_VM_READ = &H10             ' Enables using the process handle in the ReadProcessMemory function to read from the virtual memory of the process.
Private Const PROCESS_VM_WRITE = &H20            ' Enables using the process handle in the WriteProcessMemory function to write to the virtual memory of the process.
Private Const SYNCHRONIZE = &H100000             ' Windows NT/2000: Enables using the process handle in any of the wait functions to wait for the process to terminate.
Private Const PROCESS_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or SYNCHRONIZE Or &HFFF) ' Specifies all possible access flags for the process object.

' Constants - GetExitCodeProcess(lngExitCode)
Private Const STATUS_WAIT_0 = &H0
Private Const STATUS_ABANDONED_WAIT_0 = &H80
Private Const STATUS_USER_APC = &HC0
Private Const STATUS_TIMEOUT = &H102
Private Const STATUS_PENDING = &H103
Private Const STATUS_SEGMENT_NOTIFICATION = &H40000005
Private Const STATUS_GUARD_PAGE_VIOLATION = &H80000001
Private Const STATUS_DATATYPE_MISALIGNMENT = &H80000002
Private Const STATUS_BREAKPOINT = &H80000003
Private Const STATUS_SINGLE_STEP = &H80000004
Private Const STATUS_ACCESS_VIOLATION = &HC0000005
Private Const STATUS_IN_PAGE_ERROR = &HC0000006
Private Const STATUS_INVALID_HANDLE = &HC0000008
Private Const STATUS_NO_MEMORY = &HC0000017
Private Const STATUS_ILLEGAL_INSTRUCTION = &HC000001D
Private Const STATUS_NONCONTINUABLE_EXCEPTION = &HC0000025
Private Const STATUS_INVALID_DISPOSITION = &HC0000026
Private Const STATUS_ARRAY_BOUNDS_EXCEEDED = &HC000008C
Private Const STATUS_FLOAT_DENORMAL_OPERAND = &HC000008D
Private Const STATUS_FLOAT_DIVIDE_BY_ZERO = &HC000008E
Private Const STATUS_FLOAT_INEXACT_RESULT = &HC000008F
Private Const STATUS_FLOAT_INVALID_OPERATION = &HC0000090
Private Const STATUS_FLOAT_OVERFLOW = &HC0000091
Private Const STATUS_FLOAT_STACK_CHECK = &HC0000092
Private Const STATUS_FLOAT_UNDERFLOW = &HC0000093
Private Const STATUS_INTEGER_DIVIDE_BY_ZERO = &HC0000094
Private Const STATUS_INTEGER_OVERFLOW = &HC0000095
Private Const STATUS_PRIVILEGED_INSTRUCTION = &HC0000096
Private Const STATUS_STACK_OVERFLOW = &HC00000FD
Private Const STATUS_CONTROL_C_EXIT = &HC000013A
Private Const STATUS_FLOAT_MULTIPLE_FAULTS = &HC00002B4
Private Const STATUS_FLOAT_MULTIPLE_TRAPS = &HC00002B5
Private Const STATUS_REG_NAT_CONSUMPTION = &HC00002C9
Private Const DBG_TERMINATE_THREAD = &H40010003
Private Const DBG_TERMINATE_PROCESS = &H40010004
Private Const DBG_CONTROL_C = &H40010005
Private Const DBG_CONTROL_BREAK = &H40010008
Private Const DBG_EXCEPTION_NOT_HANDLED = &H80010001
Private Const DBG_CONTINUE = &H10002

' Win32 API Declarations
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal lngMilliseconds As Long)
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As BOOL
Private Declare Function GetTempPath Lib "kernel32.dll" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function GetTempFileName Lib "kernel32.dll" Alias "GetTempFileNameA" (ByVal strTempFilePath As String, ByVal strFilePrefix As String, ByVal lngUniqueValue As Long, ByVal ReturnBuffer As String) As Long
Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal lngAccessType As Long, ByVal blnInheritHandle As BOOL, ByVal lngProcessID As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByRef lngExitCode As Long) As BOOL

Public Function ShellCommand(ByVal strCommand As String, _
                             ByRef Return_Text As String, _
                             Optional ByVal WindowStyle As VBA.VbAppWinStyle = vbNormalFocus, _
                             Optional ByVal intTimeoutSeconds As Integer = 30, _
                             Optional ByRef Return_ErrNum As Long, _
                             Optional ByRef Return_ErrSrc As String, _
                             Optional ByRef Return_ErrDesc As String) As Boolean
On Error GoTo ErrorTrap
   
   Dim strTempPath  As String
   Dim strTempFile  As String
   Dim intFileNum   As Integer
   Dim sngStartTime As Single
   Dim hProcess     As Long
   Dim strShell     As String
   Dim hShell       As Long
   Dim lngExitCode  As Long
   
   ' Set the default return values
   Return_Text = ""
   Return_ErrNum = 0
   Return_ErrSrc = ""
   Return_ErrDesc = ""
   
   ' Validate parameters
   If Trim(strCommand) = "" Then
      Err.Raise -1, "ShellCommand", "No valid command specified to execute"
   ElseIf WindowStyle <> vbHide And _
          WindowStyle <> vbMaximizedFocus And _
          WindowStyle <> vbMinimizedFocus And _
          WindowStyle <> vbMinimizedNoFocus And _
          WindowStyle <> vbNormalFocus And _
          WindowStyle <> vbNormalNoFocus Then
      Err.Raise -1, "ShellCommand", "Invalid window style specified"
   ElseIf intTimeoutSeconds < 1 Then
      intTimeoutSeconds = 1
   End If
   
   ' Get the system TEMP directory
   strTempPath = String(MAX_PATH, Chr(0))
   If GetTempPath(MAX_PATH, strTempPath) = 0 Then
      Err.Raise Err.LastDllError, "GetTempPath Win32 API", "Failed to get the path to the system temp folder"
   Else
      strTempPath = Left(strTempPath, InStr(1, strTempPath, Chr(0), vbTextCompare) - 1)
      If Right(strTempPath, 1) <> "\" Then strTempPath = strTempPath & "\"
   End If
   
   ' Get the file name of the TEMP file to use
   strTempFile = String(MAX_PATH, Chr(0))
   If GetTempFileName(strTempPath & Chr(0), "CMD" & Chr(0), 0, strTempFile) = 0 Then
      Err.Raise Err.LastDllError, "GetTempFileName Win32 API", "Failed to get the file name of the temp file to use"
   Else
      strTempFile = Left(strTempFile, InStr(1, strTempFile, Chr(0), vbTextCompare) - 1)
   End If
   
   ' Assemble the executable command
   strShell = "COMMAND.COM /C " & strCommand & " > " & strTempFile
   
   ' Execute the command
   hShell = Shell(strShell, WindowStyle)
   
   ' Get the handle to the running process
   hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, FALSE_, hShell)
   If hProcess = 0 Then
      Err.Raise -1, "OpenProcess Win32 API", "Failed to get the handle to the executing process"
   End If
   
   ' Get the current status of the executing command
   If GetExitCodeProcess(hProcess, lngExitCode) = FALSE_ Then
      CloseHandle hProcess
      Err.Raise Err.LastDllError, "GetExitCodeProcess Win32 API", "Failed to get the current status of the process " & CStr(hProcess)
   End If
   
   ' Loop while the process is still executing and the TIMEOUT hasn't expired
   sngStartTime = Timer
   Do While lngExitCode = STATUS_PENDING
      
      ' If the timeout has expired, error out
      If Timer - sngStartTime > intTimeoutSeconds Then
         CloseHandle hProcess
         Err.Raise -1, "ShellCommand", "The process execution timed out"
      End If
      
      ' Wait for a 10th of a second before checking the status of the executing command again
      DoEvents
      Sleep 100
      
      ' Get the current status of the executing command
      If GetExitCodeProcess(hProcess, lngExitCode) = FALSE_ Then
         CloseHandle hProcess
         Err.Raise Err.LastDllError, "GetExitCodeProcess Win32 API", "Failed to get the current status of the process " & CStr(hProcess)
      End If
      
   Loop
   
   ' Close the handle to the process we opened
   If CloseHandle(hProcess) = FALSE_ Then
      Err.Raise Err.LastDllError, "CloseHandle Win32 API", "Failed to successfully close the process handle"
   End If
   
   ' Make sure the temporary file was successfully created
   If Dir(strTempFile, vbArchive Or vbHidden Or vbNormal Or vbReadOnly Or vbSystem) <> "" Then
      
      ' Open the temporary output file and get it's contents
      Return_Text = String(FileLen(strTempFile), Chr(0))
      intFileNum = FreeFile
      Open strTempFile For Binary Access Read As #intFileNum
         Get #intFileNum, , Return_Text
      Close #intFileNum
      
      ' Delete the temporary output file
      Kill strTempFile
      
   End If
   
   ' Function executed successfully
   ShellCommand = True
   Exit Function
   
ErrorTrap:
   
   Return_ErrNum = Err.Number
   Return_ErrSrc = Err.Source
   Return_ErrDesc = Err.Description
   Err.Clear
   
End Function