Linked Picture; Add to Comment

[Kwong]

Dear All,

I'm preparing an organization chart with photos.

I have a list (or a column) with the full path file names of the pictures. Say in 'Sheet 2' Column A.

I want to display all those pictures in the particular cells under the organization chart. Say in 'Sheet 1'.

Anyone could help me please.

Cheers,

Kwong

[Oorang]

Sub Example()
InsertPicture Worksheets("Sheet1").range("b7"), "C:\Mypath\Oorang.gif"
End Sub

Private Sub InsertPicture(anchorRange As Excel.range, path As String)
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Set ws = anchorRange.Parent
Set wb = ws.Parent
wb.Activate
ws.Activate
anchorRange.Activate
ws.Pictures.Insert path
End Sub

[lenze]

Just an idle thought, but why not place the relative picture in a cell comment for the appropriate cell?

lenze

[Oorang]

Well, largely because AFAIK comments only support text :)

[lenze]

Well, largely because AFAIK comments only support text :)

You can place a picture in a cell comment. It's really quite easy!!
A Google seach will show you how.

But, in 2003
1. Insert Comment
2. Choose Edit Comment
3. Right Click Comment and choose Format Comment
4. On the Color and Lines tab of the dialog, under Fill, choose "Fill Effects"
5. Select the Picture Tab and select a picture.
6. Exit Out

lenze

[Oorang]

Oh Yah! I totally forgot about that one. I saw it a few years ago and thought "gee that's slick", then never used it.

Sub ExampleWithObjects()
Dim ws As Excel.Worksheet
Dim rng As Excel.Range
Dim cmnt As Excel.Comment
Dim shp As Excel.Shape
Set rng = Selection
Set ws = rng.Parent
Set cmnt = rng.AddComment
Set shp = cmnt.Shape
shp.Fill.UserPicture "C:\EmployeeAvatars\Oorang.gif"
End Sub

Sub ShortExample()
Selection.AddComment.Shape.Fill.UserPicture "C:\EmployeeAvatars\Oorang.gif"
End Sub

[Kwong]

Can I also set the size of the picture, please?

Kwong

[Oorang]

Yes, use the Width & Height properties of the shape object.

[Kwong]

Is it possible to remove all the old pictures in the existing worksheets?

Thanks,

Kwong

[Kwong]

Here's the code so far I made:

Sub Example()
Dim Sname As String, Srow As Integer, Scolumn As Integer, Fname As String, Srange As String
X = (Application.WorksheetFunction.CountA(Sheets("Details").[a:a]))
For i = 2 To X
Sname = Sheets("Details").Cells(i, 14)
Srow = Sheets("Details").Cells(i, 15)
Scolumn = Sheets("Details").Cells(i, 16)
Srange = GetXLCol(Scolumn - 1) & CStr(Srow)
Fname = Sheets("Details").Cells(i, 17) & Sheets("Details").Cells(i, 18)
Worksheets(Sname).Cells(Srow, Scolumn) = Null
InsertPicture Worksheets(Sname).Range(Srange), Fname
Next
End Sub

Private Sub InsertPicture(anchorRange As Excel.Range, path As String)
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Dim cmnt As Excel.Comment
Dim shp As Excel.Shape
Set ws = anchorRange.Parent
Set wb = ws.Parent
Set cmnt = anchorRange.AddComment
Set shp = cmnt.Shape
With shp
.Width = 40
.Height = 50
End With
wb.Activate
ws.Activate
anchorRange.Activate
shp.Fill.UserPicture path
End Sub

Private Function GetXLCol(Col As Integer) As String
' Col is the present column, not the number of cols
Const A = 65 'ASCII value for capital A
Dim iMults As Integer
Dim sCol As String
Dim iRemain As Integer
' THIS ALGORITHM ONLY WORKS UP TO ZZ. It fails on AAA
If Col > 701 Then
GetXLCol = ""
Exit Function
End If
If Col <= 25 Then
sCol = Chr(A + Col)
Else
iRemain = Int((Col / 26)) - 1
sCol = Chr(A + iRemain) & GetXLCol(Col _
Mod 26)
End If
GetXLCol = sCol
End Function

Using comment can adjust the size of the picture, but can I remove the arrow indicator and the shadow? And, how to move the comment?

Thanks,

Kwong

[grichey]

movings comments via rec:

myComment.ShapeRange.IncrementLeft -500 'where number is direction

[Kwong]

Thanks, I can move the comment now.

But how can i remove the drop shadow of the comment?

Also, how can I remove the old comments, because every time when this line runs:

Set cmnt = anchorRange.AddComment

If there exists previous comment, it returns an error.

How can I tackle it?

[Oorang]

To get rid of preexisting comments, pretest the range. To get rid of the drop shadow, choose a shape that doesn't have one.
Option Explicit

Public Sub Example()
Dim rng As Excel.Range
Dim cmnt As Excel.Comment
Dim shp As Excel.Shape
Set rng = Excel.ActiveSheet.Range("A1")
Set cmnt = rng.Comment
If Not cmnt Is Nothing Then
cmnt.Delete
End If
Set cmnt = rng.AddComment(" ")
Set shp = cmnt.Shape
shp.Fill.UserPicture "C:\Test\Oorang.gif"
shp.Height = 90
shp.Width = 90
shp.AutoShapeType = msoShapeRoundedRectangle
End Sub

[Kwong]

Thanks Aaron,

I can get rid of the pre-existing comments now. But the shadow still cannot be removed??? Even I used the rounded rectangle......

Kwong

[Oorang]

Yep you are right. I had tested using a picture with a solid black background and it was blending in with the drop shadow. Getting rid of that drop shadow turned out to be a lot harder than I was expecting. I had to dig into some less documented methods. But here you are:

Edit: Adding missing incrementer.
Edit2: Documented and modularized for addition to knowledge base. Thought I would post preview here.

'-------------------------------------------------------------------------------
' Module : CommentPictures
' Author : Aaron Bush
' Date : 07/24/2008
' Purpose : Contains procedures related to adding floating picture
' comments.
' References : Microsoft Excel XX.0 Object Library (Tested on 2003)
' Dependencies : No dependancies outside module.
' Revisions : 08/12/2008 Aaron Bush Added "SendLinkToPictures" sub to
' module. Updated Example sub to
' InsertPicturesub.
'-------------------------------------------------------------------------------

Option Explicit
'Option Private Module
Option Compare Binary
Option Base 0

'Setting this to True will turn off all error handling:
#Const m_blnErrorHandlersOff_c = False

Public Sub InsertPicture()

'---------------------------------------------------------------------------
' Procedure : InsertPicture
' Author : Aaron Bush
' Date : 08/12/2008
' Purpose : Inserts a picture into the selected cell.
' Remarks :
' Revisions :
'---------------------------------------------------------------------------

Dim strPicPath As String

'Conditionally Invoke Error Handler:
#If Not m_blnErrorHandlersOff_c Then
On Error GoTo Err_Hnd
#End If

strPicPath = Application.GetOpenFilename(Title:="Select Picture:")
If strPicPath = "False" Then
Exit Sub
End If
If InsertPictureComment(Selection, strPicPath, overWrite:=True) Then
MsgBox "Picture inserted"
Else
MsgBox "Could not insert picture."
End If

Exit Sub

'******* Error Handler *******
Err_Hnd:
MsgBox Err.Description, vbSystemModal, "Error: " & Err.Number

End Sub

Public Sub SendLinkToPicture()

'---------------------------------------------------------------------------
' Procedure : SendLinkToPictures
' Author : Aaron Bush
' Date : 08/12/2008
' Purpose : Loops through all selected cells and if a hyperlink is found
' it attempts to put the link into a comment/picuture.
' Remarks :
' Revisions :
'---------------------------------------------------------------------------

Dim rng As Excel.Range
Dim cll As Excel.Range

'Conditionally Invoke Error Handler:
#If Not m_blnErrorHandlersOff_c Then
On Error GoTo Err_Hnd
#End If

InterfaceOff
Set rng = Selection
Set rng = Intersect(rng, rng.parent.UsedRange)
If Not rng Is Nothing Then
For Each cll In rng.Cells
If cll.Hyperlinks.Count Then
InsertPictureComment cll, cll.Hyperlinks(1).Address, overWrite:=True
End If
Next
End If

'******* Exit Procedure *******
Exit_Proc:
'Supress Error Handling to Prevent Error-Loops:
On Error Resume Next
'Release Objects:
Set rng = Nothing
Set cll = Nothing
'Restore Interface
InterfaceOn
Exit Sub

'******* Error Handler *******
Err_Hnd:
MsgBox Err.Description, vbSystemModal, "Error: " & Err.Number
Resume Exit_Proc

End Sub

Public Function InsertPictureComment( _
ByRef anchorRange As Excel.Range, _
ByVal imagePath As String, _
Optional ByVal imageHeight As Long = 90, _
Optional ByVal imageWidth As Long = 90, _
Optional ByVal overWrite As Boolean = False _
) As Boolean

'---------------------------------------------------------------------------
' Procedure : InsertPictureComment
' Author : Aaron Bush
' Date : 07/24/2008
' Purpose : Inserts a picture that floats like a comment.
' Input(s) : anchorRange - The cell that you want to place a comment on.
' If more than one cell is specified, the first
' cell in the range will be used.
' imagePath - The path to the image you want to use.
' imageHeight - Optional. Sets the height of the image.
' imageWidth - Optional. Sets the width of the image.
' overWrite - Optional. If a comment already exists in cell
' specified by anchorRange and overWrite is true
' then the comment will be overwritten. Otherwise
' an exception will be thrown.
' Output(s) : True if procedure completed correctly. False if error
' was encountered.
' Remarks :
' Revisions : 08/12/2008 Aaron Bush Added comment name truncation to
' prevent error that occurs when names
' greater than 32 chars are used.
'---------------------------------------------------------------------------

