vba code to show pictures in cells needed

[kelly mort]

Hello All,
I wanna find out if there is a way to use vba to pick pictures from a folder and place them in cells on a worksheet. By using IDs from cells to make lookups. That is say I have the dataset as:

Col A Col B
ID PIC
1001

So I will like the vba code use the ID 1001 to lookup the picture in the folder then show it under the PIC. The pictures will be named just as the IDs. If there is a better way of doing this let me know. Thanks
Kelly

 

[IanB76]

Hi,


This is a piece of code i used to use to manually insert an image into a worksheet and resize it to fit a certain set of cells.






Sub Macro5()
'
' Macro5 Macro
'
' Keyboard Shortcut: Ctrl+q
'
Dim myPicture As String
Dim pic As Object
Dim r As Range
'
' to insert an image
'



Range("B9:I26").Select

myPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif; *.png),*.gif; *.jpg; *.bmp; *.tif; *.png", , "Select Picture to Import")
If myPicture = "False" Then Exit Sub


If myPicture <> "" Then
Set r = Selection
Set pic = ActiveSheet.Shapes.AddPicture(myPicture, False, True, 12, 99, 387, 285)




If pic.Height <> 285 Then
With pic
.Top = r.Top
.Left = r.Left
.Height = 285
.Placement = xlMoveAndSize
End With
End If

If pic.Width <> 387 Then
With pic
.Top = r.Top
.Left = r.Left
.Width = 387
.Placement = xlMoveAndSize
End With
End If
End If


End Sub




If you worked on this code you could maybe expand it to automate it to select a specific image from the folder you want and place it where you want it.



Hope this is a bit of help for you

 

[kelly mort]

Oh okay thanks for sharing with me. Though I am not good at reading scripts yet, I will do my best to do that. But can you add comments to the script for me please? Thanks
Kelly

 

[IanB76]

Oh okay thanks for sharing with me. Though I am not good at reading scripts yet, I will do my best to do that. But can you add comments to the script for me please? Thanks
Kelly

I will do my best for you but I am not the best at this either..lol




Range("B9:I26").Select (selects the destination cells)



myPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif; *.png),*.gif; *.jpg; *.bmp; *.tif; *.png", , "Select Picture to Import") (opens pictures folder and lists compatible extensions)
If myPicture = "False" Then Exit Sub (cancels operation if nothing selected)





If myPicture <> "" Then
Set r = Selection
Set pic = ActiveSheet.Shapes.AddPicture(myPicture, False, True, 12, 99, 387, 285) (checks image size if one selected)




If pic.Height <> 285 Then
With pic
.Top = r.Top
.Left = r.Left
.Height = 285
.Placement = xlMoveAndSize
End With
End If

If pic.Width <> 387 Then
With pic
.Top = r.Top
.Left = r.Left
.Width = 387
.Placement = xlMoveAndSize
End With
End If
End If (this last part resizes if needed and positions the image)






I hope this is of help , sorry I haven't worked out how to do quotes properly on here yet .

 

[kelly mort]

I hope someone here has the capacity to get me the code I want. I am finding it hard to modify this one .
Kelly

 

[Stiuart_W]

Why don't you post the code you have to date - when creating your paste and you have pasted the code, select the code and then click the "#" button above to tag the code - makes it much easier to read.

What problems are you having? Any error messages?

 

[kelly mort]

This code is what I was given for my request. I wish I could modify it.

Sub Macro5()
Dim myPicture As String
Dim pic As Object
Dim r As Range

' to insert an image

Range("B9:I26").Select
myPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif; *.png),*.gif; *.jpg; *.bmp; *.tif; *.png", , "Select Picture to Import")
If myPicture = "False" Then Exit Sub

If myPicture <> "" Then
Set r = Selection
Set pic = ActiveSheet.Shapes.AddPicture(myPicture, False, True, 12, 99, 387, 285)

If pic.Height <> 285 Then
With pic
.Top = r.Top
.Left = r.Left
.Height = 285
.Placement = xlMoveAndSize
End With
End If

If pic.Width <> 387 Then
With pic
.Top = r.Top
.Left = r.Left
.Width = 387
.Placement = xlMoveAndSize
End With
End If
End If
End Sub

I am now learning so don't know what to do yet.
Thanks

 

[MickG]

Perhaps this :-
See code instructions:-
(1) Change Path to suit
(2) make sure Picture Names in column "A" are the same as Folde picture names
(3) Alter size, position etc. in code to suit.

[COLOR=navy]Sub[/COLOR] MG13Sep54
'[COLOR=green][B]The code Retrieves pictures from Selected[/B][/COLOR]
'[COLOR=green][B](Named) Folder to sheet.[/B][/COLOR]
'[COLOR=green][B]==================[/B][/COLOR]
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] fNam [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]Dim[/COLOR] Pth [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]Dim[/COLOR] FSO [COLOR=navy]As[/COLOR] Object, F [COLOR=navy]As[/COLOR] Object, ff [COLOR=navy]As[/COLOR] Object, f1 [COLOR=navy]As[/COLOR] Object
[COLOR=navy]Dim[/COLOR] oMax [COLOR=navy]As[/COLOR] Date
[COLOR=navy]Dim[/COLOR] MyObj [COLOR=navy]As[/COLOR] Picture
[COLOR=navy]Dim[/COLOR] nStr [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]Set[/COLOR] FSO = CreateObject("Scripting.FileSystemObject")
    '[COLOR=green][B]Change Folder Path below:-[/B][/COLOR]
    [COLOR=navy]Set[/COLOR] F = FSO.GetFolder("C:\Users\USER1\Desktop\Bird Pictures")
    [COLOR=navy]Set[/COLOR] ff = F.Files
    '[COLOR=green][B]Picture Names in column "A"[/B][/COLOR]
    [COLOR=navy]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
        [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
            [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] f1 [COLOR=navy]In[/COLOR] ff
               Pth = F.Path & "\"
                nStr = Dn.Value & ".jpg"
                [COLOR=navy]If[/COLOR] nStr = f1.Name [COLOR=navy]Then[/COLOR]
                    Pth = Pth & f1.Name
                    [COLOR=navy]Set[/COLOR] MyObj = ActiveSheet.Pictures.Insert(Pth)
        [COLOR=navy]With[/COLOR] MyObj
        
[COLOR=navy]With[/COLOR] .ShapeRange

        '[COLOR=green][B]Change details below to get Size and Postion Correct[/B][/COLOR]
        .Height = 50
        .Width = 100
        .Top = Dn.Offset(1, 1).Top
        .Left = Dn.Offset(, 1).Left
[COLOR=navy]End[/COLOR] With
  
    .Placement = xlMoveAndSize
    [COLOR=navy]End[/COLOR] With
[COLOR=navy]Set[/COLOR] MyObj = Nothing
[COLOR=navy]Exit[/COLOR] For
[COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] f1
[COLOR=navy]Next[/COLOR] Dn
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[kelly mort]

MickG,
I have missed you. I can't sent you pm again. My storage full I think.

Back to the script, it worked just as I wanted. Thanks a lot.

But some of the pics cannot be pasted . Don't know why

Also can I use the "ThisWorkbook.Path & "\" & "Pictures" for the file path? If yes how ? Because my work maybe carried on a flash drive. So I have a folder that I have the work and pictures folder in it.

 

[MickG]

Do you mean your workbook file and the various pictures are in The Same folder on a flash drive.???