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.xxxx.com.cn", , 2)
      End Sub