Insert Picture In Comment Excel 2010

[Jaye7]

Jeff/ Repairman615 has provided the following script on another post, however he could not get it to work for Excel 2010, it works perfectly on Excel 2003 and 2007, just not on 2010.

[COLOR=black][COLOR=#00007f]Sub[/COLOR] Insert_Comment_Picture()
 
[COLOR=#007f00]'''Uses column E:E and insert into column G:G[/COLOR]
 
[COLOR=#00007f]Dim[/COLOR] PicNo [COLOR=#00007f]As[/COLOR] [COLOR=#00007f]Integer[/COLOR], LR [COLOR=#00007f]As[/COLOR] [COLOR=#00007f]Integer[/COLOR], _
c [COLOR=#00007f]As[/COLOR] Range, cRng [COLOR=#00007f]As[/COLOR] Range, _
FR [COLOR=#00007f]As[/COLOR] [COLOR=#00007f]String[/COLOR], fPath [COLOR=#00007f]As[/COLOR] [COLOR=#00007f]String[/COLOR], _
Ws [COLOR=#00007f]As[/COLOR] Worksheet, rngComment [COLOR=#00007f]As[/COLOR] Range
 
[COLOR=#00007f]Set[/COLOR] Ws = ActiveSheet
 
fPath = "C:\Users\standard account\Pictures\" [COLOR=#007f00]'''Change to your file path[/COLOR]
[COLOR=#00007f]If[/COLOR] Right(fPath, 1) <> "\" [COLOR=#00007f]Then[/COLOR] fPath = fPath & "\"
 
FR = "E1" [COLOR=#007f00]'''First cell in column E:E <------Change to suit[/COLOR]
 
LR = Ws.Range("E" & Rows.Count).End(xlUp).Row
[COLOR=#00007f]Set[/COLOR] cRng = Ws.Range(FR & ":E" & LR)
 
[COLOR=#00007f]On[/COLOR] [COLOR=#00007f]Error[/COLOR] [COLOR=#00007f]Resume[/COLOR] [COLOR=#00007f]Next[/COLOR]
[COLOR=#00007f]For[/COLOR] [COLOR=#00007f]Each[/COLOR] c [COLOR=#00007f]In[/COLOR] cRng
[COLOR=#00007f]Set[/COLOR] rngComment = Ws.Range("G" & c.Row)
[COLOR=#00007f]With[/COLOR] rngComment
[COLOR=red].Comment.Delete[/COLOR]
.AddComment
.Comment.Shape.Fill.UserPicture fPath & c.Value & ".jpg"
.Comment.Shape.ScaleWidth 3, msoFalse, msoScaleFromTopLeft
.Comment.Shape.ScaleHeight 3, msoFalse, msoScaleFromTopLeft
[COLOR=#00007f]End[/COLOR] [COLOR=#00007f]With[/COLOR]
[COLOR=#00007f]Set[/COLOR] rngComment = [COLOR=#00007f]Nothing[/COLOR]
[COLOR=#00007f]Next[/COLOR] c
[COLOR=#00007f]On[/COLOR] [COLOR=#00007f]Error[/COLOR] [COLOR=#00007f]GoTo[/COLOR] 0
[COLOR=#00007f]End[/COLOR] [COLOR=#00007f]Sub[/COLOR]
[/COLOR]

This script will work fine if comments are already in the cells, however if there are no comments then it is getting stuck on the .comment.delete line of the script.

Error no. 91 - variable width block not set.

Can someone please help with this.

 

[AlphaFrog]

.deleted

 

[Jaye7]

Hi Alphafrog,

.deleted gives a different error no 438 object doesn't support this property or method.

 

[AlphaFrog]

.deleted gives a different error no 438 object doesn't support this property or method.

Sorry. I meant that I deleted my original reply as I realized after I posted that it wasn't a solution. So I deleted it. I didn't mean to suggest you try .deleted

I don't have a suggestion for you.

 

[Jaye7]

Solution obtained, thanks to Jeff and a small contribution from myself.

Sub Insert_Comment_Picture()
'''Uses column E:E and insert into column G:G
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 = "C:\Users\Public\Pictures\Sample Pictures\"   '''Change to your file path
If Right(fPath, 1) <> "\" Then fPath = fPath & "\"
FR = "E1"   '''First cell in column E:E  <------Change to suit
LR = Ws.Range("E" & Rows.Count).End(xlUp).Row
Set cRng = Ws.Range(FR & ":E" & LR)
    On Error Resume Next
    For Each c In cRng
        If c.Value = "" Then
            If Not (c.Offset(0, 2).Comment Is Nothing) Then c.Offset(0, 2).Comment.Delete
            GoTo SkipLoop
        End If
 
 
        Set rngComment = Ws.Range("G" & c.Row)
        With rngComment
 
        If Not .Comment Is Nothing Then .Comment.Delete
        .AddComment
 
            .Comment.Shape.Fill.UserPicture fPath & c.Value & ".jpg"
            .Comment.Shape.ScaleWidth 3, msoFalse, msoScaleFromTopLeft
            .Comment.Shape.ScaleHeight 3, msoFalse, msoScaleFromTopLeft
        End With
 
        Set rngComment = Nothing
SkipLoop:
    Next c
    On Error GoTo 0
End Sub