Question

我有一个代码可以读取文件夹内容（只有其他文件夹），并在一定范围内将它们列入excel 问题是代码读取内容的路径（/ CtrExtrase）在代码中给出。

我需要用户选择的路径。完全失败了。

我的代码：

Sub distribuire_foldere()
Dim objFSO As Object
Dim objFolder As Object
Dim objSubFolder As Object
Dim i As Integer


'CLEARS ALL PREVIOUS CONTENT
   Sheets("DISTRIBUIRE foldere").Range("A2:A2000").ClearContents

'INSERTS IN CELL THE PATH WHERE THE SCRIPT IS READING
Sheets("DISTRIBUIRE foldere").Range("$E$1").Value = ThisWorkbook.path & "\CtrExtrase"

' LISTS THE CONTENT OF THE CHOOSEN FOLDER
Application.StatusBar = ""
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
On Error GoTo nuexistafolderul

'这是问题，因为我需要用户选择路径：

Set objFolder = objFSO.GetFolder(Application.ThisWorkbook.path & "\CtrExtrase")

i = 1
'loops through each folder in the directory and prints their names   
On Error GoTo handleCancel
Application.EnableCancelKey = xlErrorHandler
For Each objSubFolder In objFolder.subfolders

Application.StatusBar = objSubFolder.path & " " & objSubFolder.Name
    'OUTPUTS THE FOLDERS NAME
    Cells(i + 1, 1) = objSubFolder.Name
    i = i + 1
Next objSubFolder
handleCancel:
If Err = 18 Then
 MsgBox "Ai anulat procesul inainte de finalizare! Reia procedura!"
nuexistafolderul:
 MsgBox "Nu exista folderul pentru extractia contractelor! Extrage intai contractele!"


End If
'CALLS A MODULE THAT INSERTS CERTAIN TEXT INTO A BATCH FILE
 Call Module1.batchfile2

End Sub

Answer 1

将FileDialog与FolderPicker一起使用，此处包含在函数中：

Function GetFolder(Optional strPath As String = "C:\") As String
    Dim fldr As FileDialog
    Dim sItem As String
    GetFolder = vbNullString
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function

您的代码，您可以在GetFolder(ThisWorkbook.Path & "\")中设置默认路径：

Sub distribuire_foldere()
Dim objFSO As Object
Dim objFolder As Object
Dim objSubFolder As Object
Dim i As Integer
    'CLEARS ALL PREVIOUS CONTENT
    Sheets("DISTRIBUIRE foldere").Range("A2:A2000").ClearContents

    'INSERTS IN CELL THE PATH WHERE THE SCRIPT IS READING
    Sheets("DISTRIBUIRE foldere").Range("$E$1").Value = ThisWorkbook.Path & "\CtrExtrase"

    ' LISTS THE CONTENT OF THE CHOOSEN FOLDER
    Application.StatusBar = ""
    'Create an instance of the FileSystemObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    'Get the folder object
    On Error GoTo nuexistafolderul
    'THIS IS THE PROBLEM, AS I NEED THE USER TO CHOOSE THE PATH:

    Set objFolder = objFSO.GetFolder(GetFolder(ThisWorkbook.Path & "\"))

    i = 1
    'loops through each folder in the directory and prints their names
    On Error GoTo handleCancel
    Application.EnableCancelKey = xlErrorHandler
    For Each objSubFolder In objFolder.SubFolders
        Application.StatusBar = objSubFolder.Path & " " & objSubFolder.Name
        'OUTPUTS THE FOLDERS NAME
        Cells(i + 1, 1) = objSubFolder.Name
        i = i + 1
    Next objSubFolder

handleCancel:
If Err = 18 Then
    MsgBox "Ai anulat procesul inainte de finalizare! Reia procedura!"
nuexistafolderul:
    MsgBox "Nu exista folderul pentru extractia contractelor! Extrage intai contractele!"
End If
'CALLS A MODULE THAT INSERTS CERTAIN TEXT INTO A BATCH FILE
Call Module1.batchfile2

End Sub

查询用户选择路径

1 个答案: