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]

Just for fun, try this. This code should select the biggest possible Picturesize depending on the cell size and center the picture in the cell.
I have not tested this, but it should do the job.

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 = 24
 
  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 = ActiveSheet.Cells(I, Col + 1).Height
      If .Width > ActiveSheet.Cells(I, Col + 1).Width Then
        .Width = ActiveSheet.Cells(I, Col + 1).Width
      End If
      .Left = ActiveSheet.Cells(I, Col + 1).Left + (ActiveSheet.Cells(I, Col + 1).Width - .Width) / 2
      .Top = ActiveSheet.Cells(I, Col + 1).Top + (ActiveSheet.Cells(I, Col + 1).Height - .Height) / 2
      .PrintObject = True
    End With
    Set Bild = Nothing
  Next I
  On Error GoTo 0
End Sub

 

[JohanGduToit]

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.

Thank you so so much; I truly appreciate what you have done and believe me, this will have a big impact on user productivity. To date, this use to be a manual process where users imported image one by one! I will try out your suggested change above and revert back soon. I'm signing off for the day Have a gr8 weekend. Please inbox me your address details (if you wish) and wine preference...

 

[JohanGduToit]

Just for fun, try this. This code should select the biggest possible Picturesize depending on the cell size and center the picture in the cell.
I have not tested this, but it should do the job.

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 = 24
 
  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 = ActiveSheet.Cells(I, Col + 1).Height
      If .Width > ActiveSheet.Cells(I, Col + 1).Width Then
        .Width = ActiveSheet.Cells(I, Col + 1).Width
      End If
      .Left = ActiveSheet.Cells(I, Col + 1).Left + (ActiveSheet.Cells(I, Col + 1).Width - .Width) / 2
      .Top = ActiveSheet.Cells(I, Col + 1).Top + (ActiveSheet.Cells(I, Col + 1).Height - .Height) / 2
      .PrintObject = True
    End With
    Set Bild = Nothing
  Next I
  On Error GoTo 0
End Sub

You are a star... will test and revert back

 

[JohanGduToit]

Worked PERFECTLY !

 

[Zyndstoff]

Glad I could help.