Встраивание связанных изображений в Excel с помощью Visual Basic

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