VBA Code to insert image automatically into comment box of each item number from item list

kpeer · Aug 28, 2018

Dear Everyone,

this forum had always been a great help even though I have only used it passive so far. However, I stuck with the following problem and could not find anything to solve it.

In my table are item numbers listed in the first (A) column. I want to insert a comment box to each cell with an item number and the comment box shall show the respective item image of that item number within the cell. This shall happen to all cells with item numbers within column A.
If I add an item number to the list then the code shall automatically insert the comment box incl. item image to that cell.

The item image is named after the item number and (as there are more than one image) extended by a "-" and a running number.
--> Example1: "218001-1.jpeg" ("218001" = item number; "-1" = running number)
--> Example2: "218002-1.jpeg" ("218002" = item number; "-1" = running number) ... and so on ...

The images are located in subfolders of the excel file. Each subfolder is named after the item number. The path of the file shall be mobile thorugh "ThisWorkbook.Path".
--> Example1: "ThisWorkbook.Path\218001\218001-1.jpeg"
--> Example2: "ThisWorkbook.Path\218001\218002-1.jpeg" ... and so on ...

The code shall...
- start with opening of the file
- overwrite the existing comment (to include updated item images)
- If no image can be found, insert "no image found"
- If image can be found, insert image
- reduce the image size respecting the orignial aspect ratio

My code looks like the following so far (Code entered in Sheet1):

Code:

Sub MakeCommentWithPicture()
  Dim a As Integer, cmt As Comment, Path
  lr = Cells(Rows.Count, 1).End(xlUp).Row
  With Sheets(1)
  For a = 4 To lr
    Path= ThisWorkbook.Path & "\" & ActiveCell.Value & "\" & ActiveCell.Value & "-1.jpeg"
    With .Cells(a, 1)
        .ClearComments
        .AddComment
        .Comment.Visible = False
        If Dir(Path) <> "" Then
            .Comment.Shape.DrawingObject.AutoSize = True
            With .Comment.Shape.TextFrame.Characters
              .Font.Bold = True
              .Font.Size = 12
            End With
            .Comment.Shape.Fill.UserPicture Path
            .Comment.Shape.Width = 200
            .Comment.Shape.Height = 300
        Else
            With .Comment.Shape.TextFrame.Characters
              .Font.Bold = True
              .Font.Size = 12
              .Text = "no image found"
            End With
        End If
      End With
  Next
  End With
End Sub

Unfortunately, the code does not work yet. The code already creates comment boxes but only insert "no image found". Furthermore, I do not really know, how to reduce the image size respecting the orignial aspect ratio.

Sorry, I am a VBA beginner and would really appreciate your

kpeer · Aug 28, 2018

Soooooo, an update. I could almost solve my problem through the following code:

Code:

Sub Insert_Comment_Picture()
Dim PicNo           As Integer, _
    LR              As Integer, _
    c               As Range, _
    cRng            As Range, _
    FR              As String, _
    fPath           As String, _
    Ws              As Worksheet, _
    rngComment      As Range
Set Ws = ActiveSheet
fPath = ThisWorkbook.Path & "\"   

If Right(fPath, 1) <> "\" Then fPath = fPath & "\"
FR = "A4"   '''First cell in column A:A  
LR = Ws.Range("A" & Rows.Count).End(xlUp).Row
Set cRng = Ws.Range(FR & ":A" & LR)
    On Error Resume Next
    For Each c In cRng
        If c.Value = "" Then
            If Not (c.Offset(0, 0).Comment Is Nothing) Then c.Offset(0, 0).Comment.Delete
            GoTo SkipLoop
        End If
  
        Set rngComment = Ws.Range("A" & c.Row)
        With rngComment
 
        Application.ScreenUpdating = False
        Set picBild = ActiveSheet.Pictures.Insert(fPath & c.Value & "\" & c.Value & "-1.jpg")
        
        If Not .Comment Is Nothing Then .Comment.Delete
        fFile = fPath & c.Value & "\" & c.Value & "-1.jpg"
        .AddComment
            .Comment.Visible = False
            .Comment.Shape.Width = picBild.Width
            .Comment.Shape.Height = picBild.Height
            .Comment.Shape.Fill.UserPicture fFile
            .Comment.Shape.ScaleWidth 0.36, msoFalse, msoScaleFromTopLeft
            .Comment.Shape.ScaleHeight 0.36, msoFalse, msoScaleFromTopLeft
       
        End With
 
        picBild.Delete
        Set picBild = Nothing
        Application.ScreenUpdating = True
      
        Set rngComment = Nothing
SkipLoop:
    Next c
    On Error GoTo 0
End Sub

Only one issue still bothers me: How is it possible that the comment (with the picture) height is always 300 high but the width shall be in relation to the orignial aspect ratio.

Thank you in advance for your help!

VBA Code to insert image automatically into comment box of each item number from item list

kpeer

New Member

Excel Facts

kpeer

New Member

Similar threads

Forum statistics

Share this page

VBA Code to insert image automatically into comment box of each item number from item list

kpeer

New Member

Excel Facts

kpeer

New Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock