'-------------------------------------------------------------------------------
 ' 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.
 '-------------------------------------------------------------------------------
 
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 Example() 
    If InsertPictureComment(ActiveSheet.Range("A1"), "C:\Test\PaleGreen.bmp", _ 
    overWrite:=True) Then 
        MsgBox "Picture inserted" 
    Else 
        MsgBox "Could not insert picture." 
    End If 
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 :
     '---------------------------------------------------------------------------
     
    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:
    If overWrite Then 
        Set cmnt = rng.Comment 
        If Not cmnt Is Nothing Then 
             'If comment found, then delete it:
            cmnt.Delete 
        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 
        strCmntName = lngIndx & imagePath 
        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