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]

It works!

 

[DanteAmor]

I'm glad to know that it works for you.

 

[menno_edeltrend]

Thanks to DanteAmor I created the code below to auto add in images and a comment with the extended image.

Sub Auto_Add_Image_2()
   Dim i As Long, wPath As String, wFile As String, sh As Worksheet
  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
    wFile = wPath & Range("C" & i)
     If Dir(wFile) <> "" Then
    With sh.Pictures.Insert(wFile)
        .Top = Range("C" & i).Top + 1
        .Left = Range("C" & i).Left + 1
        .ShapeRange.LockAspectRatio = msoFalse
        .Placement = xlMoveAndSize
        .Width = Range("C" & i).Width - 2
        .Height = Range("C" & i).Height - 2
    End With
    Thispicture = wFile
    With ActiveCell.AddComment
        .Shape.Fill.UserPicture Thispicture
        .Shape.ScaleHeight 4, msoFalse, msoScaleFromTopLeft
        .Shape.ScaleWidth 3.25, msoFalse, msoScaleFromTopLeft
    End With
    ActiveCell.Offset(1, 0).Select
    Else
      MsgBox "The file does not exist: " & wFile
     End If
  Next
End Sub

The images are set to the cell size witch messes up their ratio's. If I set LockAspectRatio to true the images are larger then the cell. Is it possible to set LockAspectRatio to true and make sure the picture doesn't become bigger than the cell? So the cell will just be partially unfilled depending on whether the picture hits the maximum hight or width. Thank you in advance!

 

[DanteAmor]

Check if the following works for you.

Sub Auto_Add_Image()
  Dim i As Long, wPath As String, wFile As String, Sh As Worksheet
  Range("D7").Select
  If ActiveCell.Column <> 4 Then
    MsgBox "Select column D"
    Exit Sub
  End If
  If ActiveCell.Value = "" Then
    MsgBox "Select article number in column D"
    Exit Sub
  End If
  Set Sh = ActiveSheet
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Selecciona una carpeta"
    .AllowMultiSelect = False
    .InitialFileName = "C:\Users\damor\Pictures\" 'ThisWorkbook.Path & "\"
    If .Show <> -1 Then Exit Sub
    wPath = .SelectedItems(1) & "\"
  End With
  For i = ActiveCell.Row To Range("D" & Rows.Count).End(xlUp).Row
    wFile = wPath & Range("D" & i)
    If Dir(wFile) <> "" Then
      With Sh.Pictures.Insert(wFile)
          .ShapeRange.LockAspectRatio = False
          .Top = Range("B" & i).Top + 1
          .Left = Range("B" & i).Left + 1
          .Width = Range("B" & i).Width - 2
          .Height = Range("B" & i).Height - 2
          .ShapeRange.LockAspectRatio = True
        End With
    Else
      MsgBox "The file does not exist: " & wFile
    End If
  Next
End Sub

 

[menno_edeltrend]

Thank you for your response again, unfortunately this does not work. It still shanges the ratio to fit inside the cell filling the whole cel. Pictures that are longer than they are wide are placed randomly around the sheet.

 

[DanteAmor]

Try this

Sub Auto_Add_Image()
  Dim i As Long, wPath As String, wFile As String, sh As Worksheet
  If ActiveCell.Column <> 4 Then
    MsgBox "Select column D"
    Exit Sub
  End If
  If ActiveCell.Value = "" Then
    MsgBox "Select article number in column D"
    Exit Sub
  End If
  Set sh = ActiveSheet
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Selecciona una carpeta"
    .AllowMultiSelect = False
    .InitialFileName = "C:\Users\damor\Pictures\" 'ThisWorkbook.Path & "\"
    If .Show <> -1 Then Exit Sub
    wPath = .SelectedItems(1) & "\"
  End With
  For i = ActiveCell.Row To Range("D" & Rows.Count).End(xlUp).Row
    wFile = wPath & Range("D" & i)
    If Dir(wFile) <> "" Then
      With sh.Pictures.Insert(wFile)
        .ShapeRange.LockAspectRatio = True
        .Top = Range("B" & i).Top + 1
        .Left = Range("B" & i).Left + 1
        Dim h, w
        h = 1000
        w = 1000
        Do While True
          .ShapeRange.Height = h
          .ShapeRange.Width = w
          If .Width > Range("B" & i).Width Or .Height > Range("B" & i).Height Then
          Else
            Exit Sub
          End If
          h = h - 10
          w = w - 10
        Loop
      End With
    Else
      MsgBox "The file does not exist: " & wFile
    End If
  Next
