Adding and Assigning Photos

[overKBV]

I have an asset list of 200+ items. I would like to add photos of each asset to its row. So far I have this command button vba

Private Sub AddPicture_Click()
    Dim strFileName As String
    Dim objPic As Picture
    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 = Me.Range("A10:D20")
    Set objPic = Me.Pictures.Insert(strFileName)
    With objPic
        .ShapeRange.LockAspectRatio = msoFalse
        .Left = rngDest.Left
        .Top = rngDest.Top
        .Width = rngDest.Width
        .Height = rngDest.Height
    End With
End Sub

I need to be able to restrict the photo to the individual cell and be able to repeat the button for each asset. Ideally I would be able to search for the asset and then click add photo.
Any help or direction to other resources would be appreciated.
Thanks
P.S. I did not write the code above so please don't overestimate my ability I have the most basic understanding of any of this.

 

[KOKOSEK]

This (I've done some changes) gives you opportunity to insert picture to activecell with the same button.
So select cell where you want to put picture and run it:

Sub AddPicture_Click()
    Dim strFileName As String
    Dim objPic As Picture
    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.Pictures.Insert(strFileName)
    With objPic
        .ShapeRange.LockAspectRatio = msoFalse
        .Left = rngDest.Left + 1
        .Top = rngDest.Top + 1
        .Width = rngDest.Width - 2
        .Height = rngDest.Height - 2
    End With
End Sub

to be honest I do not see reason to create separate buttons for each individual row/product/record.

 

[overKBV]

This (I've done some changes) gives you opportunity to insert picture to activecell with the same button.
So select cell where you want to put picture and run it:

Sub AddPicture_Click()
    Dim strFileName As String
    Dim objPic As Picture
    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.Pictures.Insert(strFileName)
    With objPic
        .ShapeRange.LockAspectRatio = msoFalse
        .Left = rngDest.Left + 1
        .Top = rngDest.Top + 1
        .Width = rngDest.Width - 2
        .Height = rngDest.Height - 2
    End With
End Sub

to be honest I do not see reason to create separate buttons for each individual row/product/record.

It works thank you!

 

[KOKOSEK]

Happy to hear it.
You have to remember that ActiveSheet.Pictures.Insert(strFileName) just inserting picture into excel (link them) and if you want to use this excel on another computer, picture won't be visible.
If you want to see these picture on each computer you can use this (main change is to use Shapes.AddPicture instaed)

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
End Sub

 

[overKBV]

Happy to hear it.
You have to remember that ActiveSheet.Pictures.Insert(strFileName) just inserting picture into excel (link them) and if you want to use this excel on another computer, picture won't be visible.
If you want to see these picture on each computer you can use this (main change is to use Shapes.AddPicture instaed)

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
End Sub

Is there a way to permalink them? It is all in OneDrive if that would fix it?

 

[overKBV]

Is there a way to permalink them? It is all in OneDrive if that would fix it?

Also is there a way to link an object with the file location of the picture so when I clicked on the photo it could direct me to that picture in file explorer? Again, you have been very helpful thanks!

 

[KOKOSEK]

Code from post #4 (AddPictureNotInsert) do the job. Pictures will be permanently embed and keep inside xl file.

 

[overKBV]

Code from post #4 (AddPictureNotInsert) do the job. Pictures will be permanently embed and keep inside xl file.

That works. I do not know if you saw my reply to myself so I'll post it again. No pressure. But I would like to be able to take that photo and copy and paste it into a word doc but to get it to fit in the cell it has to be shrunk. Do you know of a way I can link the file location so when I click on or near the photo is would then open it in file explorer or photos. Again appreciate your help.

 

[KOKOSEK]

Add this line:

ActiveSheet.Hyperlinks.Add Anchor:=objPic, Address:=strFileName

before End Sub, so end of code should looks like this:

.....................
        .Width = rngDest.Width - 2
        .Height = rngDest.Height - 2
    End With
    ActiveSheet.Hyperlinks.Add Anchor:=objPic, Address:=strFileName
End Sub

then after inserting picture it will be clickable link into explorer.
I do not get this part with repasting it into word.

 

[overKBV]

It does what I need it to do. Thanks a bunch