问:vba中如何调用dos，将返回值输出到excle中

Question

vba中如何调用dos，将返回值输出到excel中
我想再excel中，建两个文本框和一个按钮，在第一个文本框中输入dos命令，例如：“dir/w”，点击按钮后，在第二个文本框中返回执行后的内容。
读取文件的方式我已经会了，我想问一个不用生成临时文件，通过api调用来实现的方法，谢谢，最好各个代码。

Answer 1

看来没有人帮我，不过我找到方法了，如下：
有需要的可以看一下Option ExplicitPrivate Declare Function CreatePipe Lib "kernel32" ( _
    phReadPipe As Long, _
    phWritePipe As Long, _
    lpPipeAttributes As SECURITY_ATTRIBUTES, _
    ByVal nSize As Long) As LongPrivate 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 LongPrivate Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End TypePrivate 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 TypePrivate Type PROCESS_INFORMATION
    hProcess As Long
    hThread As Long
    dwProcessId As Long
    dwThreadId As Long
End TypePrivate 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 LongPrivate 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 LongPrivate Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As LongPrivate Const NORMAL_PRIORITY_CLASS = &H20
Private Const STARTF_USESTDHANDLES = &H100
Private Const STARTF_USESHOWWINDOW = &H1Private 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.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.Trim(VBA.Replace(VBA.Left(sBuffer, lBytesRead), VBA.Chr(0), ""))
                
                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 FunctionPrivate Sub CommandButton1_Click()    TextBox1.Text = ExecuteCommandLineOutput("cmd /c dir", , 0)End Sub

Answer 2

我也找到了，
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 = &H1Private Sub test() ''''测试
   VBA.MsgBox ExecuteCommandLineOutput("ping www.sina.com.cn")
End SubPrivate 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'执行并返回一个命令行程序(shell程序)的标准输出和标准错误输出
'通常命令行程序的所有输出都直接送到屏幕上
Private Function ExecuteApp(sCmdline As String) As String
    Dim Proc As PROCESS_INFORMATION, ret As Long
    Dim Start As STARTUPINFO
    Dim SA As SECURITY_ATTRIBUTES
    Dim hReadPipe As Long
    '负责读取的管道
    Dim hWritePipe As Long
    '负责Shell程序的标准输出和标准错误输出的管道
    Dim sOutput As String
    '放返回的数据
    Dim lngBytesRead As Long, sBuffer As String * 256
    SA.nLength = Len(SA)
    SA.bInheritHandle = True
    ret = CreatePipe(hReadPipe, hWritePipe, SA, 0)
    If ret = 0 Then
    MsgBox "CreatePipe failed. Error: " & Err.LastDllError
    Exit Function
    End If
    Start.cb = Len(Start)
    Start.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
    ' 把标准输出和标准错误输出重定向到同一个管道中去。
    Start.hStdOutput = hWritePipe
    Start.hStdError = hWritePipe
    Start.wShowWindow = SW_HIDE
    '隐含shell程序窗口
    ' 启动shell程序, sCmdLine指明执行的路径
    ret = CreateProcessA(0&, sCmdline, SA, SA, True, _
        NORMAL_PRIORITY_CLASS, 0&, 0&, Start, Proc)
    If ret = 0 Then
    MsgBox "无法建立新进程，错误码：" & Err.LastDllError
    Exit Function
    End If
    ' 本例中不必向shell程序送信息，因此可以先关闭hWritePipe
    CloseHandle hWritePipe
    ' 循环读取shell程序的输出，每次读取256个字节。
    Do
    ret = ReadFile(hReadPipe, sBuffer, 256, lngBytesRead, 0&)
    sOutput = sOutput & Left$(sBuffer, lngBytesRead)
    Loop While ret <> 0
    ' 如果ret=0代表没有更多的信息需要读取了
    ' 释放相关资源
    CloseHandle Proc.hProcess
    CloseHandle Proc.hThread
    CloseHandle hReadPipe
    ExecuteApp = sOutput
    ' 输出结果
End FunctionSub tt()
    MsgBox ExecuteApp("ver")
End Sub

Answer 3

上面的内容帖多了
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 = &H1Private Sub test() ''''测试
   VBA.MsgBox ExecuteCommandLineOutput("ping www.sina.com.cn")
End SubPrivate 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