PDA

View Full Version : Solved: Insert comment pictures fill down.



Shazam
05-10-2008, 10:04 AM
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
05-10-2008, 04:30 PM
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
05-10-2008, 06:41 PM
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
05-11-2008, 03:25 PM
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
05-12-2008, 06:11 AM
Well done rbrhodes the code is perfect.


Thank you so much!