2002/2010 Compatible Image link to embed vba

[DasWolf60652]

My VBA is currently adding a list of photos from a file chosen by the user but as others have had the problem it saves them as links instead of embedding them. Is there a way to choose all and convert them after they have been inserted?

Sub AddOlEObject()
    
    Dim mainWorkBook As Workbook
    Dim Path As String
    Dim pic as Picture
    
    
    
    Set mainWorkBook = ActiveWorkbook
    
  
    Sheets("Pictures").Activate
    
   
    Folderpath = Range("H1").Value
    
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    NoOfFiles = fso.GetFolder(Folderpath).Files.Count
    Set listfiles = fso.GetFolder(Folderpath).Files
    Application.ScreenUpdating = False
    
    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) _
             Then
                counter = counter + 1
                Sheets("Pictures").Range("A" & counter).Offset(1, 0).Value = counter
                Sheets("Pictures").Range("C" & counter).Offset(1, 0).Value = "Enter Comment Here"
                Sheets("Pictures").Range("C" & counter).Offset(1, 0).ColumnWidth = 80
                Sheets("Pictures").Range("B" & counter).Offset(1, 0).ColumnWidth = 40
                Sheets("Pictures").Range("B" & counter).Offset(1, 0).RowHeight = 220
                Sheets("Pictures").Range("B" & counter).Offset(1, 0).Activate
                Call insert(strCompFilePath, counter)
                Sheets("Pictures").Activate
            End If
        End If
    Next
    
            For Each pic In ActiveSheet.Pictures
            pic.Placement = xlMoveAndSize
Next
Application.ScreenUpdating = True


End Sub
 
Function insert(PicPath, counter)






    With ActiveSheet.Pictures.insert(PicPath)
       With .ShapeRange
           .LockAspectRatio = msoTrue
           
            .Width = 150
           .Height = 210
       End With
            .Left = ActiveSheet.Range("B" & counter).Offset(1, 0).Left
            .Top = ActiveSheet.Range("B" & counter).Offset(1, 0).Top
            .Placement = 1
            .PrintObject = True
    End With
 
End Function

 

[RoryA]

Hi, and welcome to the forum.

Try this replacement function:

Function insert(PicPath, counter)
    Dim shp                   As Shape
    With ActiveSheet
        Set shp = .Shapes.AddPicture(Filename:=PicPath, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
                                     Left:=Range("B" & counter).Offset(1, 0).Left, Top:=Range("B" & counter).Offset(1, 0).Top, _
                                     Width:=150, Height:=210)
    End With
    With shp
        .LockAspectRatio = msoTrue
        .Placement = 1
        .PrintObject = True
    End With

End Function

 

[DasWolf60652]

Hi, and welcome to the forum.

Try this replacement function:

Function insert(PicPath, counter)
    Dim shp                   As Shape
    With ActiveSheet
        Set shp = .Shapes.AddPicture(Filename:=PicPath, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
                                     Left:=Range("B" & counter).Offset(1, 0).Left, Top:=Range("B" & counter).Offset(1, 0).Top, _
                                     Width:=150, Height:=210)
    End With
    With shp
        .LockAspectRatio = msoTrue
        .Placement = 1
        .PrintObject = True
    End With

End Function

Great! This works perfectly. I saw the scripting in another post but didn't know how to integrate it.

After using this though, I was having Runtime 438, Object doesn't support this property or method on .PrintObject = True so I hid that line and it worked great, and printed as well. Couldn't be happier!


Thank you so much Rory!

 

[RoryA]

Glad to help!