excel - 如何定义文件夹的路径？

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

列表文件夹：

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

标签： excelvba

Answer 1

摆脱objFolderand 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

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

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)