- Option Explicit
- Private Declare Function CreatePipe Lib "kernel32" (phReadPipe As Long, phWritePipe As Long, lpPipeAttributes As SECURITY_ATTRIBUTES, 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 Type SECURITY_ATTRIBUTES
- nLength As Long
- lpSecurityDescriptor As Long
- bInheritHandle As Long
- End Type
- Private Type STARTUPINFO
- cb As Long
- lpReserved As String
- lpDesktop As String
- lpTitle As String
- 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 CreateProcessAsUser Lib "advapi32.dll" Alias "CreateProcessAsUserA" (ByVal hToken As Long, ByVal lpApplicationName As String, ByVal lpCommandLine As String, ByVal lpProcessAttributes As SECURITY_ATTRIBUTES, ByVal lpThreadAttributes As SECURITY_ATTRIBUTES, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As String, ByVal lpCurrentDirectory As String, ByVal lpStartupInfo As STARTUPINFO, ByVal lpProcessInformation As PROCESS_INFORMATION) As Long
- Private Declare Function CreateProcessA Lib "kernel32" (ByVal lpApplicationName As Long, ByVal lpCommandLine As String, lpProcessAttributes As SECURITY_ATTRIBUTES, lpThreadAttributes As SECURITY_ATTRIBUTES, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
- Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
- Private Const NORMAL_PRIORITY_CLASS = &H20
- Private Const STARTF_USESTDHANDLES = &H100
- Private Const STARTF_USESHOWWINDOW = &H1
- Private Function ExecuteCommandLineOutput(CommandLine As String, Optional BufferSize As Long = 256, Optional TimeOut As Long) As String
- Dim Proc As PROCESS_INFORMATION
- Dim Start As STARTUPINFO
- Dim SA As SECURITY_ATTRIBUTES
- Dim hReadPipe As Long
- Dim hWritePipe As Long
- Dim lBytesRead As Long
- Dim sBuffer As String
- If VBA.Len(CommandLine) > 0 Then
- SA.nLength = Len(SA)
- 'SA.nLength = vba.Len(sa)
- SA.bInheritHandle = 1&
- SA.lpSecurityDescriptor = 0&
- If CreatePipe(hReadPipe, hWritePipe, SA, 0) > 0 Then
- Start.cb = Len(Start)
- Start.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
- Start.hStdOutput = hWritePipe
- Start.hStdError = hWritePipe
- If CreateProcessA(0&, CommandLine, SA, SA, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, Start, Proc) = 1 Then
- CloseHandle hWritePipe
- sBuffer = VBA.String(BufferSize, VBA.Chr(0))
- If TimeOut > 0 Then
- Dim BeginTime As Date
- BeginTime = VBA.Now
- End If
- Do Until ReadFile(hReadPipe, sBuffer, BufferSize, lBytesRead, 0&) = 0
- DoEvents
- If TimeOut > 0 Then
- If VBA.DateDiff("s", BeginTime, VBA.Now) > TimeOut Then
- ExecuteCommandLineOutput = "Timeout"
- Exit Do
- End If
- End If
- ExecuteCommandLineOutput = ExecuteCommandLineOutput & VBA.Left(sBuffer, lBytesRead)
- Loop
- CloseHandle Proc.hProcess
- CloseHandle Proc.hThread
- CloseHandle hReadPipe
- Else
- ExecuteCommandLineOutput = "File or command not found"
- End If
- Else
- ExecuteCommandLineOutput = "CreatePipe failed. Error: " & Err.LastDllError & "."
- End If
- End If
- End Function
- Private Sub Command1_Click() '测试
- 'VBA.MsgBox ExecuteCommandLineOutput("ping www.sina.com.cn")
- VBA.MsgBox ExecuteCommandLineOutput("ping www.baidu.com", , 2)
- End Sub
- //该片段来自于http://www.codesnippet.cn/detail/050620133812.html
来源: http://www.codesnippet.cn/detail/050620133812.html