Inserting Image into cell with VBA

[overKBV]

So I am using this to add pictures to my file. I am essentially creating an asset list and want to put the picture with the asset on that line. It essentially then creates a link to open the photo in its original size. The problem is it works sometimes. I suspect it might have to do with the size/resolution of the photo. Can I force Excel to accept larger photos or, using VBA, compress the photo? I have tried bulk compressing my photos but it has not been easy.

Sub AddPictureNotInsert()
    Dim strFileName As String
    Dim objPic As Shape
    Dim rngDest As Range
    strFileName = Application.GetOpenFilename( _
        FileFilter:="Images (*.jpg;*.gif;*.png),*.jpg;*.gif;*.png", _
        Title:="Please select an image...")
    If strFileName = "False" Then Exit Sub
    Set rngDest = ActiveCell
    Set objPic = ActiveSheet.Shapes.AddPicture(strFileName, False, True, 10, 10, -1, -1)
    With objPic
        .LockAspectRatio = msoFalse
        .Left = rngDest.Left + 1
        .Top = rngDest.Top + 1
        .Width = rngDest.Width - 2
        .Height = rngDest.Height - 2
    End With
    ActiveSheet.Hyperlinks.Add Anchor:=objPic, Address:=strFileName
End Sub

 

[Zot]

Maybe you can make this part of your code.

Compress all images in Excel workbook via VBA

I need help to compress all images in Excel workbook via VB (email format 96 ppi). I tried sendkeys but seems it doesn't work. Sub test() Dim wsh As Worksheet Set wsh = Worksheets("Sheet1"...

stackoverflow.com