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

注意：您需要文件扩展名，例如＆＃39;，jpg＆＃39;或您正在使用的任何内容，因此您可以匹配。

从本地文件夹将特定图片导入Excel

1 个答案: