使用FileDialog(msoFileDialogFolderPicker)选文件夹遇运行时错误求助

问题场景 #

想替换VBA代码中固定路径的Set oFolder = ofso.GetFolder("F:\")为文件夹选择对话框，运行时触发错误：run-time error "Object variable or With block variable not set"，错误发生在oFolder = .SelectedItems(1) & "\"行，修改对象名称后问题仍未解决。

出错代码片段 #

Dim ofso As Scripting.FileSystemObject
Dim oFolder As Object
Dim oFile As Object
Dim i As Long, colFolders As New Collection, ws As Worksheet
 
Set ws = Sheets.Add(Type:=xlWorksheet, After:=ActiveSheet)
Set ofso = CreateObject("Scripting.FileSystemObject")
'Set oFolder = ofso.GetFolder("F:\") This is the line to be replaced with the folder picker and what was being used before.
'Start folder picker
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
    .Title = "Select A Target Folder"
    .AllowMultiSelect = False
    If .Show <> -1 Then Exit Sub 'Check if user clicked cancel button
    oFolder = .SelectedItems(1) & "\" 
End With

修改尝试的代码 #

Set oFolder = Application.FileDialog(msoFileDialogFolderPicker)

With oFolder
    .Title = "Select A Target Folder"
    .AllowMultiSelect = False
    If .Show <> -1 Then Exit Sub 'Check if user clicked cancel button
    oFolder = .SelectedItems(1) & "\" 
End With

完整无文件夹选择器的代码 #

Sub GetFilesColFunc()
    Application.ScreenUpdating = False
    
    Dim ofso As Scripting.FileSystemObject
    Dim FldrPicker As FileDialog
    Dim oFolder As Object
    Dim oFile As Object
    Dim i As Long, colFolders As New Collection, ws As Worksheet
 
    Set ws = Sheets.Add(Type:=xlWorksheet, After:=ActiveSheet)
    Set ofso = CreateObject("Scripting.FileSystemObject")
    Set oFolder = ofso.GetFolder("F:\")
    
    On Error Resume Next
           
    ws.Cells(1, 1) = "File Name"
    ws.Cells(1, 2) = "File Type"
    ws.Cells(1, 3) = "Date Created"
    ws.Cells(1, 4) = "Date Last Modified"
    ws.Cells(1, 5) = "Date Last Accessed"
    ws.Cells(1, 6) = "File Path"
    
    Rows(1).Font.Bold = True
    Rows(1).Font.Size = 11
    Rows(1).Borders(xlEdgeBottom).LineStyle = XlLineStyle.xlContinuous
    Range("C:E").Columns.AutoFit
           
    colFolders.Add oFolder          'start with this folder
    
    Do While colFolders.Count > 0      'process all folders
        Set oFolder = colFolders(1)    'get a folder to process
        colFolders.Remove 1            'remove item at index 1
                    
        For Each oFile In oFolder.Files
            
                ws.Cells(i + 2, 1) = oFile.Name
                ws.Cells(i + 2, 2) = oFile.Type
                ws.Cells(i + 2, 3) = oFile.DateCreated
                ws.Cells(i + 2, 4) = oFile.DateLastModified
                ws.Cells(i + 2, 5) = oFile.DateLastAccessed
                ws.Cells(i + 2, 6) = oFolder.Path
                i = i + 1
            
        Next oFile

        'add any subfolders to the collection for processing
        For Each sf In oFolder.SubFolders
            If Not SkipFolder(sf.Name) Then colFolders.Add sf 'Skips folders listed within the referenced function
        Next sf
           
    Loop

    Application.ScreenUpdating = True
    
End Sub

错误原因 #

1. oFolder实际需要的是FileSystemObject的Folder对象，直接将字符串路径赋值给它时，既没有用Set关键字，也没有通过ofso.GetFolder()将路径字符串转换为Folder对象，导致对象未正确初始化。
2. 修改尝试中，先将FileDialog对象赋值给oFolder，之后又试图将路径字符串赋值给同一个变量，类型不匹配，且同样缺少Set关键字。

修正方案 #

使用文件夹选择对话框获取路径后，通过ofso.GetFolder()将路径转换为Folder对象，并用Set关键字赋值给oFolder。

替换后的正确代码片段 #

Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
    .Title = "Select A Target Folder"
    .AllowMultiSelect = False
    If .Show <> -1 Then Exit Sub '用户点击取消则退出
    '将选中的路径转换为FileSystemObject的Folder对象，用Set赋值
    Set oFolder = ofso.GetFolder(.SelectedItems(1))
End With

完整修正后的代码 #

Sub GetFilesColFunc()
    Application.ScreenUpdating = False
    
    Dim ofso As Scripting.FileSystemObject
    Dim FldrPicker As FileDialog
    Dim oFolder As Object
    Dim oFile As Object
    Dim i As Long, colFolders As New Collection, ws As Worksheet
 
    Set ws = Sheets.Add(Type:=xlWorksheet, After:=ActiveSheet)
    Set ofso = CreateObject("Scripting.FileSystemObject")
    
    '添加文件夹选择对话框
    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
    With FldrPicker
        .Title = "Select A Target Folder"
        .AllowMultiSelect = False
        If .Show <> -1 Then 
            Application.ScreenUpdating = True
            Exit Sub '用户点击取消则退出，恢复屏幕更新
        End If
        Set oFolder = ofso.GetFolder(.SelectedItems(1))
    End With
    
    On Error Resume Next
           
    ws.Cells(1, 1) = "File Name"
    ws.Cells(1, 2) = "File Type"
    ws.Cells(1, 3) = "Date Created"
    ws.Cells(1, 4) = "Date Last Modified"
    ws.Cells(1, 5) = "Date Last Accessed"
    ws.Cells(1, 6) = "File Path"
    
    Rows(1).Font.Bold = True
    Rows(1).Font.Size = 11
    Rows(1).Borders(xlEdgeBottom).LineStyle = XlLineStyle.xlContinuous
    Range("C:E").Columns.AutoFit
           
    colFolders.Add oFolder          'start with this folder
    
    Do While colFolders.Count > 0      'process all folders
        Set oFolder = colFolders(1)    'get a folder to process
        colFolders.Remove 1            'remove item at index 1
                    
        For Each oFile In oFolder.Files
            
                ws.Cells(i + 2, 1) = oFile.Name
                ws.Cells(i + 2, 2) = oFile.Type
                ws.Cells(i + 2, 3) = oFile.DateCreated
                ws.Cells(i + 2, 4) = oFile.DateLastModified
                ws.Cells(i + 2, 5) = oFile.DateLastAccessed
                ws.Cells(i + 2, 6) = oFolder.Path
                i = i + 1
            
        Next oFile

        'add any subfolders to the collection for processing
        For Each sf In oFolder.SubFolders
            If Not SkipFolder(sf.Name) Then colFolders.Add sf 'Skips folders listed within the referenced function
        Next sf
           
    Loop

    Application.ScreenUpdating = True
    
End Sub

内容的提问来源于stack exchange，提问作者Sange7