從本地文件夾導入特定圖片到Excel中

Question

我完全是VBA的新手，我在工作中挑戰自己的方式。

我正在尋找一個簡單的代碼，將特定圖片從文件夾導入到工作表中。我真的很困擾編碼語言，很多東西都在我的頭上。

我基本上希望宏查看列A中的所有引用，並將關聯的圖片返回到驅動器上的文件夾中的相鄰列。列A中的引用將是文件名，沒有擴展名。

Option Explicit 

Sub AddOlEObject() 

    Dim mainWorkBook As Workbook 
    Dim Folderpath As String 
    Dim fso, NoOfFiles, listfiles, fls, strCompFilePath 
    Dim counter 


    Dim shp As Shape 
    For Each shp In ActiveSheet.Shapes 
    If shp.Type = msoPicture Then shp.Delete 
    Next shp 

    Set mainWorkBook = ActiveWorkbook 
    Sheets("Sheet1").Activate 
    Folderpath = "C:\Users\grahamb\Desktop\TEST" 
    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 

End Sub 

Function insert(PicPath, counter) 

    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 

時遇到的挑戰是：

- 這個宏觀的進口都來自於這個文件夾的圖片。我只想要列A中引用的特定圖片。 - 此宏刪除所有圖片，但我想保留按鈕。

任何幫助，將不勝感激。

乾杯 摹

Answer 1

考慮這一點。

Sub InsertPics() 
Dim fPath As String, fName As String 
Dim r As Range, rng As Range 

Application.ScreenUpdating = False 
fPath = "C:\Users\Public\Pictures\Sample Pictures\" 
Set rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row) 
i = 1 

For Each r In rng 
    fName = Dir(fPath) 
    Do While fName <> "" 
     If fName = r.Value Then 
      With ActiveSheet.Pictures.Insert(fPath & fName) 
       .ShapeRange.LockAspectRatio = msoTrue 
       Set px = .ShapeRange 
       If .ShapeRange.Width > Rows(i).Columns(2).Width Then .ShapeRange.Width = Columns(2).Width 
        With Cells(i, 2) 
         px.Top = .Top 
         px.Left = .Left 
         .RowHeight = px.Height 
        End With 
      End With 
     End If 
     fName = Dir 
    Loop 
    i = i + 1 
Next r 
Application.ScreenUpdating = True 
End Sub 

注意：您需要的文件擴展名，例如「 JPG」，或任何你正在使用，所以你可以匹配上。