vba excel: PasteSpecial for JPEG not working

Question

I have code that has been working, and all of the sudden it is not. I have tried everything and cannot figure out why. It works when I do a step by step (F8) but not when I run the code. What the code is doing is finding an ID in column B, and finding the jpg that has the same image (in the file H:\Images...) and pasting it into the 1st column. The code produces the error "Run-time error 1004: PasteSpecial method of worksheet class failed" and highlights the ActiveSheet.PasteSpecial line. Please help!

Sub Picture()
 Dim picname As String

Dim lThisRow As Long

lThisRow = 3

Do While (Cells(lThisRow, 2) <> "")

    Cells(lThisRow, 1).Select 'This is where picture will be inserted


     picname = Cells(lThisRow, 2) 'This is the picture name
    'MsgBox (picname)

    Dim DirFile As String
    DirFile = "H:\Images\9 Thumbnails\" & picname & ".jpg"
    If Len(Dir(DirFile)) = 0 Then
      'MsgBox "File does not exist"

    Else
        ActiveSheet.Pictures.Insert("H:\Images\9 Thumbnails\" & picname & ".jpg").Select
        Selection.Cut

    ActiveSheet.PasteSpecial Format:="Picture (JPEG)", Link:=False, _
        DisplayAsIcon:=False

     'Set WB = Workbooks.Open(DirFile)
             With Selection
                .ShapeRange.ScaleHeight 0.9, msoTrue
                .Left = Cells(lThisRow, 1).Left + Cells(lThisRow, 1).Width / 2 - Selection.ShapeRange.Width / 2
                .Top = Cells(lThisRow, 1).Top + Cells(lThisRow, 1).Height / 2 - Selection.ShapeRange.Height / 2

                '.ShapeRange.LockAspectRatio = msoFalse

                ''.ShapeRange.Width = 80#
                .ShapeRange.Rotation = 0#
            End With
    End If

lThisRow = lThisRow + 1
Loop

Range("B3").Select
On Error GoTo 0
Application.ScreenUpdating = True

Exit Sub

End Sub

I'm going to guess some of your issue will be your use of `.Select`. It's best practice to [Avoid Using `.Select`](http://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba-macros). When stepping through it, it's a line by line process, so VBA is less likely to confuse worksheets/selections. When running as a macro, as fast as it can, this can likely cause issues. — BruceWayne, Feb 15 '16 at 21:04
ilm gessing (jpeg) is not available as pasting, and anyway this is what I am using ; `ActiveSheet.PasteSpecial Format:="Picture (Enhanced Metafile)"` — Patrick Lepelletier, Feb 15 '16 at 21:35
on further advice, if you want to avoid using select after the pastespecial, you can use this : `Set Pic = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)` , (pic is declared as shape) — Patrick Lepelletier, Feb 15 '16 at 21:37
Thank you both for your help, the metafile option did not work. Since I am not that experienced at writing code, I am not sure how to try the other two (not using .select or setting the pic as a shape). I am going to start trying now. But if will probably take me hours so if you have any hints on how to go about it, they would be greatly appreciated! — spaindc, Feb 16 '16 at 21:37

score 0 · Accepted Answer · answered Feb 18 '16 at 18:51

I figured out the answer using .addpicture. This changes the way you have to look at dimensions, but I figured that out too. Final code:

Sub Picture()
 Dim picname As String
 Dim PicPath As String
 Dim lThisRow As Long
 Dim Pic As Shape
 Dim rngPic As Range


lThisRow = 3

Do While (Cells(lThisRow, 2) <> "")

    Set rngPic = Cells(lThisRow, 1) 'This is where picture will be inserted

    picname = Cells(lThisRow, 2) 'This is the picture name

    present = Dir("H:\Images\8 Thumbnails\" & picname & ".jpg")
    PicPath = ("H:\Images\8 Thumbnails\" & picname & ".jpg")

    If present <> "" Then

      Set Pic = ActiveSheet.Shapes.AddPicture(PicPath, msoFalse, msoCTrue, 1, 1, -1, -1)

      With Pic
        .LockAspectRatio = msoTrue
        If .Height < 45 Then .Height = 115
        If .Width > 150 Then .Width = 150
        .Left = rngPic.Left + rngPic.Width / 2 - Pic.Width / 2
        .Top = rngPic.Top + rngPic.Height / 2 - Pic.Height / 2
      End With

    Else

    Cells(lThisRow, 1) = ""

    End If

lThisRow = lThisRow + 1
Loop

Range("B3").Select
On Error GoTo 0
Application.ScreenUpdating = True

Exit Sub

End Sub

vba excel: PasteSpecial for JPEG not working

1 Answers1