将 VBA 中执行的 Shell 命令的输出通过管道传输到特定的 Shell

Question

我对 VBA 还是很陌生，几天前开始学习它。现在我正在尝试创建一个宏来执行 shell 命令并将输出传递到特定工作表中的特定单元格。我想要完成的是将目录结构的文本转储到工作表中。以下是我到目前为止的代码。

Sub CopyList()

    Call Shell("cmd.exe /S /K" & "dir /s /b directoryPath", vbNormalFocus)

End Sub

执行此宏会打开命令提示符并将目录结构转储到 cmd 窗口中。我想知道如何将其传输到工作表。非常感谢您的帮助。

Answer 1

您可以创建 WScript.Shell 对象并直接读取 StdOut：

Sub SO()

Range("A1").Value = CreateObject("WScript.Shell").Exec("CMD /S /C dir /s /b directoryPath").StdOut.ReadAll

End Sub

Answer 2

一种方法是将Call Shell 修改为：

Call Shell("cmd.exe /S /K" & "dir /s /b directoryPath >C:\MyData\dir.txt", vbNormalFocus)

这将在文件夹“C:\MyData”（由您选择的文件夹替换）中创建一个文本文件，其中包含将发送到控制台的内容。然后您可以打开文本文件并提取其内容。

针对评论添加了 VBA 解决方案

如果您想要 VBA 解决方案，您有两个选择：函数 Dir$ 和 File Scripting Objects。

函数Dir$ 是较旧的函数。它提供带有通配符的文件规范，但在其他方面提供的功能少于File Scripting Objects。我决定提供File Scripting Objects 解决方案，因为我几乎总是觉得它更有用。

我相信下面代码中的 cmets 充分解释了我在做什么，但没有解释我使用的 VBA 语句。一旦你知道一个语句存在，就很容易查找它。如有必要，可以提出问题，但您自己发现的越多，您的知识和技能发展就越快。

' The subroutine ListFiles needs a reference to "Microsoft Scripting Runtime".
' Within VBE, click Tools then References. If "Microsoft Scripting Runtime" is
' not near the top and ticked, scroll down and click box to its left.
Option Explicit
Sub TestListFiles()

  With Worksheets("Sheet1")
    .Range("C1").Value = "Folder"
    .Range("D1").Value = "File"
    .Range("E1").Value = "Attributes"
    .Range("F1").Value = "Last modified"
    .Range("C1:F1").Font.Bold = True
  End With

  ' #### Replace parameters with ones appropriate for your system
  ' #### if you want to use this test routine.
  Call ListFiles("Sheet1", 2, 3, "C:\DataArea\NHSIC")

End Sub
Sub ListFiles(ByVal WshtName As String, ByVal RowTop As Long, _
              ByVal ColLeft As Long, ByVal FolderRootName As String)

  ' Writes a list of all files within the folder named FolderRootName,
  ' and its subfolders, starting at Worksheets(WshtName).Cells(RowTop, ColLeft)

  Dim FileObj As File
  Dim FileSysObj As FileSystemObject
  Dim FolderNameCrnt As String
  Dim FolderObj As Folder
  Dim FolderSubObj As Folder
  Dim FoldersToCheck As New Collection
  Dim RowCrnt As Long
  Dim Wsht As Worksheet

  Application.ScreenUpdating = False
  Set Wsht = Worksheets(WshtName)
  RowCrnt = RowTop

  Set FileSysObj = CreateObject("Scripting.FileSystemObject")

  ' Prime FoldersToCheck with the root folder
  FoldersToCheck.Add FolderRootName

  Do While FoldersToCheck.Count > 0

    ' Extract and delete first folder name in FoldersToCheck
    FolderNameCrnt = FoldersToCheck(1)
    FoldersToCheck.Remove (1)

    ' Get folder object for first name in FoldersToCheck
    Set FolderObj = FileSysObj.GetFolder(FolderNameCrnt)

    ' Add any subfolders of current folder to FoldersToCheck ready to be
    ‘ checked by a later repeat of this loop.
    For Each FolderSubObj In FolderObj.SubFolders
      FoldersToCheck.Add FolderNameCrnt & "\" & FolderSubObj.Name
    Next

    ' Output details of any files within current folder. I have output
    ' more details than requested to give a hint of what is available.
    For Each FileObj In FolderObj.Files
      With Wsht
        .Cells(RowCrnt, ColLeft).Value = FolderNameCrnt
        .Cells(RowCrnt, ColLeft + 1).Value = FileObj.Name
        .Cells(RowCrnt, ColLeft + 2).Value = AttrNumToNames(FileObj.Attributes)
        With .Cells(RowCrnt, ColLeft + 3)
          .Value = FileObj.DateLastModified
          .NumberFormat = "d mmm yyyy"
        End With
      End With
      RowCrnt = RowCrnt + 1
    Next
    DoEvents    ' Allows code to be interrupted if necessary
  Loop

  Wsht.Columns.AutoFit

  Application.ScreenUpdating = True

End Sub
Function AttrNumToNames(ByVal AttrNum As Long) As String

  ' Convert an attribute number into the list of properties it represents

  Dim Names As String

  Names = ""

  If AttrNum >= 128 Then
    Names = "Compressed " & Names
    AttrNum = AttrNum - 128
  End If
  If AttrNum >= 64 Then
    ' Some documentation says this is only for Mac. Other documentation
    ' implies it is also used with Windows. During my experimentation
    ' I have not found any shortcut with it set.
    Names = "Link " & Names
    AttrNum = AttrNum - 64
  End If
  If AttrNum >= 32 Then
    Names = "ToBeArchived " & Names
    AttrNum = AttrNum - 32
  End If
  If AttrNum >= 16 Then
    Names = "Directory " & Names
    AttrNum = AttrNum - 16
  End If
  If AttrNum >= 8 Then
    Names = "Label " & Names
    AttrNum = AttrNum - 8
  End If
  If AttrNum >= 4 Then
    Names = "System " & Names
    AttrNum = AttrNum - 4
  End If
  If AttrNum >= 2 Then
    Names = "Hidden " & Names
    AttrNum = AttrNum - 2
  End If
  If AttrNum >= 1 Then
    Names = "Read-only " & Names
    AttrNum = AttrNum - 1
  End If
  If Names = "" Then
    Names = "None"
  End If

  AttrNumToNames = Names

End Function