VBA auto-add image to cell from folder

[menno_edeltrend]

Dear mrExcellers,

In my company we work with a product database with calculations in it, every product offcourse has an unique article number. In the shared server we have a folder with pictures of every product with the article number as the title. We want to add the pictures automatically to every product with VBA, I know it is possible but my knowledge doesn't stretch far enough.

The article number stands in column D, the picture has to been placed in column B. The cel widht and hight are minimal, it would be nice to have the picture expending when you move the mouse over it.

I would like to let VBA start in the selected row and then go on from there till there is no article number in column D. That way it doesn't overwrite all the previous uploaded pictures.

I hope there is someone out there with the solution, thanks in advance!

 

[menno_edeltrend]

Upload MR.Excell/CALCULTIE FORMULIER test ME 10-12.xls and 6 more files

7 files sent via WeTransfer, the simplest way to send your files around the world

wetransfer.com

 

[DanteAmor]

Ready, this code works with your file examples

Sub Auto_Add_Image_2()
  Dim i As Long, wPath As String, wFile As String, sh As Worksheet
  Dim h As Variant, w As Variant
  If ActiveCell.Column <> 3 Then
    MsgBox "Select column C"
    Exit Sub
  End If
  If ActiveCell.Value = "" Then
    MsgBox "Select article number in column C"
    Exit Sub
  End If
  Set sh = ActiveSheet
   With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Selecteer map"
    .AllowMultiSelect = False
    .InitialFileName = ThisWorkbook.Path & "\"
    If .Show <> -1 Then Exit Sub
    wPath = .SelectedItems(1) & "\"
  End With
 
  For i = ActiveCell.Row To Range("C" & Rows.Count).End(xlUp).Row
    If Range("C" & i).Value <> "" Then
      wFile = wPath & Range("C" & i).Value
      If Dir(wFile) <> "" Then
        With sh.Pictures.Insert(wFile)
          h = Range("B" & i).Height - 2
          w = Range("B" & i).Width - 2
          .ShapeRange.LockAspectRatio = True
          .Top = Range("B" & i).Top + 1
          .Left = Range("B" & i).Left + 1
          .ShapeRange.Height = h
          .ShapeRange.Width = w
          Do While True
            .ShapeRange.Height = h
            .ShapeRange.Width = w
            If .Width < Range("B" & i).Width And .Height < Range("B" & i).Height Then Exit Do
            h = h - 5
            w = w - 5
          Loop
          
          With Range("B" & i).AddComment
            .Shape.Fill.UserPicture wFile
            .Shape.ScaleHeight 4, msoFalse, msoScaleFromTopLeft
            .Shape.ScaleWidth 3.25, msoFalse, msoScaleFromTopLeft
          End With
        End With
      Else
        MsgBox "The file does not exist: " & wFile
      End If
    End If
  Next
End Sub

 

[menno_edeltrend]

It works! Do you think I can do the same for the .AddComment part? So that also the comment keeps the right aspectratio?

 

[DanteAmor]

Try this.
But I think the following is about the aspect of the comment, not about the image within the comment.
But check if it is what you need.

          With Range("B" & i)
            .AddComment
            .Comment.Shape.Fill.UserPicture wFile
            .Comment.Shape.ScaleHeight 4, msoFalse, msoScaleFromTopLeft
            .Comment.Shape.ScaleWidth 3.25, msoFalse, msoScaleFromTopLeft
            .Comment.Shape.LockAspectRatio = msoTrue
          End With

 

[menno_edeltrend]

No that is indeed not working unfortunately. I think what makes it hard to do is that the picture becomes the fill of the comment and does not stay a picture.

 

[DanteAmor]

I was investigating and did not find properties of the image within the comment. The properties are from the comment.

In addition to inserting the image and putting the image in the comment I think your file will grow too much.
You can zoom the sheet to see the image larger, or make the cells larger so that the image is in a larger space.