VBA Code to AddPicture(s) based on Range Selection

JohanGduToit

Board Regular
Joined
Nov 12, 2021
Messages
89
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
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!):

'=====
VBA Code:
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!
 

Attachments

  • Post_Add_Picture.JPG
    Post_Add_Picture.JPG
    43.7 KB · Views: 32
  • Pre_Add_Picture.JPG
    Pre_Add_Picture.JPG
    46.3 KB · Views: 32

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
What do you mean exactly by "embedding" the picture in a worksheet?
 
Upvote 0
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?
 
Upvote 0
Okay, so I got this far:

VBA Code:
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).
 
Upvote 0
Okay, so I got this far:

VBA Code:
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 :)
 
Upvote 0
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.
 

Attachments

  • 103497.JPG
    103497.JPG
    40.5 KB · Views: 10
  • 137928.JPG
    137928.JPG
    6 KB · Views: 9
  • 183765.JPG
    183765.JPG
    46.4 KB · Views: 8
  • 183772.JPG
    183772.JPG
    10.1 KB · Views: 7
  • 183789.JPG
    183789.JPG
    35.3 KB · Views: 8
  • 183796.JPG
    183796.JPG
    46.3 KB · Views: 7
  • 191074.jpg
    191074.jpg
    40.1 KB · Views: 7
  • 196666.JPG
    196666.JPG
    31 KB · Views: 9
Upvote 0
Try this out:

VBA Code:
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
 
Upvote 0
Try this out:

VBA Code:
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?
 

Attachments

  • Result.JPG
    Result.JPG
    26.9 KB · Views: 21
Upvote 0
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.
 
Upvote 0

Forum statistics

Threads
1,213,485
Messages
6,113,931
Members
448,533
Latest member
thietbibeboiwasaco

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top