Can Someone Tell Me If This Should Work Please

[rockyw]

I found this insert macro but I cannot get it to work.

Sub InsertPictures()

Dim row As Long

Dim picPath As String

Dim Picture As Object



row = 1



On Error Resume Next



While Cells(row, 1) <> ""

  Cells(row, 3).Select

  

  ' just guess what type of picture it is: .jpg or .gif

  picPath = Cells(row, 2) & Cells(row, 1) & ".gif"

  ActiveSheet.Pictures.Insert(picPath).Select

  picPath = Cells(row, 2) & Cells(row, 1) & ".jpg"

  ActiveSheet.Pictures.Insert(picPath).Select

  

  Set Picture = Selection

  'set cell height to picture size

  Picture.Top = Picture.TopLeftCell.Top

  Picture.Left = Picture.TopLeftCell.Left

  Picture.TopLeftCell.EntireRow.RowHeight = Picture.Height

   row = row + 1

Wend

End Sub

The instructions said...
Column A = imagename (AL-100Y)
Column B = imagepath (c:vonnieimages)
Column C = place to insert image
Image extension can be jpg or gif

I put in column A 01
In column B C:Pictures
I can not get this to work. Can someone tell me what might be wrong? Do I need more in A and B. Thanks

 

[tweedle]

Give me a minute

 

[tweedle]

This would be my version:
Goes in a Module and loads the active sheet

Sub KillShapes at the bottom will wipe out the active sheet [careful with that one]

Dim shp As Shape

Sub LoadPics()
   On Error GoTo LoadPics_Error

    rootpath = "C:\Users\Public\Pictures\Sample Pictures\Deeper\"
    nextrow = 1

    For i = 1 To 2

        If i = 1 Then picfile = Dir(rootpath & "*.jpg")
        If i = 2 Then picfile = Dir(rootpath & "*.gif")
        
        With ActiveSheet
        Do While picfile <> ""
            .Cells(nextrow, 3).Select
            Set shp = .Shapes.AddPicture(rootpath & picfile, msoFalse, msoCTrue, .Cells(nextrow, 3).Left, .Cells(nextrow, 3).Top, 150, 150)
            Selection.RowHeight = shp.Height
            .Cells(nextrow, 2) = picfile

            nextrow = nextrow + 2 'Controls the rows between pictures
            picfile = Dir()
        Loop
        End With
    Next

   On Error GoTo 0
   Exit Sub

LoadPics_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure LoadPics " & vbLf & picfile
    Err = 0
End Sub

Sub KillShapes()
    With ActiveSheet
        If .Shapes.Count > 0 Then
            .Shapes.SelectAll
            Selection.Delete
        End If
        .Cells.Clear
    End With
End Sub

 

[tweedle]

Yes, in your current version, that would be:

row = row + 2

 

[rockyw]

I got that to work. I can then move this over and make a next row like the other code? Can the File name go under the picture ? That would be sweet. Thanks so much for the code. Let me know if the name can be moved, if not I can work with this just fine. About time for bed, 11pm here. Thanks

 

[rockyw]

Can't wait till tomorrow, if I get time I can start this new project thanks to you. Have a great Friday and a great weekend.

 

[tweedle]

I can then move this over and make a next row like the other code?

I'm not sure what you mean by 'move this over and make a next row'.

Can the File name go under the picture ?

yep
Change

 .Cells(nextrow, 2) = picfile

to

.Cells(nextrow [B]+1, 3[/B]) = picfile

also, the 2 indicated below can be made 3, 4 to allow more rows-between to buffer, if you like.
nextrow = nextrow + 2 'Controls the rows between pictures

 

[rockyw]

Thank you for the help. (I'm not sure what you mean by 'move this over and make a next row'.) Sorry that was unclear. I can change the column numbers and the code will make a row beside the first, I tried it and it worked fine. I will end up making 3 or maybe 4 rows of pictures. I will just seperate the pictures into a couple folders and run the code 3 or 4 times. Would there be a simple way to have the code load say 100 pictures and make 3 or 4 rows by itself? This its great thanks

 

[tweedle]

Would there be a simple way to have the code load say 100 pictures and make 3 or 4 rows by itself? This its great thanks

One would need to set the columns as a variable and then control that increment.
I think I got all the pertinent parts colored blue to do something like that.

Dim shp As Shape

Sub LoadPics()
   On Error GoTo LoadPics_Error

    rootpath = "C:\Users\Public\Pictures\Sample Pictures\"
[COLOR="Blue"]    toprow = 5
    nextrow = toprow
    mycol = 3
    colshift = 3[/COLOR]
    
    For i = 1 To 2

        If i = 1 Then picfile = Dir(rootpath & "*.jpg")
        If i = 2 Then picfile = Dir(rootpath & "*.gif")
        
        With ActiveSheet
        Do While picfile <> ""
            .Cells(nextrow, [COLOR="Blue"]mycol[/COLOR]).Select
            Set shp = .Shapes.AddPicture(rootpath & picfile, msoFalse, msoCTrue, .Cells(nextrow, [COLOR="blue"]mycol[/COLOR]).Left, .Cells(nextrow, [COLOR="blue"]mycol[/COLOR]).Top, 150, 150)
            Selection.RowHeight = shp.Height
            Selection.ColumnWidth = 30
            .Cells(nextrow + 1, [COLOR="blue"]mycol[/COLOR]) = picfile
            DoEvents

            nextrow = nextrow + 2
[COLOR="blue"]            If nextrow > 20 Then
                nextrow = toprow 'Reset the Row to toprow
                mycol = mycol + colshift 'shift over x number of columns
            End If[/COLOR]
            
            picfile = Dir()
        Loop
        End With
    Next

   On Error GoTo 0
   Exit Sub

LoadPics_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure LoadPics " & vbLf & picfile
    Err = 0
End Sub

simple

See my sig.

 

[rockyw]

tweedle I just seen the newest code. This works great but I have a couple questions. This puts 8 images in the first column then starts the next column. I'm not sure how I adjust that. Thinking about this if I want the pictures in alphabetical order it would be best to put 5 on the top row, then drop down and insert the next 5 and so on until I run out of images in that directory. can this be set to do that? I will keep playing with it. Thanks again for your help.

 

[rockyw]

I got the code to fill the row but it will not stop at 5 and go the the next row.I changed this to insert acrostthe top..

[COLOR=#0000ff]If nextrow > 20 Then ( I changed to)   If nextrow > 5 Then
[/COLOR]

But it will not start the next row after 5 images. any idea here, am I close. Thanks