PDA

View Full Version : [SOLVED] VBA to select picture in a comment



primaryteach
01-08-2010, 05:18 AM
Hi everyone and Happy New Year.

I would like to be able to add any picture to any cell in a comment box (as a fill). I used the macro recorder which generated the code below.

However, it has two problems:

1) It refers to a specific file on my hard drive. How do I change the code so that I can choose which picture I want each time?

2) The macro recorder has hard-coded the cell reference for the comment. Is there a way to change the code so that when the macro runs, it adds the comment to the cell that is currently selected?

I will need my hand held through this, as my VBA knowledge is very poor!

Thanks,

Simon


Sub addpicture()
' addpicture Macro
Range("I18").Select
Range("I18").AddComment
Range("I18").Comment.Visible = False
Range("I18").Comment.Text Text:="" & Chr(10) & ""
Range("I18").Select
ActiveCell.Comment.Visible = True
Range("I18").Comment.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)
Selection.ShapeRange.Fill.UserPicture _
"C:\Users\Simon\Pictures\Building blocks2.gif"
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 127.5
Selection.ShapeRange.Width = 283.5
Range("I18").Select
ActiveCell.Comment.Visible = False
End Sub

Bob Phillips
01-08-2010, 06:05 AM
Sub addpicture()
Dim fName As String
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
If .Show = -1 Then
fName = .SelectedItems(1)
Else
Exit Sub
End If
End With
With ActiveCell
.AddComment
.Comment.Text Text:="" & Chr(10) & ""
.Comment.Visible = True
With .Comment.Shape
.Fill.Transparency = 0#
.Line.Weight = 0.75
.Line.DashStyle = msoLineSolid
.Line.Style = msoLineSingle
.Line.Transparency = 0#
.Line.Visible = msoTrue
.Line.ForeColor.RGB = RGB(0, 0, 0)
.Line.BackColor.RGB = RGB(255, 255, 255)
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Fill.BackColor.RGB = RGB(255, 255, 225)
.Fill.UserPicture fName
.LockAspectRatio = msoFalse
.Height = 127.5
.Width = 283.5
End With
.Comment.Visible = False
End With
End Sub

Bob Phillips
01-08-2010, 06:06 AM
A tad better


Sub addpicture()
Dim fName As String
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
If .Show = -1 Then
fName = .SelectedItems(1)
Else
Exit Sub
End If
End With
With ActiveCell
.AddComment
With .Comment
.Text Text:="" & Chr(10) & ""
.Visible = True
With .Shape
.Fill.Transparency = 0#
.Line.Weight = 0.75
.Line.DashStyle = msoLineSolid
.Line.Style = msoLineSingle
.Line.Transparency = 0#
.Line.Visible = msoTrue
.Line.ForeColor.RGB = RGB(0, 0, 0)
.Line.BackColor.RGB = RGB(255, 255, 255)
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Fill.BackColor.RGB = RGB(255, 255, 225)
.Fill.UserPicture fName
.LockAspectRatio = msoFalse
.Height = 127.5
.Width = 283.5
End With
.Visible = False
End With
End With
End Sub

primaryteach
01-08-2010, 06:56 AM
Thanks XLD, this is brilliant.

primaryteach
01-15-2010, 02:43 AM
I've used XLD's code, works fine in Excel 2007. However, when I try to use it in Excel 2000 (including a new file with no other vba code or content) it gives me the following message:

Run Time Error '438'

Object doesn't support this property or method.


When I run the debug is highlights the following line of code:


With Application.FileDialog(msoFileDialogOpen)

What is going on? Why is it not working? Any help gratefully received.


Simon

Bob Phillips
01-15-2010, 02:54 AM
FileDialog was introduced in Excel 2000 (if my memory serves me well), so you need to use something else. Lookup GetOpenFilename in help, that works in 2000

primaryteach
01-15-2010, 04:16 AM
XLD, I've tried to use GetOpenFilename command without success - I just mess up the code you have already given. I think I might need to be spoon fed this, as my VBA knowledge is so poor. Sorry.

Bob Phillips
01-15-2010, 08:46 AM
Sub addpicture()
Dim fName As String
fName = Application.GetOpenFilename("All Files (*.*), *.*")
If fName <> "False" Then
With ActiveCell
.AddComment
With .Comment
.Text Text:="" & Chr(10) & ""
.Visible = True
With .Shape
.Fill.Transparency = 0#
.Line.Weight = 0.75
.Line.DashStyle = msoLineSolid
.Line.Style = msoLineSingle
.Line.Transparency = 0#
.Line.Visible = msoTrue
.Line.ForeColor.RGB = RGB(0, 0, 0)
.Line.BackColor.RGB = RGB(255, 255, 255)
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Fill.BackColor.RGB = RGB(255, 255, 225)
.Fill.UserPicture fName
.LockAspectRatio = msoFalse
.Height = 127.5
.Width = 283.5
End With
.Visible = False
End With
End With
End If
End Sub

primaryteach
01-15-2010, 11:46 AM
This is brilliant XLD - really grateful.
Just a quick thought. Is it possible to code it so you are unable to add the comment (picture) if someone has already added a comment to that particular cell? At present, if this happens an error message occurs.

Simon

Bob Phillips
01-15-2010, 05:33 PM
Sub addpicture()
Dim fName As String
Dim cellComment As Comment
fName = Application.GetOpenFilename("All Files (*.*), *.*")
If fName <> "False" Then
With ActiveCell
On Error Resume Next
Set cellComment = .Comment
On Error GoTo 0
If cellComment Is Nothing Then
.AddComment
With .Comment
.Text Text:="" & Chr(10) & ""
.Visible = True
With .Shape
.Fill.Transparency = 0#
.Line.Weight = 0.75
.Line.DashStyle = msoLineSolid
.Line.Style = msoLineSingle
.Line.Transparency = 0#
.Line.Visible = msoTrue
.Line.ForeColor.RGB = RGB(0, 0, 0)
.Line.BackColor.RGB = RGB(255, 255, 255)
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Fill.BackColor.RGB = RGB(255, 255, 225)
.Fill.UserPicture fName
.LockAspectRatio = msoFalse
.Height = 127.5
.Width = 283.5
End With
.Visible = False
End With
End If
End With
End If
End Sub


You could always just delete any existing comment in the code.

primaryteach
01-16-2010, 01:50 AM
Thanks again XLD. Your help has been invaluable.