如何定義文件夾的路徑？

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)