使用 msoFileDialogFolderPicker 选择文件夹

Question

要复制图片/图像，需要编写代码，要复制图像，我必须设置文件夹路径，现在我正在手动设置文件夹路径，因为该代码将被许多用户使用，我想给出一个用户选择文件夹的选项。

Application.FileDialog(msoFileDialogFolderPicker) Vba有这个方法来设置文件夹路径，如果有错误请纠正我。

现在我必须实现上面的方法来按用户为下面的代码选择文件夹。

    Private Sub CommandButton1_Click()

Dim rgTarget As Range
Dim RowI As Long, ColumnI As Long

    Folderpath = "C:\Users\sandeep.hc\Pics"
    Set fso = CreateObject("Scripting.FileSystemObject")
    NoOfFiles = fso.GetFolder(Folderpath).Files.Count
    Set listfiles = fso.GetFolder(Folderpath).Files
    For Each fls In listfiles
       strCompFilePath = Folderpath & "\" & Trim(fls.Name)
        If strCompFilePath <> "" Then
            If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
            Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
            Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then
    RowI = 29
    ColumnI = ColumnI + 1
    Set rgTarget = Cells(RowI, ColumnI)
    Application.ActiveSheet.Shapes.Addpicture strCompFilePath, False, True, rgTarget.Left, rgTarget.Top, 875, 400
    ColumnI = ColumnI + 17
    End If

End If
Next

End Sub

在上面的代码中，我在代码中手动设置文件夹路径。

文件夹路径 = "C:\Users\sandeep.hc\Pics"

相反，我希望用户像下面的部分代码一样，

Application.FileDialog(msoFileDialogFolderPicker)

以上代码实现 msoFileDialogFolderPicker 需要帮助。

Answer 1

请在您的例程中加入以下代码，它将使您能够做您想做的事情。

    Dim myPath As String
    Dim myFile As String
    Dim myExtension As String
    Dim FldrPicker As FileDialog
    Dim myPath As String
    Dim wb1 As Workbook
    Dim sht As Worksheet
    'Optimize Macro Speed
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    'Retrieve Target Folder Path From User
    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
    .Title = "Select A Target Folder"
    .AllowMultiSelect = False
    If .Show <> -1 Then GoTo NextCode
    myPath = .SelectedItems(1) & "\"
    End With

    'In Case of Cancel
NextCode:
    myPath = myPath
    If myPath = "" Then GoTo ResetSettings

    'Target File Extension (must include wildcard "*")
    myExtension = "*.xls" 'change extension as per your requirement

    'Target Path with Ending Extension
    myFile = Dir(myPath & myExtension)
    'Loop through each Excel file in folder
    Do While myFile <> ""
    'Set variable equal to opened workbook
    Set wb1 = Workbooks.Open(Filename:=myPath & myFile)
    Set sht = wb1.Worksheets("Your_Sheet")

    '.....do something here......

    'Save and Close Workbook
     wb1.Close SaveChanges:=True

    'Get next file name
     myFile = Dir
    Loop



ResetSettings:
    'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    'Message Box when tasks are completed
    MsgBox "Job done!"

编辑
我已经修改了程序。我已经包含了一个包含 Application.FileDialog 方法的函数，它为用户提供了一个选择文件夹的选项。这个程序对我有用。值得一提的是，我通常使用包含在 VBE 中的 Option Explicit，它总是要求明确提及所有变量。请根据您的要求调整图片参数。

 Sub Picinsert()

    Dim mainWorkBook As Workbook

    Set mainWorkBook = ActiveWorkbook
    Sheets("Sheet1").Activate
    Folderpath = GetFolder()
    'Folderpath = "C:\Excelvba_exp" 'change as per your requirement
    Set fso = CreateObject("Scripting.FileSystemObject")
    NoOfFiles = fso.GetFolder(Folderpath).Files.Count
    Set listfiles = fso.GetFolder(Folderpath).Files
    For Each fls In listfiles
       strCompFilePath = Folderpath & "\" & Trim(fls.Name)
        If strCompFilePath <> "" Then
            If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
            Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
            Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then
                 counter = counter + 1
                  Sheets("Sheet1").Range("A" & counter).Value = fls.Name
                  Sheets("Sheet1").Range("B" & counter).ColumnWidth = 25
                Sheets("Sheet1").Range("B" & counter).RowHeight = 100
                Sheets("Sheet1").Range("B" & counter).Activate
                Call insert(strCompFilePath, counter)
                Sheets("Sheet1").Activate
            End If
        End If
    Next
    mainWorkBook.Save
End Sub

Function insert(PicPath, counter)
'MsgBox PicPath
    With ActiveSheet.Pictures.insert(PicPath)
        With .ShapeRange
            .LockAspectRatio = msoTrue
            .Width = 50
            .Height = 70
        End With
        .Left = ActiveSheet.Range("B" & counter).Left
        .Top = ActiveSheet.Range("B" & counter).Top
        .Placement = 1
        .PrintObject = True
    End With
End Function
Function GetFolder() As String
    Dim dlg                   As FileDialog
    Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
    If dlg.Show = -1 Then
        GetFolder = dlg.SelectedItems(1)
    End If
End Function