End Sub

 

[menno_edeltrend]

Now the macro does nothing anymore, is it correct that it is empty after "then" and "else".

 

[DanteAmor]

Now the macro does nothing anymore, is it correct that it is empty after "then" and "else". Yes that's right.

Macros work in my tests. The image is inside the cell.
Maybe it will be your excel version or the type of image.

Try this

Sub Auto_Add_Image()
  Dim i As Long, wPath As String, wFile As String, sh As Worksheet
  If ActiveCell.Column <> 4 Then
    MsgBox "Select column D"
    Exit Sub
  End If
  If ActiveCell.Value = "" Then
    MsgBox "Select article number in column D"
    Exit Sub
  End If
  Set sh = ActiveSheet
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Selecciona una carpeta"
    .AllowMultiSelect = False
    .InitialFileName = ThisWorkbook.Path & "\"
    If .Show <> -1 Then Exit Sub
    wPath = .SelectedItems(1) & "\"
  End With
  For i = ActiveCell.Row To Range("D" & Rows.Count).End(xlUp).Row
    wFile = wPath & Range("D" & i)
    If Dir(wFile) <> "" Then
      With sh.Pictures.Insert(wFile)
        .ShapeRange.LockAspectRatio = True
        .Top = Range("B" & i).Top + 1
        .Left = Range("B" & i).Left + 1
        Dim h, w
        h = 1000
        w = 1000
        Do While True
          .ShapeRange.Height = h
          .ShapeRange.Width = w
          If .Width > Range("B" & i).Width And .Height > Range("B" & i).Height Then
            Exit Do
          End If
          h = h + 100
          w = w + 100
        Loop
        Do While True
          .ShapeRange.Height = h
          .ShapeRange.Width = w
          If .Width > Range("B" & i).Width Or .Height > Range("B" & i).Height Then
          Else
            Exit Sub
          End If
          h = h - 10
          w = w - 10
        Loop
      End With
    Else
      MsgBox "The file does not exist: " & wFile
    End If
  Next
End Sub

Or try this

Sub Auto_Add_Image2()
  Dim i As Long, wPath As String, wFile As String, sh As Worksheet
  If ActiveCell.Column <> 4 Then
    MsgBox "Select column D"
    Exit Sub
  End If
  If ActiveCell.Value = "" Then
    MsgBox "Select article number in column D"
    Exit Sub
  End If
  Set sh = ActiveSheet
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Selecciona una carpeta"
    .AllowMultiSelect = False
    .InitialFileName = ThisWorkbook.Path & "\"
    If .Show <> -1 Then Exit Sub
    wPath = .SelectedItems(1) & "\"
  End With
  For i = ActiveCell.Row To Range("D" & Rows.Count).End(xlUp).Row
    wFile = wPath & Range("D" & i)
    If Dir(wFile) <> "" Then
      With sh.Pictures.Insert(wFile)
        .ShapeRange.LockAspectRatio = True
        .Top = Range("B" & i).Top + 1
        .Left = Range("B" & i).Left + 1
        Dim h, w
        h = 1000
        w = 1000
        Do While True
          .ShapeRange.Height = h
          .ShapeRange.Width = w
          If .Width > Range("B" & i).Width And .Height > Range("B" & i).Height Then
            Exit Do
          End If
          h = h + 100
          w = w + 100
        Loop
        h = 1
        w = 1
        Do While True
          '.ShapeRange.Height = h
          '.ShapeRange.Width = w
          
          .ShapeRange.ScaleHeight h, msoTrue
          .ShapeRange.ScaleWidth w, msoTrue
          
          If .Width > Range("B" & i).Width Or .Height > Range("B" & i).Height Then
          Else
            Exit Sub
          End If
          h = h - 0.1
          w = w - 0.1
        Loop
      End With
    Else
      MsgBox "The file does not exist: " & wFile
    End If
  Next
End Sub

 

[menno_edeltrend]

It still doesn't work, especially on tall images. It works on 1 cell with some images but it doesn't go through the whole selection. Also it doesn't work with the .Addcomment that I have in my macro.

 

[DanteAmor]

All options work for me, the image is inside the cell with the LockAspectRatio property = True.
You can upload your Excel file and one of the images that do not work for you, to check the conditions in which they are.

You could upload a copy of your file to a free site such www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. If the workbook contains confidential information, you could replace it with generic data.