Untitled

DOS-Programme an der Console starten

und Ausgaben der Programme von der Console lesen.
Um die Ausgaben von DOS-Programmen in einem VBA-Programm auszuwerten, wird normalerweise die Ausgabe in eine Datei umgeleitet, die man dann per VBA auswertet.
Das geht aber auch ohne diesen Umweg mit der API.
Zu beachten ist vielleicht noch beim Testen, dass der Kommandozeileninterpreter von NT und Win9x in unterschiedlichen Dateien steckt. Bei NT (XP) ist es die cmd.exe, unter 9x ist es die Command.com. Ich habe die Timeoutzeit, vor der das aufgerufene Programm beendet sein muss, auf 60 Sekunden gesetzt. Danach wird der Prozess rigoros gekillt. Bei länger dauernden Programmen muss deshalb die Zeit entsprechend hochgesetzt werden.
Das Beispiel listet Dateien mittels Dir und den Befehlszeilenparametern /S (für alle Unterverzeichnisse) und /B (für nur Dateinamen) in einem Tabellenblatt auf.

Beispieldatei (dateiliste_dos_dir.zip 24 KB )

Option Explicit
Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type

Private Type STARTUPINFO
    cb As Long
    lpReserved As Long
    lpDesktop As Long
    lpTitle As Long
    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 Long
    hStdInput As Long
    hStdOutput As Long
    hStdError As Long
End Type

Private Type PROCESS_INFORMATION
    hProcess As Long
    hThread As Long
    dwProcessId As Long
    dwThreadId As Long
End Type

Private Declare Function TerminateProcess Lib "kernel32" _
(ByVal hProcess As Long, ByVal uExitCode As Long) As Long

Private Declare Function CreateProcess Lib "kernel32" _
    Alias "CreateProcessA" (ByVal _
    lpApplicationName As Long, ByVal lpCommandLine As String, _
    lpProcessAttributes As Any, lpThreadAttributes As Any, _
    ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
    ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, _
    lpStartupInfo As Any, lpProcessInformation As Any) As Long

Private Declare Function CreatePipe Lib "kernel32" ( _
    phReadPipe As Long, _
    phWritePipe As Long, _
    lpPipeAttributes As Any, _
    ByVal nSize As Long) As Long

Private Declare Function CopyFromPipe Lib "kernel32" _
    Alias "PeekNamedPipe" _
    (ByVal hNamedPipe As Long, lpBuffer As Any, _
    ByVal nBufferSize As Long, lpBytesRead As Long, _
    lpTotalBytesAvail As Long, lpBytesLeftThisMessage As Long) _
    As Long

Private Declare Function ReadFile Lib "kernel32" ( _
    ByVal hFile As Long, _
    ByVal lpBuffer As String, _
    ByVal nNumberOfBytesToRead As Long, _
    lpNumberOfBytesRead As Long, _
    ByVal lpOverlapped As Any) As Long

Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, lpExitCode As Long) As Long

Private Declare Function CloseHandle Lib "kernel32" (ByVal _
hObject As Long) As Long

Private Declare Function CharToOem Lib "user32" Alias "CharToOemA" _
(ByVal lpszSrc As String, ByVal lpszDst As String) As Long

Private Declare Function OemToChar Lib "user32" Alias "OemToCharA" _
(ByVal lpszSrc As String, ByVal lpszDst As String) As Long

Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const STARTF_USESTDHANDLES = &H100&
Private Const STILL_ACTIVE = &H103&
Private Const SW_HIDE = 0
Private Const SW_MAX = 10
Private Const SW_MAXIMIZE = 3
Private Const SW_MINIMIZE = 6
Private Const SW_NORMAL = 1
Private Const SW_SHOWDEFAULT = 10
Private Const SW_SHOWMAXIMIZED = 3
Private Const SW_SHOWMINIMIZED = 2
Private Const SW_SHOWMINNOACTIVE = 7
Private Const SW_SHOWNA = 8
Private Const SW_SHOWNOACTIVATE = 4
Private Const SW_SHOWNORMAL = 1

Private Sub DosCommandTest()
' MsgBox DosCommandResult("command.com dir c:") '<> NT
MsgBox DosCommandResult("cmd.exe /c dir c:") 'NT
End Sub

Public Function DosCommandResult(Kommando As String) As String
Dim MyProc As PROCESS_INFORMATION
Dim StartInf As STARTUPINFO
Dim SecAtt As SECURITY_ATTRIBUTES
Dim MyWritePipe As Long, MyReadPipe As Long
Dim ExitCode As Long, Verfügbar As Long
Dim Buffer As String
Dim MyTimeout As Date
With SecAtt
    .nLength = Len(SecAtt)
    .bInheritHandle = 1
End With
'Pipe anlegen, den nachher zur Ausgabe benutzt wird
If CreatePipe(MyReadPipe, MyWritePipe, SecAtt, 0) = 0 Then Exit Function
With StartInf 'Startattribute festlegen
    .cb = Len(StartInf)
    .wShowWindow = SW_HIDE
    .dwFlags = STARTF_USESTDHANDLES
    .hStdOutput = MyWritePipe
End With
'Prozess (Programm) starten
If CreateProcess(0&, Kommando, SecAtt, _
    SecAtt, 1&, NORMAL_PRIORITY_CLASS, _
    0&, 0&, StartInf, MyProc) <> 1 Then
        CloseHandle MyReadPipe
        CloseHandle MyWritePipe
        Exit Function 'Erfolglos
End If
'Zeitpunkt zum Timeout festsetzen
MyTimeout = Now + TimeSerial(0, 0, 60)
Do
    'Läuft Anwendung noch?
    GetExitCodeProcess MyProc.hProcess, ExitCode
    'Sind Zeichen im Lesepuffer?
    CopyFromPipe MyReadPipe, 0&, 0, 0, Verfügbar, 0
    If Verfügbar Then
        'Buffer groß genug machen
        Buffer = String(50000, 0)
        'Inhalt auslesen
        ReadFile MyReadPipe, Buffer, Len(Buffer), Verfügbar, 0&
        'Den Buffer auf dei Länge des geholten Textes Trimmen
        Buffer = Left$(Buffer, Verfügbar)
        DosCommandResult = DosCommandResult & Buffer
    End If
    'Wenn Anwendung nicht mehr läuft, beenden
    If ExitCode <> STILL_ACTIVE Then Exit Do
    If Now > MyTimeout Then
        'Wenn nichts mehr geht, Prozess nach 60 s
        ' mit DOS-Fenster zerstören
        TerminateProcess MyProc.hProcess, ExitCode
        Exit Do
    End If
    DoEvents
Loop
'OEM-Text nach Win-Ansi umwandeln
DosCommandResult = NachChar(DosCommandResult)
'Handles schließen
CloseHandle MyProc.hProcess
CloseHandle MyProc.hThread
CloseHandle MyReadPipe
CloseHandle MyWritePipe
End Function

Function NachChar(Quelle As String) As String
Dim Ziel$, Rück&
Ziel = String(Len(Quelle), 0)
Rück = OemToChar(Quelle, Ziel)
NachChar = Ziel
End Function

Function NachOem(Quelle As String) As String
Dim Ziel$, Rück&
Ziel = String(Len(Quelle), 0)
Rück = CharToOem(Quelle, Ziel)
NachOem = Ziel
End Function