2002/2010 Compatible Image link to embed vba

DasWolf60652

New Member
Joined
Jul 15, 2015
Messages
9
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?

Code:
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
 
Last edited by a moderator:

Some videos you may like

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!

RoryA

MrExcel MVP, Moderator
Joined
May 2, 2008
Messages
34,964
Office Version
365, 2019, 2016, 2010
Platform
Windows, MacOS
Hi, and welcome to the forum.

Try this replacement function:

Code:
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

New Member
Joined
Jul 15, 2015
Messages
9
Hi, and welcome to the forum.

Try this replacement function:

Code:
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

MrExcel MVP, Moderator
Joined
May 2, 2008
Messages
34,964
Office Version
365, 2019, 2016, 2010
Platform
Windows, MacOS
Glad to help! :)
 

Watch MrExcel Video

Forum statistics

Threads
1,098,869
Messages
5,465,182
Members
406,416
Latest member
banasiak_robert

This Week's Hot Topics

Top