使用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 

在上面的代碼中，在代碼中手動設置文件夾路徑。

FOLDERPATH = 「C：\用戶\ sandeep.hc \照片管理」

相反，我希望它由用戶像下面的代碼的一部分，

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