VBA Code to AddPicture(s) based on Range Selection

[JohanGduToit]

Greetings Everybody,

I am new to this forum and apologise if I am submitting this request incorrectly or within the wrong forum.

I would truly appreciate assistance with adding (product item) pictures into a column located next to a selected column range which contains product codes.

The column containing 'Product Item Codes' is not in a fixed location (not a fixed range) and can be anywhere on an active worksheet. Product Image files are saved in a folder on our server
and each image filename correspond with values contained in the Product Item Column. I have managed to do this successfully utilizing Pictures.Insert; but this method, as you very well
know, does not embed images within the spreadsheet. Embedding images within the sheet is very important to us, so I have to revisit and adjust my code.

I have uploaded 2 images files : "Pre_Add_Picture" and "Post_Add_Picture" - "Pre-Add_Picture" samples a listing of "Product Item Codes" (before running the Macro/VBA code) and the "Post_Add_Picture" shows the expected results (after the Macro/VBA code was ran). Mini Sheet contain the working code for Pictures.Insert - but this needs to be modified to do an "Add.Picture" instead. Columns Height and Width's are also set to accommodate the images and images are sized to fit accordingly.

Below the working code for Pictures.Insert (I could not figure out how to do the mini sheet upload, sorry!):

'=====

Sub InsertImages()

Dim I As Integer
Dim PPath As String
Dim Col, X, Y As Long

X = Selection.Rows(1).Row
Y = Selection.Rows.Count + X - 1
Col = Selection.Columns(1).Column

Selection.RowHeight = 50
Columns(Col + 1).ColumnWidth = 8

With Selection
    .VerticalAlignment = xlCenter
End With

For I = X To Y
    'Product Code (Picture Filename) in Column A - but this can be any column range and will vary in how many items are selected)
    'PPath = "\\QVSERV\ANALYSER\DATA\IMAGES\" & CStr(Cells(I, Col).Value) & ".JPG"
    PPath = "\\RDSSERV\FUTURA\SVEN\BILD\" & CStr(Cells(I, Col).Value) & ".JPG"
   
    On Error Resume Next
   
    With ActiveSheet.Pictures.Insert(PPath)
        With .Placement
            .xlMoveAndSize
        End With
        With .ShapeRange
            .LockAspectRatio = msoFalse
            .Width = 50
            .Height = 49
        End With
        .Left = ActiveSheet.Cells(I, Col + 1).Left
        .Top = ActiveSheet.Cells(I, Col + 1).Top
        .Placement = 1
        .PrintObject = True
    End With
Next

End Sub

'=====

Your assistance will be GREATLY APPRECIATED and will make the lives of our staff so much easier!!

Thanking you in advance!

 

[Zyndstoff]

What do you mean exactly by "embedding" the picture in a worksheet?

 

[JohanGduToit]

What do you mean exactly by "embedding" the picture in a worksheet?

Hi,

To my knowledge, there are two ways of adding images via vba into a worksheet, the one being a "Pictures Insert" (i.e. ActiveSheet.Pictures.Insert) and the other "Add Pictures" (i.e. ActiveSheet.Shapes.AddPicture). I'm referring to the 2nd method that I am trying to achieve. The 1st method does not embed pictures and when emailing such a sheet, the recipient can not see the imported images), whilst the 2nd method actually embed's the imported images within the file, so the images are not merely a link to an image file; but in fact becomes part of the spreadsheet. (which allows the spreadsheet containing the images to be emailed to somebody outside of our LAN network. I hope that answers your question?

 

[Zyndstoff]

Okay, so I got this far:

Sub Makro6()

  Dim Bild As Shape
  Set Bild = Worksheets("Sheetname").Shapes.AddPicture(filepathname, False, True, 10, 10, -1, -1)
  Bild.Height = 100
 
End Sub

After adding the pic you can copy, move and resize the picture via the Bild-object (I just changed height in the code and found out, that it will keep its height-to-width ratio).

 

[JohanGduToit]

Okay, so I got this far:

Sub Makro6()

  Dim Bild As Shape
  Set Bild = Worksheets("Sheetname").Shapes.AddPicture(filepathname, False, True, 10, 10, -1, -1)
  Bild.Height = 100
 
End Sub

After adding the pic you can copy, move and resize the picture via the Bild-object (I just changed height in the code and found out, that it will keep its height-to-width ratio).

Thank you for your quick feedback Appreciated indeed.

May I ask if you could incorporate what you have done in my original posted code? Maybe comment out what should not be there and insert your code where needed?

I'm pretty new to this, so I need some guidance please

 

[Zyndstoff]

I'll try, but it may take a while.

 

[JohanGduToit]

I'll try, but it may take a while.

All help appreciated! I will send you some wine to say thank you!

So in essence, the macro/vba code should loop through the selected column range and insert (embed) the related image in the column next to each product code. I have tried; but it's not working. I have uploaded some product image files to play with.

 

[Zyndstoff]

Try this out:

Option Explicit

Sub InsertImages()

Dim I As Integer
Dim PPath As String
Dim Col, X, Y As Long
Dim Bild As Shape

X = Selection.Rows(1).Row
Y = Selection.Rows.Count + X - 1
Col = Selection.Columns(1).Column

Selection.RowHeight = 50
Selection.VerticalAlignment = xlCenter
Columns(Col + 1).ColumnWidth = 8

For I = X To Y
  PPath = "\\RDSSERV\FUTURA\SVEN\BILD\" & CStr(Cells(I, Col).Value) & ".JPG"
  On Error Resume Next
  Set Bild = ActiveSheet.Shapes.AddPicture(PPath, False, True, 10, 10, -1, -1)
  With Bild
    .Height = 49
    .Left = ActiveSheet.Cells(I, Col + 1).Left
    .Top = ActiveSheet.Cells(I, Col + 1).Top
    .Placement = 1
    .PrintObject = True
  End With
  Set Bild = Nothing
Next I
On Error GoTo 0
End Sub

 

[JohanGduToit]

Try this out:

Option Explicit

Sub InsertImages()

Dim I As Integer
Dim PPath As String
Dim Col, X, Y As Long
Dim Bild As Shape

X = Selection.Rows(1).Row
Y = Selection.Rows.Count + X - 1
Col = Selection.Columns(1).Column

Selection.RowHeight = 50
Selection.VerticalAlignment = xlCenter
Columns(Col + 1).ColumnWidth = 8

For I = X To Y
  PPath = "\\RDSSERV\FUTURA\SVEN\BILD\" & CStr(Cells(I, Col).Value) & ".JPG"
  On Error Resume Next
  Set Bild = ActiveSheet.Shapes.AddPicture(PPath, False, True, 10, 10, -1, -1)
  With Bild
    .Height = 49
    .Left = ActiveSheet.Cells(I, Col + 1).Left
    .Top = ActiveSheet.Cells(I, Col + 1).Top
    .Placement = 1
    .PrintObject = True
  End With
  Set Bild = Nothing
Next I
On Error GoTo 0
End Sub

Oh Wow! Worked like a charm I only had to comment out the 'Option Explicit declaration (said not allowed when running your code) See attached image of the result,,, I would like to preset the column width and height for the cells into which the images will be copied into and then adjust the image size accordingly. Would that be possible?

 

[Zyndstoff]

Well, I coded it that way so the pictures will always use the full height of the cell in order to get the biggest view of the item possible given the height of the cells. When you change width and height independently you get awkward looking pictures with distorted width-to-height ratio... wouldn't look nice.

Maybe just change "Columns(Col + 1).ColumnWidth = 8" to "Columns(Col + 1).ColumnWidth = 24" to make the picturecolumn triple the width.