• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Macro For Inserting Pictures w/Loop

brettdemon

New Member
Hi all,

I was turned on to you through a friend at work. I am hoping you can help.

I am new to VBA and am having a lot of fun learning but I cannot figure this out.

What I am trying to do is really simple. I have a picture name starting in A1 (these include a .jpg at the end) and continue down thru A11. These names are identical to what is in the C: Drive folder "PICTURES". I want the picture to appear in C1 and continue down.

I have a macro that I believe is very close to working but I am getting a Run-time error '1004' on the line that reads n.Name = picname & ".jpg". I am seeing this as I use F8 to go thru the code. Any help that you can give would be greatly appreciated. Here is the code.

Code:
Sub Picture()

Dim picname As String
Dim pasteAt As Integer
Dim lThisRow As Long
Dim n

'Application.ScreenUpdating = False
lThisRow = 1

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

    picname = Cells(lThisRow, 1) 'This is the picture name
    Cells(lThisRow, 3).Select 'This is where picture will be inserted
   
    Set n = ActiveSheet.Pictures.Insert("C:\Users\bcurran\Desktop\PICTURES" & picname & ".jpg") 'Path to where pictures are stored
    n.Name = picname & ".jpg"
    ActiveSheet.Shapes(picname & ".jpg").Select
   
    With Selection
        '.Left = Range("C1").Left
        '.Top = Range("C1").Top
        '.Left = Cells(pasteAt, 1).Left
        '.Top = Cells(pasteAt, 1).Top
       
        .ShapeRange.LockAspectRatio = msoFalse
        .ShapeRange.Height = 100#
        .ShapeRange.Width = 80#
        .ShapeRange.Rotation = 0#
    End With
   
    lThisRow = lThisRow + 1

Loop

Range("A11").Select
Application.ScreenUpdating = True

MsgBox "The dishes are done dude!"

Exit Sub

ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
Exit Sub

End Sub
 
you said:"these include a .jpg at the end"
so you don't need to add the .jpg again, so remove & ".jpg" everywhere in the code it occurs.

Also you're missing a backslash in:
Set n = ActiveSheet.Pictures.Insert("C:\Users\bcurran\Desktop\PICTURES" & picname & ".jpg")

