Piping the output of a Shell Command executed in VBA to a Specific Shell

Question

I am still very very new to VBA and started learning it a couple days ago. Now I am trying to create a Macro to execute a shell command and pipe the output to a specific cell in a specific worksheet. What I am trying to accomplish is to get a text dump of the directory structure into a worksheet. Below is the code i have so far.

Sub CopyList()

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

End Sub

Executing this macro brings up a command prompt and dumps the directory structure inside the cmd window. I was wondering how I could pipe this to a worksheet. Your help would be greatly appreciated.

Answer 1

You can create the WScript.Shell object and read the StdOut directly:

Sub SO()

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

End Sub

Answer 2

One approach would be to amend the Call Shell to:

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

This would create a text file in folder "C:\MyData" (replace by folder of your choice) containing what would have gone to the console. You could then open the text file and extract its contents.

VBA solution added in response to comment

If you want a VBA solution, you have two choices: function Dir$ and File Scripting Objects.

Function Dir$ is the older functionality. It offers file specifications with wildcards but otherwise offers less functionality than File Scripting Objects. I have decided to provide a File Scripting Objects solution because I almost always find it the more useful.

I believe the comments in the code below adequately explain what I am doing but do not explain the VBA statements I use. Once you know a statement exists it is easy to look it up. Ask questions if necessary but the more you can discover for yourself, the faster you will develop your knowledge and skills.

' 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