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