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 |