使用msoFileDialogFolderPicker选择文件夹

Question

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

Application.FileDialog（msoFileDialogFolderPicker） Vba有这个方法来设置文件夹路径，如果我错了就纠正我。

现在我必须实现上述方法，以便用户为下面的代码选择文件夹。

myService.init()

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

Folderpath =＆＃34; C：\ Users \ sandeep.hc \ Pics＆＃34;

相反，我希望用户喜欢下面的部分代码，

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