Выполнение вывода команды оболочки, выполненной в VBA, на конкретную оболочку

Question

Я все еще очень новичок в VBA и начал изучать ее пару дней назад. Теперь я пытаюсь создать макрос, чтобы выполнить команду оболочки и передать вывод в конкретную ячейку на конкретном листе. То, что я пытаюсь выполнить, - получить текстовый дамп структуры каталогов в рабочий лист. Ниже приведен код, который у меня есть.

Sub CopyList() 

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

End Sub 

Выполнение этого макроса выводит командную строку и выводит структуру каталогов внутри CMD окна. Мне было интересно, как я могу передать это на рабочий лист. Ваша помощь будет принята с благодарностью.

Answer 1

Один из подходов по внесению поправок в 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, потому что я почти всегда считаю его более полезным.

Я считаю, что комментарии в коде ниже адекватно объясняют, что я делаю, но не объясняю утверждения 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 

Answer 2

Вы можете создать объект WScript.Shell и прочитать STDOUT непосредственно:

Sub SO() 

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

End Sub