excel - 使用 Visual Basic 在 Excel 中嵌入链接图片

Question

如何修改以下代码以将本地临时文件夹中的链接图片嵌入到实际 excel 文件中的每个单元格中？

Visual Basic 完整源代码

'####### Add pictures to excel structure ################
For i = 2 To lngLastRow

    Dim strFileName As String
    strFileName = strPicFilesPath & objWorksheet.Cells(i, colID).Value & ".jpg"

    If File.Exists(strFileName) Then

        With objWorksheet.Pictures.Insert(strFileName)
            With .ShapeRange
                .LockAspectRatio = msoTrue
                If .Width >= .Height Then
                    .Width = objWorksheet.Cells(i, colImage).Width - 6
                Else
                    .Height = objWorksheet.Cells(i, colImage).Width - 6
                End If
                objWorksheet.Cells(i, colImage).EntireRow.RowHeight = .Height + 6
            End With

            .Left = objWorksheet.Cells(i, colImage).Left + 3 + intIndent * objWorksheet.Cells(i, colID).IndentLevel
            .Top = objWorksheet.Cells(i, colImage).Top + 3
            .Placement = 1                       'Move and Size
            .PrintObject = True
        End With

    End If
Next i
'####### End Add pictures to excel structure ################

Answer 1

我不完全确定你在做什么，但如果你想将文件夹中的图像插入 Excel，你可以试试下面的代码。

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

' Note: you need the file extension, such as ',jpg', or whatever you are using, so you can match on that.
Sub Insert()

    Dim strFolder As String
    Dim strFileName As String
    Dim objPic As Picture
    Dim rngCell As Range

    strFolder = "C:\Users\Public\Pictures\Sample Pictures\" 'change the path accordingly
    If Right(strFolder, 1) <> "\" Then
        strFolder = strFolder & "\"
    End If

    Set rngCell = Range("E1") 'starting cell

    strFileName = Dir(strFolder & "*.jpg", vbNormal) 'filter for .png files

    Do While Len(strFileName) > 0
        Set objPic = ActiveSheet.Pictures.Insert(strFolder & strFileName)
        With objPic
            .Left = rngCell.Left
            .Top = rngCell.Top
            .Height = rngCell.RowHeight
            .Placement = xlMoveAndSize
        End With
        Set rngCell = rngCell.Offset(1, 0)
        strFileName = Dir
    Loop

End Sub