Solved: Insert comment pictures fill down.

[Shazam]

Hi everyone,



I'm trying to modify this code so it will insert comment with pictures in column A. Here what I got so far:

I left an example file below.

This where I originaly got the code from.

http://www.vbaexpress.com/forum/showthread.php?t=8789


Sub pix()


Dim rngCell As Range
Dim curWks As Worksheet
Dim c As Object
Dim Path As String



Set curWks = ActiveSheet


Path = "C:\" & Range("A2:a" & Cells(Rows.Count, "A").End(xlUp).Row).Text & ".jpg"


With rngCell.Offset(0, 0)
.AddComment("").Shape.Fill.UserPicture (Path)
For Each c In ActiveSheet.Comments
c.Shape.Width = 400
c.Shape.Height = 300
Next c
End With


End Sub

[Simon Lloyd]

Why insert a comment, you could use data validation like this:

With Range("A1").Validation
.Delete
.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
:=xlBetween
.InputMessage = "You have a picture in this cell!"
End With
this shows no dropdown, doesn't require an input just shows a "comment" when the cell is selected!

[Shazam]

Sorrry Simon Lloyd (http://vbaexpress.com/forum/member.php?u=3275)



That won't work I need it the way I have in the example file I posted.


Any help?

[rbrhodes]

Hi Shazam,

This should help you out.


Option Explicit
Sub Mypix()

Dim c As Object
Dim eMsg As String
Dim Pathe As String
Dim rngCell As Range
Dim rngSheet As Range
Dim curWks As Worksheet

'Handle errors
On Error GoTo endo

'Speed
Application.ScreenUpdating = False

'Create reference
Set curWks = ActiveSheet

'Employ reference
With curWks
'Clear all old comments
.Columns("A").ClearComments
'Define range as Col A1 to last row Col A
Set rngSheet = .Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
End With

'Drive (& optionally directory) must end with "\"
Pathe = "L:\"

'For each cell
For Each rngCell In rngSheet
'If blank
If Trim(rngCell.Value) = "" Then
'do nothing
ElseIf Dir(Pathe & rngCell.Value & ".jpg") = "" Then
'picture not there!
MsgBox rngCell.Value & " doesn't exist!"
Else
'put picture
rngCell.AddComment("").Shape.Fill.UserPicture (Pathe & rngCell.Value & ".jpg")
End If
Next rngCell

'Set size for all pictures
For Each c In ActiveSheet.Comments
c.Shape.Width = 400
c.Shape.Height = 300
Next c

'Destroy reference\
Set c = Nothing
Set curWks = Nothing
Set rngCell = Nothing
Set rngSheet = Nothing

'Reset
Application.ScreenUpdating = True

'Normal exit
Exit Sub
'Errored out
endo:
'Destroy reference\
Set c = Nothing
Set curWks = Nothing
Set rngCell = Nothing
Set rngSheet = Nothing

'Reset
Application.ScreenUpdating = True

eMsg = MsgBox("Error number: " & Err.Number & " " & Err.Description, vbCritical)
End Sub

[Shazam]

Well done rbrhodes the code is perfect.


Thank you so much!