Find Pictures and Insert into Cell Comments

Sub Main()
  Dim p$, r As Range, c As Range, calc As Integer
  p = "c:\pictures\inventory\"
  'p = ThisWorkbook.Path & "\"


  On Error GoTo EndSub
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    calc = .Calculation
    .Calculation = xlCalculationManual
  End With


  Set r = Range("A2", Cells(Rows.Count, "A").End(xlUp))
  'Set r = [a2]
  For Each c In r
    PicToComment c.Offset(, 2), p & c.Value & ".jpg", c.Value, , 3 * 72
  Next c


EndSub:
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = calc
    .CutCopyMode = False
  End With
End Sub




Sub PicToComment(aCell As Range, picPath As String, _
  Optional cText As String = "", Optional dWidth As Double = 0, _
  Optional dHeight As Double = 0)
  Dim Cmnt As Comment, pic As StdPicture


  If Dir(picPath) = "" Then cText = "Not Found"


  Set Cmnt = aCell.Comment
  If Cmnt Is Nothing Then
    Set Cmnt = aCell.AddComment
    Cmnt.Shape.TextFrame.Characters.Text = cText
  End If
  If cText = "Not Found" Then Exit Sub


  Set pic = LoadPicture(picPath)
  With Cmnt.Shape
    'If dHeight = 0 Then dHeight = 100 * pic.Height / pic.Width
    If dHeight = 0 Then dHeight = pic.Height / 25.4
    .Height = dHeight


    'If dWidth = 0 Then dWidth = 100 * pic.Width / pic.Height
    'If dWidth = 0 Then dWidth = pic.Width / 25.
    If dWidth = 0 Then dWidth = dHeight * pic.Width / pic.Height
    .Width = dWidth


    .Fill.UserPicture picPath
  End With
End Sub