Const lngMaxNameLen_c As Long = 32
Const strSpace_c As String = " "
Const lngOne_c As Long = 1

Dim strCmntName As String
Dim rng As Excel.Range
Dim cmnt As Excel.Comment
Dim shp As Excel.Shape
Dim xltbx As Excel.TextBox
Dim lngIndx As Long
Dim blnRtnVal As Boolean

'Conditionally Invoke Error Handler:
#If Not m_blnErrorHandlersOff_c Then
On Error GoTo Err_Hnd
#End If

'Prevents errors caused by multicell references:
Set rng = anchorRange.Cells(lngOne_c, lngOne_c)

'If overwrites are allowed check for pre-existing comments:
Set cmnt = rng.Comment
If Not cmnt Is Nothing Then
If overWrite Then
'If comment found, then delete it:
cmnt.Delete
Else
Err.Raise vbObjectError, Description:="'" & rng.parent.name & "'!" _
& rng.Address & " already has a comment."
End If
End If

'Cannot create comment with vbnullstring, so use a space:
Set cmnt = rng.AddComment(strSpace_c)

'Load picture into comment's shape background:
Set shp = cmnt.Shape
shp.Fill.UserPicture imagePath
'Set size of comment/picture:
shp.Height = imageHeight
shp.Width = imageWidth

'To get a textbox object (needed later) comment must be named. This
'generates a unique name:
On Error Resume Next
Do
Err.Clear
'An error will be thrown if you try to use a name greater than 32 chars:
strCmntName = Left$(lngIndx & imagePath, lngMaxNameLen_c)
shp.name = strCmntName
lngIndx = lngIndx + lngOne_c
Loop Until Not CBool(Err)
#If m_blnErrorHandlersOff_c Then
On Error GoTo 0
#Else
On Error GoTo Err_Hnd
#End If

'Get textbox object using name:
Set xltbx = GetTextbox(rng.parent, strCmntName)
'Kill dropshadow:
xltbx.ShapeRange.Shadow.Visible = False

'Flag procedure as complete:
blnRtnVal = True

'******* Exit Procedure *******
Exit_Proc:
'Supress Error Handling to Prevent Error-Loops:
On Error Resume Next
'Release Objects:
Set rng = Nothing
Set cmnt = Nothing
Set shp = Nothing
Set xltbx = Nothing


'Set Return Value:
InsertPictureComment = blnRtnVal
Exit Function

'******* Error Handler *******
Err_Hnd:
blnRtnVal = False
MsgBox Err.Description, vbSystemModal, "Error: " & Err.Number
Resume Exit_Proc
Resume

End Function

Private Function GetTextbox( _
ByRef parent As Excel.Worksheet, _
ByVal name As String _
) As Excel.TextBox

'---------------------------------------------------------------------------
' Procedure : GetTextbox
' Author : Aaron Bush
' Date : 07/24/2008
' Purpose : Gets an Excel.Textbox object by name.
' Input(s) : parent - The worksheet that has the Excel.Textbox Object you
' are looking for.
' name - The name of the Excel.Textbox object you are looking
' for.
' Output(s) : An Excel.Textbox object.
' Remarks : Not case sensitive. If object not found or error encountered
' output is "Nothing".
' Revisions :
'---------------------------------------------------------------------------

Const lngLwrBnd_c As Long = 1
Dim xltbx As Excel.TextBox
Dim strName As String
Dim lngUprBnd As Long
Dim lngIndx As Long

'Conditionally Invoke Error Handler:
#If Not m_blnErrorHandlersOff_c Then
On Error GoTo Err_Hnd
#End If

'Force name to lower case for comparison:
strName = LCase$(name)
'Stay away from looping using "For Each" as the Excel.Textboxes collection
'isn't implemented quite right in XL2003:
lngUprBnd = parent.TextBoxes.Count
For lngIndx = lngLwrBnd_c To lngUprBnd
Set xltbx = parent.TextBoxes(lngIndx)
If LCase$(xltbx.name) = strName Then
'Found target, exit loop:
Exit For
End If
Next
If lngIndx > lngUprBnd Then
Set GetTextbox = Nothing
End If

'******* Exit Procedure *******
Exit_Proc:
'Supress Error Handling to Prevent Error-Loops:
On Error Resume Next
'Set Return Value:
Set GetTextbox = xltbx
'Release Objects:
Set xltbx = Nothing

Exit Function

'******* Error Handler *******
Err_Hnd:
Set xltbx = Nothing
'Fail silently.
Resume Exit_Proc
End Function

Private Sub InterfaceOff()
On Error Resume Next
With Excel.Application
.EnableCancelKey = xlErrorHandler
.Cursor = xlWait
.StatusBar = "Working..."
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub

Private Sub InterfaceOn()
On Error Resume Next
With Excel.Application
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.Cursor = xlDefault
.StatusBar = False
.EnableCancelKey = xlInterrupt
End With
End Sub