which when you make other changes too, becomes:
Set n = ActiveSheet.Pictures.Insert("C:\Users\bcurran\Desktop\PICTURES\" & picname)
 
you said:"these include a .jpg at the end"
so you don't need to add the .jpg again, so remove & ".jpg" everywhere in the code it occurs.

Also you're missing a backslash in:
Set n = ActiveSheet.Pictures.Insert("C:\Users\bcurran\Desktop\PICTURES" & picname & ".jpg")

which when you make other changes too, becomes:
Set n = ActiveSheet.Pictures.Insert("C:\Users\bcurran\Desktop\PICTURES\" & picname)

Thank you p45cal! I will make these changes tomorrow at work and let you know the results.
 
Hi, I just made those changes and am still getting the runtime error. I removed the "& .jpg" from 3 spots and added the backslash. The one that looked weird to me after the change was ActiveSheet.Shapes(picname).Select but .jpg is gone.
 
If you run this code multiple times without deleting the sapes/pictures that the previous run created you will get errors when the code tries to give the same name as an existing shape/picture. Post your code as you have it now.
 
Here it is after the changes.


Code:
Sub Picture()

Dim picname As String
Dim pasteAt As Integer
Dim lThisRow As Long
Dim n

'Application.ScreenUpdating = False
lThisRow = 1

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

    picname = Cells(lThisRow, 1) 'This is the picture name
    Cells(lThisRow, 3).Select 'This is where picture will be inserted
   
    Set n = ActiveSheet.Pictures.Insert("C:\Users\bcurran\Desktop\PICTURES\" & picname) 'Path to where pictures are stored
    n.Name = picname
    ActiveSheet.Shapes(picname).Select
   
    With Selection
        '.Left = Range("C1").Left
        '.Top = Range("C1").Top
        '.Left = Cells(pasteAt, 1).Left
        '.Top = Cells(pasteAt, 1).Top
       
        .ShapeRange.LockAspectRatio = msoFalse
        .ShapeRange.Height = 100#
        .ShapeRange.Width = 80#
        .ShapeRange.Rotation = 0#
    End With
   
    lThisRow = lThisRow + 1

Loop

Range("A11").Select
Application.ScreenUpdating = True

MsgBox "The dishes are done dude!"

Exit Sub

ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
Exit Sub

End Sub
 
If you mean deleted pics from C1 and so forth where it would start on the excel page the code hasn't delivered 1 pic yet so there are none there. It errors out on the first one every time.
 
If you mean deleted pics from C1 and so forth where it would start on the excel page the code hasn't delivered 1 pic yet so there are none there. It errors out on the first one every time.
If it errors out at
n.name = picname
as you say it does, that is the line after it has placed a picture on the sheet. The picture hasn't been repositioned yet so it may not be where you think it should be. If you do an F5, then Special, then Objects it should select all a jets on the sheet.
I'm sorry I'm not hands on at a machine right now.
As soon as I do get in front of a machine I will run your code.
 
@brettdemon

Try this...

Code:
Sub Picture1()
Dim lThisRow As Long, n As String, anyShape As Shape

Application.ScreenUpdating = False
lThisRow = 1

With ActiveSheet
'-------------------------------------------------------------
'to delte any old shapes
'For Each anyShape In .Shapes
'  If Left(anyShape.Name, Len("Picture")) = "Picture" _
        Then anyShape.Delete
'Next
'-------------------------------------------------------------

    Do While .Cells(lThisRow, 1) <> ""
        n = "C:\Users\bcurran\Desktop\PICTURES\" & .Cells(lThisRow, 1)
        If Not Len(Dir(n)) > 0 Then GoTo L9
       
        With .Pictures.Insert(n)
            With .ShapeRange
            .LockAspectRatio = msoFalse
            .Height = 100
            .Width = 80
            .Rotation = 0
            End With
        End With
       
L9:  lThisRow = lThisRow + 1

    Loop

.Range("A11").Select
End With
Application.ScreenUpdating = True

MsgBox "The dishes are done dude!"
End Sub
 
Hi Deepak. That worked right thru all the pictures! They only problem was that it put them where it wanted and right on top of each other. I need then to paste into C1 and continue down thru C11.
 

Hi,

just add & set each picture properties Left and Top
according to their destination cell (same properties !) …
 
Hi Marc. I have seen what you are talking about and know the logic of what you mean but I have no idea how to write that in the code. I am still VBA challenged:(. Can you help on what to write so I can learn? Thank you for your help!
 
Check it!!
Code:
Sub Picture1()
Dim lThisRow As Long, n As String, anyShape As Shape, l As Integer, t As Integer

Application.ScreenUpdating = False
lThisRow = 1

With ActiveSheet
'-------------------------------------------------------------
'to delte any old shapes
'For Each anyShape In .Shapes
'  If Left(anyShape.Name, Len("Picture")) = "Picture" _
        Then anyShape.Delete
'Next
'-------------------------------------------------------------

    Do While .Cells(lThisRow, 1) <> ""
    l = .Left
    t = .Top
        n = "C:\Users\bcurran\Desktop\PICTURES\" & .Cells(lThisRow, 1)
        If Not Len(Dir(n)) > 0 Then GoTo L9
     
        With .Pictures.Insert(n)
       
            With .ShapeRange
            .LockAspectRatio = msoFalse
            .Height = 100
            .Width = 80
            .Rotation = 0
            End With
           
        .Left = l
        .Top = t
        .Placement = 1
       
        End With
     
L9:  lThisRow = lThisRow + 1

    Loop

.Range("A11").Select
End With
Application.ScreenUpdating = True

MsgBox "The dishes are done dude!"
End Sub
 
Hi Deepak. I added your new lines and I get an error that says, run time error 438 "object doesn't support this property or method." It looks to be happening when it gets to t = .Top
 
Last edited:
Maybe by amending Deepak's code like this :​
Code:
Sub Picture1()
Dim lThisRow As Long, n As String, anyShape As Shape, l As Single, t As Single
Application.ScreenUpdating = False
                  lThisRow = 1
With ActiveSheet
    Do While .Cells(lThisRow, 1).Value > ""
        With .Cells(lThisRow, 1)
            l = .Left
            t = .Top
            n = "C:\Users\bcurran\Desktop\PICTURES\" & .Text
        End With
 
        If Dir(n) > "" Then
            With .Pictures.Insert(n)
                With .ShapeRange
                     .LockAspectRatio = msoFalse
                              .Height = 100
                               .Width = 80
                            .Rotation = 0
                End With
                      .Top = t
                     .Left = l
                .Placement = 1
            End With
        End If
 
        lThisRow = lThisRow + 1
    Loop

    .Range("A11").Select
End With

Application.ScreenUpdating = True
MsgBox "The dishes are done dude!"
End Sub
 
Hi all! I had a follow up question to this code (which has been working brilliantly thanks to you all.) If I want the images to be put in sheet 2 in the file in column A1 how would I change the code Deepak gave to me which was l = .offset(, 2).left The code will run in Sheet 1. Thank you to anyone that can help.
 
When I run this macro, it gives an error on 8th loop. Error reflects in insert sentence or code. Why error on 8th loop only?
 
Thanks for reply.......but that pic is there and pic name is correct also not duplicate......I tried with some different name but its showing same error. Any other reason? Error is: Run time error 1004, Application defined or object defined error
 
Back
Top