Macro to insert comment with image

[Branon]

Hi all,

I've had a stab at this myself by recording a macro and then attempting the tweaks - but cant seem to get it working.

Okay so here it goes....

I'd like to create a marco which will automatically insert a comment into a column of cells.

• The cells will contain data (part numbers)
• Rather then contain text, the comment will contain a background image
• It will look within a folder for the image (on my computer) for a file name matching the part number
• Id like it to add the comment, size it to a particular size and then move down a row to the next
• keep doing so until it finds the next blank cell, and then stop.

Below is my stab at it - but it doesn't quite seem to to work. Can anyone help?



' Macro2 Macro
Dim file_core, prt_num As String
file_core = "C:\Users\Public\Pictures\Sample Picturesl"


Do Until ActiveCell.Value = ""


prt_num = Cells(ActiveCell.Row, 2).Value 'get part number


Cells(ActiveCell.Row, 2).AddComment 'add comment gubbens
Cells(ActiveCell.Row, 2).Visible = False
Cells(ActiveCell.Row, 2).Text Text:=""
Cells(ActiveCell.Row, 2).Shape.Select True


Selection.ShapeRange.Fill.Transparency = 0#
Selection.ShapeRange.Line.Weight = 0.75
Selection.ShapeRange.Line.DashStyle = msoLineSolid
Selection.ShapeRange.Line.Style = msoLineSingle
Selection.ShapeRange.Line.Transparency = 0#
Selection.ShapeRange.Line.Visible = msoTrue
Selection.ShapeRange.Line.ForeColor.RGB = RGB(0, 0, 0)
Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 255)
Selection.ShapeRange.Fill.BackColor.RGB = RGB(255, 255, 225)

On Error Resume Next
Selection.ShapeRange.Fill.UserPicture file_core & prt_num & ".png"
Selection.ShapeRange.Fill.UserPicture file_core & prt_num & ".jpg"
On Error GoTo 0


Selection.ShapeRange.ScaleWidth 1.57, msoFalse, msoScaleFromTopLeft '
Selection.ShapeRange.ScaleHeight 1.2, msoFalse, msoScaleFromTopLeft



ActiveCell.Offset(1, 0).Select
Loop




End Sub

 

[ww4612]

i think the following 3 string is invaild

Cells(ActiveCell.Row, 2).Visible = False
Cells(ActiveCell.Row, 2).Text Text:=""
Cells(ActiveCell.Row, 2).Shape.Select True

1. you cannot make cell invisible
2. you can put text into cell wtih .value=""
3.you do not need to use Boolean for select
another advise is to use With, it will improve the performance of your code

 

[VBA Geek]

To add a comment and a pic in it, try

Sub InsImgInComment()
Const picPath As String = "C:\Users\photo 2.jpg"
With Range("A1")
    .AddComment
    .Comment.Visible = True
    .Comment.Shape.Fill.UserPicture (picPath)
End With
End Sub

 

[Branon]

Thanks for the replies - I've had a play with the With, and managed to get it working 99%

Sub InsertComment()


Range("B2").Select
Range("B:B").ClearComments


Do Until ActiveCell.Value = ""
Dim CommentPic As Comment


'Application.ActiveCell.ClearComments


Set CommentPic = Application.ActiveCell.AddComment


With CommentPic
.Visible = False
.Text Text:=""
With .Shape
.Fill.UserPicture ("C:\Users\Pictures\Misc\" & ActiveCell.Value & ".jpg")
.ScaleHeight 2.5, msoFalse, msoScaleFormTopLeft
.ScaleWidth 2.5, msoFalse, msoScaleFromTopLeft
End With
End With
ActiveCell.Offset(1, 0).Select
Loop


End Sub


The only issue I have now, is that if there is no image in the folder for the part number, the macro fails. I'm guessing I need some sort of IF statement to tell the code to run if there is a matching file name?

 

[VBA Geek]

Try it like this:

Sub InsImgInComment()
Const picPath As String = "C:\Users\photo 2.jpg"
If CBool(Len(Dir(picPath))) Then
    With Range("A1")
        .AddComment
        .Comment.Visible = True
        .Comment.Shape.Fill.UserPicture (picPath)
    End With
End If
End Sub