VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Sheller"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'SHELLER.CLS - This set of functions builds and executes a set of commands via the Shell procedure.
Option Explicit
Public Enum ShellConst
  AutoClose = 0                         'automatically close window on completion of batch
  NoAutoClose = 1                       'no automatic close
End Enum
Private lDebugMode As Boolean
Dim CmdFileName As String               'name of the batch file to hold commands
Dim lAutoClose As Integer               'TRUE if automatic window close
Dim FSO As FileSystemObject             'file system object
Dim CmdTS As TextStream                 'debug text file object
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Property Get DebugMode() As Boolean
  DebugMode = lDebugMode
End Property

Public Property Let DebugMode(ByVal NewDebugMode As Boolean)
  lDebugMode = NewDebugMode
End Property

Sub AddCmd(s As String)                 'Add a command to the batch file
  CmdTS.WriteLine s                     'add command to file
End Sub

Function Run(Optional md As Integer) As Long 'Complete construction of the batch file and execute it
  On Error GoTo RunError
  If lAutoClose Then
    CmdTS.WriteLine "@cls"              'complete auto close
  End If
  CmdTS.Close                           'close the file
  Set CmdTS = Nothing
  Set FSO = Nothing
  If Not lDebugMode Then
    Run = Shell32Bit(CmdFileName, md)   'non-debug or logging style debug; display according to caller wishes
  Else
    Run = Shell32Bit(CmdFileName, 1)    'debug; make sure we can see what happened
  End If
  Kill CmdFileName
  Exit Function
RunError:
  Err.Raise Err.Number, "", "Sheller.Run Error: " + Err.Description
  Run = Err.Number
End Function

Function Shell32Bit(ByVal JobToDo As String, wMode As Integer) As Long 'Shell to program and wait for completion
  Dim hProcess As Long
  Dim RetVal As Long
  Const PROCESS_QUERY_INFORMATION = &H400
  Const STILL_ACTIVE = &H103
  On Error GoTo Shell32BitError
  'Launches JobToDo as icon and capture process ID in hProcess
  hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, Shell(JobToDo, wMode))
  Do
    GetExitCodeProcess hProcess, RetVal 'Get the status of the process
DoEvents: Sleep 100                     'Sleep command recommended as well as DoEvents
  Loop While RetVal = STILL_ACTIVE      'Loop while the process is active
  Shell32Bit = RetVal                   'send exit code back to caller
  Exit Function
Shell32BitError:
  Err.Raise Err.Number, "", "Sheller.Shell32Bit Error: " + Err.Description
  Shell32Bit = Err.Number
End Function

Sub Init(AutoCloseorNoAutoClose As Integer) 'Start a Shell command file. The argument indicates if the shell's window is to be automatically closed upon completion.
  On Error GoTo InitError
  CmdFileName = "C:\" + "$" + Trim(str(Int(Rnd * 1000000#))) + "$" + ".BAT" 'assign a file name
  Set FSO = New FileSystemObject        'get the base object
  Set CmdTS = FSO.CreateTextFile(CmdFileName, True) 'open file
  lAutoClose = (AutoCloseorNoAutoClose = AutoClose) And Not lDebugMode 'set the options; let window stay open if in heavy debug
  If lAutoClose Then
    CmdTS.WriteLine "@echo off"         'set up for auto close
  End If
  Exit Sub
InitError:
  Err.Raise Err.Number, "", "Sheller.Init Error: " + Err.Description
End Sub

Private Sub Class_Initialize()
  DebugMode = False
End Sub