从本地文件夹导入特定图片到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”，或任何你正在使用，所以你可以匹配上。