如何定义文件夹的路径？

Question

I have code for listing folders, sub folders and filenames. I have to choose a folder by clicking the code.

How it is possible to define path? I have tried to uncomment MyPath but it didn't work.

My path: "\\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

---------------- EDIT ---------------------

Same path in another code that is working. This code is doing quite the same but I don't like the output of listing folders.

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

Create new worksheet and list sub folders there:

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

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

Answer 1

Get rid of the objFolder and objShell (and any dependent conditional code, etc.). Then you should be able to hardcode MyPath . As presently written, this code is using the objShell to browse.

Get rid of this:

'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

Replace with this:

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

NOTE: It is important that the MyPath end with a backslash character, while you can hardcode that on the same line, eg:

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

It may be best to add a check for it (similar to the original code) just in case you forget, so:

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