Как определить путь к папке?

Question

У меня есть код для перечисления папок, вложенных папок и имен файлов.Я должен выбрать папку, нажав на код.

Как можно определить путь?Я пытался раскомментировать MyPath, но это не сработало.

Мой путь: "\ infra \ Services \ turb"

Sub ListAllFilesInAllFolders()

    Dim MyPath As String, MyFolderName As String, MyFileName As String
    Dim i As Integer, F As Boolean
    Dim objShell As Object, objFolder As Object, AllFolders As Object, AllFiles As Object
    Dim MySheet As Worksheet

    On Error Resume Next

    '************************
    'Select folder
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "", 0, 0)
    If Not objFolder Is Nothing Then
        'MyPath = "\\infra\Services\turb"
        MyPath = objFolder.self.Path & "\"
    Else
        Exit Sub
       'MyPath = "\\infra\Services\turb"
    End If
    Set objFolder = Nothing
    Set objShell = Nothing

    '************************
    'List all folders

    Set AllFolders = CreateObject("Scripting.Dictionary")
    Set AllFiles = CreateObject("Scripting.Dictionary")
    AllFolders.Add (MyPath), ""
    i = 0
    Do While i < AllFolders.Count
        Key = AllFolders.keys
        MyFolderName = Dir(Key(i), vbDirectory)
        Do While MyFolderName <> ""
            If MyFolderName <> "." And MyFolderName <> ".." Then
                If (GetAttr(Key(i) & MyFolderName) And vbDirectory) = vbDirectory Then
                    AllFolders.Add (Key(i) & MyFolderName & "\"), ""
                End If
            End If
            MyFolderName = Dir
        Loop
        i = i + 1
    Loop

    'List all files
    For Each Key In AllFolders.keys
        MyFileName = Dir(Key & "*.*")
        'MyFileName = Dir(Key & "*.PDF")    'only PDF files
        Do While MyFileName <> ""
            AllFiles.Add (Key & MyFileName), ""
            MyFileName = Dir
        Loop
    Next

    '************************
    'List all files in Files sheet

    For Each MySheet In ThisWorkbook.Worksheets
        If MySheet.Name = "Files" Then
            Sheets("Files").Cells.Delete
            F = True
            Exit For
        Else
            F = False
        End If
    Next
    If Not F Then Sheets.Add.Name = "Files"

    'Sheets("Files").[A1].Resize(AllFolders.Count, 1) = WorksheetFunction.Transpose(AllFolders.keys)
    Sheets("Files").[A1].Resize(AllFiles.Count, 1) = WorksheetFunction.Transpose(AllFiles.keys)
    Set AllFolders = Nothing
    Set AllFiles = Nothing
End Sub

---------------- РЕДАКТИРОВАТЬ ---------------------

Тот же путь в другом работающем коде.Этот код делает то же самое, но мне не нравится вывод списка папок.

Option Explicit

Private iColumn As Integer

    Sub TestListFolders(strPath As String, Optional bFolders As Boolean = True)

        Application.ScreenUpdating = False

        Cells.Delete

        Range("A1").Select
        iColumn = 1

         ' add headers
        With Range("A1")
            .Formula = "Folder contents: " & strPath
            .Font.Bold = True
            .Font.Size = 12
        End With

        If Right(strPath, 1) <> "\" Then
            strPath = strPath & "\"
        End If

        ListFolders strPath, bFolders

        Application.ScreenUpdating = True

    End Sub

ListFolders:

Sub ListFolders(SourceFolderName As String, IncludeSubfolders As Boolean)
     ' lists information about the folders in SourceFolder
     ' example: ListFolders "C:\", True
    Dim FSO As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
    Dim r As Long
    Dim strfile As String

    Set FSO = New Scripting.FileSystemObject
    Set SourceFolder = FSO.GetFolder(SourceFolderName)

     'line added by dr for repeated "Permission Denied" errors

    On Error Resume Next

    iColumn = iColumn + 1

     ' display folder properties
    ActiveCell.Offset(1).Select

    With Cells(ActiveCell.Row, iColumn)
        .Formula = SourceFolder.Name
        .Font.ColorIndex = 11
        .Font.Bold = True

        .Select
    End With

    strfile = Dir(SourceFolder.Path & "\*.*")

    If strfile <> vbNullString Then
        ActiveCell.Offset(0, 1).Select
        Do While strfile <> vbNullString
            ActiveCell.Offset(1).Select
            ActiveCell.Value = strfile
            strfile = Dir

        Loop
        ActiveCell.Offset(0, -1).Select

    End If

    Cells(r, 0).Formula = SourceFolder.Name
    Cells(r, 3).Formula = SourceFolder.Size
    Cells(r, 4).Formula = SourceFolder.SubFolders.Count
    Cells(r, 5).Formula = SourceFolder.Files.Count
    Cells(r, 6).Formula = SourceFolder.ShortName
    Cells(r, 7).Formula = SourceFolder.ShortPath
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFolders SubFolder.Path, True

            iColumn = iColumn - 1
        Next SubFolder
        Set SubFolder = Nothing
    End If

    Set SourceFolder = Nothing
    Set FSO = Nothing

End Sub

Создайте новый рабочий лист и подпапки списка там:

Sub ListAllFilesTurb()
Dim WS As Worksheet
Set WS = Sheets.Add

Sheets.Add.Name = "Turb"
TestListFolders "\\infra\Services\turb"
End Sub

Answer 1

Избавьтесь от objFolder и objShell (и от любого зависимого условного кода и т. Д.).Тогда вы сможете суметь закодировать MyPath.Как написано в настоящее время, этот код использует objShell для просмотра.

Избавьтесь от этого:

'Select folder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "", 0, 0)
If Not objFolder Is Nothing Then
    'MyPath = "\\infra\Services\turb"
    MyPath = objFolder.self.Path & "\"
Else
    Exit Sub
   'MyPath = "\\infra\Services\turb"
End If
Set objFolder = Nothing
Set objShell = Nothing

Замените на это:

' Define hard-coded folder:
MyPath = "\\infra\Services\turb"  '# Modify as needed

ПРИМЕЧАНИЕ: Важно, чтобы MyPath заканчивался символом обратной косой черты, в то время как вы можете жестко закодировать его в той же строке, например:

MyPath = "\\infra\Services\turb\" 

Лучше всего добавить проверку дляэто (похоже на оригинальный код) на тот случай, если вы забудете, так:

MyPath = "\\infra\Services\turb" 
'### Ensure the path ends with a separator:
MyPath = MyPath & IIf(Right(MyPath, 1) = Application.PathSeparator, "", Application.PathSeparator)