Zachycení výstupu z DOS okna

Postup:
Option Explicit

Private Declare Function CreatePipe Lib "kernel32" _
   (phReadPipe As Long, phWritePipe As Long, _
   lpPipeAttributes As Any, ByVal nSize 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 GetNamedPipeInfo Lib "kernel32" _
   (ByVal hNamedPipe As Long, lType As Long, _
   lLenOutBuf As Long, lLenInBuf As Long, lMaxInstances As Long) As Long

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 WaitForSingleObject Lib "kernel32" _
   (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CreateProcessA Lib "kernel32" _
   (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 CloseHandle Lib "kernel32" _
   (ByVal hObject As Long) As Long


Function ShellExecuteCapture(sCommandLine As String, _
   Optional bShowWindow As Boolean = False) As String

'Synchronní běh DOS příkazů a vracení výstupů z této činnosti.
'Vstup : sCommandLine - DOS příkaz, který se má provést
'             [bShowWindow] - pokud je True, pak je zobrazeno okno
'Výstup : Vrací výstupy z okna
'Poznámka : Pracuje pouze v případě, že aplikace vrací výstup na standardní
'                  výstupní zařízení (stdout).
' Pouze pro Windows NT

   Const clReadBytes As Long = 256
   Const INFINITE As Long = &HFFFFFFFF
   Const STARTF_USESHOWWINDOW = &H1,
   Const STARTF_USESTDHANDLES = &H100&
   Const SW_HIDE = 0, SW_NORMAL = 1
   Const NORMAL_PRIORITY_CLASS = &H20&
   Const PIPE_CLIENT_END = &H0
   Const PIPE_SERVER_END = &H1
   Const PIPE_TYPE_BYTE = &H0
   Const PIPE_TYPE_MESSAGE = &H4

   Dim tProcInfo As PROCESS_INFORMATION,
   Dim lRetVal As Long, lSuccess As Long
   Dim tStartupInf As STARTUPINFO
   Dim tSecurAttrib As SECURITY_ATTRIBUTES,
   Dim lhwndReadPipe As Long, lhwndWritePipe As Long
   Dim lBytesRead As Long, sBuffer As String
   Dim lPipeOutLen As Long, lPipeInLen As Long, lMaxInst As Long

   tSecurAttrib.nLength = Len(tSecurAttrib)
   tSecurAttrib.bInheritHandle = 1&
   tSecurAttrib.lpSecurityDescriptor = 0&

   lRetVal = CreatePipe(lhwndReadPipe, lhwndWritePipe, tSecurAttrib, 0)
   If lRetVal = 0 Then
      Exit Function
   End If

   tStartupInf.cb = Len(tStartupInf)
   tStartupInf.dwFlags = STARTF_USESTDHANDLES Or_
      STARTF_USESHOWWINDOW
   tStartupInf.hStdOutput = lhwndWritePipe
   If bShowWindow Then
      tStartupInf.wShowWindow = SW_NORMAL
   Else
      tStartupInf.wShowWindow = SW_HIDE
   End If

   lRetVal = CreateProcessA(0&, sCommandLine, tSecurAttrib, _
      tSecurAttrib, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, _
      tStartupInf, tProcInfo)

   If lRetVal <> 1 Then
      Exit Function
   End If

   WaitForSingleObject tProcInfo.hProcess, INFINITE

   lSuccess = GetNamedPipeInfo(lhwndReadPipe, PIPE_TYPE_BYTE, _
      lPipeOutLen, lPipeInLen, lMaxInst)
   If lSuccess Then
      sBuffer = String(lPipeOutLen, 0)
      lSuccess = ReadFile(lhwndReadPipe, sBuffer, lPipeOutLen, _
            lBytesRead, 0&)
      If lSuccess = 1 Then
         ShellExecuteCapture = Left$(sBuffer, lBytesRead)
      End If
   End If

   Call CloseHandle(tProcInfo.hProcess)
   Call CloseHandle(tProcInfo.hThread)
   Call CloseHandle(lhwndReadPipe)
   Call CloseHandle(lhwndWritePipe)

End Function


Příklad použití:
Vytvořte soubor "C:\test.bat", který bude obsahovat:
dir *.*


Sub Test()

   Debug.Print ShellExecuteCapture("C:\test.bat", False)

End Sub

Zpět

Autor: The Bozena