Embedding Linked Pictures in Excel with Visual Basic

Question

How would I modify the following code to embed linked pictures from my local temp folder into each cell within the actual excel file?

visual basic complete source code

'####### 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

I'm not totally sure what you are doing, but if you want to insert images in a folder into Excel, you can try the code below.

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