Attribute VB_Name = "modDosCommand"
Option Explicit


'=============================================================================================================
'
' modDosCommand Module
' --------------------
'
' Created By  : Kevin Wilson
'               http://www.TheVBZone.com   ( The VB Zone )
'               http://net.TheVBZone.com   ( The VB Zone .net )
'               http://rb.TheVBZone.com    ( The VB Zone [RB] )
'
' Last Update : October 06, 2004
' Created On  : October 06, 2004
'
' VB Versions : 5.0 / 6.0
'
' Requires    : WinNT4, Win2000, WinXP, Win2003  (doesn't work on Win95, Win98, or WinME [consider using "modShellCommand.bas" instead])
'               Security rights to execute the CMD.EXE 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.
'
'               The difference betwen this module and the "modShellCommand.bas" module is this module does not
'               write anything out to file in order to capture output text.  This can be especially useful if
'               all opperations need to be done in memory or file access is restricted.
'
' NOTE        : This code uses the "Windows Script Host Shell Object" (WSHOM.OCX) [WScript.Shell]
'
' See Also    : http://msdn.microsoft.com/scripting  (Scripting Home Page [OLD])
'               http://msdn.microsoft.com/library/en-us/dnanchor/html/Scriptinga.asp  (Scripting Home Page [NEW])
'               http://msdn.microsoft.com/downloads/list/webdev.asp  (Scripting Download Page)
'               http://msdn.microsoft.com/library/default.asp?url=/library/en-us/dnwinpro00/html/WindowsScriptingHost.asp?frame=true  (Article demonstrating the use of Windows Scripting)
'
'=============================================================================================================
'
' 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.
'
'=============================================================================================================


Private Const WshRunning As Long = 0  'The job is still running
Private Const WshFinished As Long = 1 'The job has completed

Private Declare Sub Sleep Lib "KERNEL32.DLL" (ByVal dwMilliseconds As Long)

' Seperate multiple DOS commands by "&"
Function ExecuteDosCommand(ByVal strCommand As String, _
                           ByRef Return_Text As String, _
                           Optional ByVal strSeperator As String = "---------------------------", _
                           Optional ByRef Return_ErrNum As Long = 0, _
                           Optional ByRef Return_ErrSrc As String = "", _
                           Optional ByRef Return_ErrDesc As String = "") As Boolean
On Error GoTo ErrorTrap
   
   Dim objShell       As Object 'As WSScript.Shell
   Dim objExec        As Object 'As WshScriptExec
   Dim strReturn      As String
   Dim lngReturn      As Long
   Dim astrCommands() As String
   Dim strCurrent     As String
   Dim lngCmdCount    As Long
   Dim lngPos         As Long
   Dim lngCurr        As Long
   Dim lngCounter     As Long
   
   Err.Clear
   
   ' Set default values
   ExecuteDosCommand = False
   Return_Text = ""
   Return_ErrNum = 0
   Return_ErrSrc = ""
   Return_ErrDesc = ""
   lngCurr = 1
   
   ' If there's nothing to execute, just exit
   If Trim(strCommand) = "" Then Err.Raise -1, "ExecuteDosCommand", "No command specified to execute"
   
   ' Parse through the command given and seperate each line so it can be executed individually and the results captured
   If InStr(lngCurr, strCommand, "&", vbTextCompare) > 0 Then lngPos = InStr(lngCurr, strCommand, "&", vbTextCompare)
   If lngPos < 1 Then
      strCurrent = Trim(strCommand)
      If strCurrent <> "" And UCase(strCurrent) <> "EXIT" Then
         strCurrent = strCurrent & " & exit"
         ReDim astrCommands(0) As String
         astrCommands(0) = strCurrent
         lngCmdCount = 1
      End If
   Else
      Do While lngPos > 0
         strCurrent = Mid(strCommand, lngCurr, lngPos - lngCurr)
         strCurrent = Trim(strCurrent)
         If strCurrent <> "" And UCase(strCurrent) <> "EXIT" Then
            strCurrent = strCurrent & " & exit"
            ReDim Preserve astrCommands(lngCmdCount) As String
            astrCommands(lngCmdCount) = strCurrent
            lngCmdCount = lngCmdCount + 1
         End If
         lngCurr = lngPos + 1
         lngPos = InStr(lngCurr, strCommand, "&", vbTextCompare)
      Loop
      strCurrent = Mid(strCommand, lngCurr)
      strCurrent = Trim(strCurrent)
      If strCurrent <> "" And UCase(strCurrent) <> "EXIT" Then
         strCurrent = strCurrent & " & exit"
         ReDim Preserve astrCommands(lngCmdCount) As String
         astrCommands(lngCmdCount) = strCurrent
         lngCmdCount = lngCmdCount + 1
      End If
   End If
   
   ' If no commands were found then exit
   If lngCmdCount < 1 Then
      ExecuteDosCommand = True
      Exit Function
   End If
   
   ' Create the shell object
   Set objShell = CreateObject("WScript.shell", vbNullString)
   
   ' Loop through all the commands and execute them one by one
   For lngCounter = 0 To lngCmdCount - 1
      
      ' Execute the commands and check for errors
      Set objExec = objShell.Exec("CMD /K " & astrCommands(lngCounter))
      If Not objExec Is Nothing Then
         
         ' Wait for the command to finish
         Do While objExec.Status = WshRunning
            Sleep 100
         Loop
         lngReturn = objExec.ExitCode
         
         ' Get the return from the command that executed (NOTE: The "objExec.StdOut" property returns a "Scripting.TextStream" object)
         If objExec.StdOut.AtEndOfStream = False Then
            If Return_Text <> "" Then Return_Text = Return_Text & vbCrLf & strSeperator & vbCrLf
            Do While objExec.StdOut.AtEndOfStream = False
               Return_Text = Return_Text & objExec.StdOut.ReadLine
            Loop
         End If
         
         ' Get any errors that occured from the command that executed (NOTE: The "objExec.StdErr" property returns a "Scripting.TextStream" object)
         If objExec.StdErr.AtEndOfStream = False Then
            If Return_Text <> "" Then Return_Text = Return_Text & vbCrLf & strSeperator & vbCrLf
            Return_Text = Return_Text & "** ERROR: "
            Do While objExec.StdErr.AtEndOfStream = False
               Return_Text = Return_Text & objExec.StdErr.ReadLine
            Loop
         End If
         
         ' If an error occured while executing the command, exit the program
         If lngReturn <> 0 Then
            Err.Raise lngReturn, "ExecuteDosCommand", "The shell command failed to execute successfully : return code = " & CStr(lngReturn) & ", return text = " & Return_Text
            Set objExec = Nothing
            Set objShell = Nothing
            Exit Function
         End If
         
         ' Clean up the "WshScriptExec" object
         Set objExec = Nothing
         
      End If
   Next
   
   ' Clean up
   Set objShell = Nothing
   Set objExec = Nothing
   ExecuteDosCommand = True
   Exit Function
   
ErrorTrap:
   
   Return_Text = ""
   Return_ErrNum = Err.Number
   Return_ErrSrc = Err.Source
   Return_ErrDesc = Err.Description
   Err.Clear
   
   Set objShell = Nothing
   Set objExec = Nothing
   
End Function