'
' The purpose of this macro is to insert a comment within the first cell
' of a line which starts with the text "Bookmark Info Start:" followed
' by some user input comment and ended with the text "Bookmark Info End"
' If this cell already has a comment this text will be inserted in front
' of the current text.
' If the currentl line is already bookmarked it will ask for clearing it
' and if the user decides to clear it the procedure clears it, but will
' retain any additional comment added for the current line, and calls
' itself to possibly define a new bookmark name for the current line.
' The procedure will also verify whether the bookmark requested does
' not exist already. If it does it will signal that and quit
'
' Fixed the handling of the row and comment height
'
' Macro created 14-06-2007 by Bob Becker Hof (HP)
' Tested with Excel 2003 and EVE 2.30 xls output format
'

Sub Comment_Bookmark_lines_Marking()

Dim crow As Long
Dim ccol As Long
Dim trow As Long
Dim tcol As Long
Dim lasrow As Long
Dim lascol As Long
Dim csname As String
Dim prgname As String

Dim msg As String
Dim Style As Long
Dim Title As String
Dim Response As Long

Dim Markline As Boolean                             ' Boolean used for flagging we found a match or not
Dim hidden_rows_behind_lasrow As Long

Dim currentcomment As String
Dim currentcommentmaxlen As Integer
Dim commentabsolutemaxlen As Integer
Dim commenttextstart As String
Dim commenttextend As String
Dim cmttext As String
Dim cmttextkey As String
Dim cmttextname As String
Dim commentcolumn As Integer
Dim commentvisablestate As Boolean
Dim currentrowheight As Long

Dim rng As Range

    Title = "Comment_Bookmark_lines_Marking"                       ' Define title.
    prgname = "%" + Title + ": "

    crow = ActiveCell.Row
    ccol = ActiveCell.Column
    lasrow = ActiveCell.SpecialCells(xlLastCell).Row
    lascol = ActiveCell.SpecialCells(xlLastCell).Column
    
    commenttextstart = "====== Bookmark Info ======"
    commenttextend = commenttextstart
    commentcolumn = 1
    currentcommentmaxlen = 255
    commentabsolutemaxlen = 1024
    commentvisablestate = True

' By default the xlLastCell.row funtion returns the last visible row
' But there might be more rows below it which are hidden so loop down until we hit a row which is NOT hidden
' Lets assume that 650000 is the maximum row number possible...
'
''    Debug.Print "Current Lasrow: " & Str(lasrow)
    For hidden_rows_behind_lasrow = lasrow To 650000 Step 1
        If Not (Range(Cells(hidden_rows_behind_lasrow + 1, 1).Address).EntireRow.Hidden) Then
            lasrow = hidden_rows_behind_lasrow
''            Debug.Print "New Lasrow    : " & Str(lasrow)
            Exit For
        End If
    Next

    csname = ActiveSheet.Name

    If Range(Cells(crow, commentcolumn).Address).EntireColumn.Hidden Then
        msg = "Do you want to unhide the first column for displaying the bookmarks?"    ' Define message.
        Style = vbYesNo + vbWarning + vbDefaultButton1     ' Define buttons.
        Response = MsgBox(msg, Style, Title)
        If Response = vbYes Then                            ' User chose Yes.
            Columns(commentcolumn).EntireColumn.Hidden = False
        End If
    End If
    
    Set rng = ActiveSheet.Cells(crow, commentcolumn)
    If Not (rng.Comment Is Nothing) Then
        currentcomment = rng.Comment.Text
''        Debug.Print prgname & "Cell at row " & crow & " column 1 has comment/bookmark set to """ & currentcomment & """ within worksheet " & csname
        If Left(currentcomment, Len(commenttextstart)) = commenttextstart Then
            If Len(currentcomment) > currentcommentmaxlen Then
                currentcomment = Left(currentcomment, currentcommentmaxlen - 3) & "..."
            End If
            msg = "Current row is already bookmarked to " & Chr(10) & currentcomment & Chr(10) & Chr(10) & "Replace current bookmark?"
            Style = vbYesNo + vbWarning + vbDefaultButton2      ' Define buttons.
'            Title = "Replace current bookmark"                  ' Define title.
            Response = MsgBox(msg, Style, Title)
            If Response = vbYes Then                            ' User chose Yes.
                currentcomment = Right(currentcomment, Len(currentcomment) - Len(commenttextstart))
                commentendpos = InStr(1, currentcomment, commenttextend)
                If commentendpos <> 0 Then
                    commentendpos = commentendpos + Len(commenttextend) - 1
                    If (commentendpos < Len(currentcomment)) Then
                        currentcomment = Right(currentcomment, Len(currentcomment) - commentendpos)
                    Else
                        currentcomment = ""
                    End If
                    If Left(currentcomment, 1) = Chr(10) Then
                        currentcomment = Right(currentcomment, Len(currentcomment) - 1)
                    End If
                End If
                
                If Len(currentcomment) <> 0 Then
                    rng.ClearComments
                    rng.AddComment Text:=currentcomment
                    rng.Comment.Shape.Placement = xlMoveAndSize
                Else
                    rng.Comment.Delete
                End If
                Comment_Bookmark_lines_Marking
            End If
            GoTo Finish
        End If
    End If
    
'
' Ask for unique marker name
'

    cmttextname = InputBox("Enter unique bookmark name without equal (=) sign:", Title)
    If cmttextname = "" Then
        GoTo Finish
    End If
    
'
' First define the unique starter for the bookmark
'
define_cmttextkey:
    cmttextname = UCase(cmttextname)
    cmttextkey = commenttextstart & Chr(10) & cmttextname & " = "

'
' Check whether the marker name entered is really unique
'
    
    For trow = 1 To lasrow Step 1
        Set rng = ActiveSheet.Cells(trow, commentcolumn)
        If Not (rng.Comment Is Nothing) Then
            currentcomment = rng.Comment.Text
''            Debug.Print prgname & "Cell at row " & crow & " column 1 has comment/bookmark set to " & Chr(10) & currentcomment & Chr(10) & "within worksheet " & csname
                        
            If Left(currentcomment, Len(cmttextkey)) = cmttextkey Then
                
                cmttextname = InputBox("Bookmark name '" + cmttextname + "' already exists at line " + Trim(Str(trow)) + "!" + Chr(10) + "Enter unique bookmark name without equal (=) sign:", Title)

                If cmttextname = "" Then
                    GoTo Finish
                End If
                GoTo define_cmttextkey
            End If
        End If
    Next

'
' Ask for optional extra info to be added
'
    
    cmttext = InputBox("Enter (optional) additional descriptive info for bookmark '" + cmttextname + "':", Title)
    cmttext = cmttextkey & cmttext & Chr(10) & commenttextend
    
'
' If we already have a comment within this cell add that to our marker
'

    Set rng = ActiveSheet.Cells(crow, commentcolumn)
    If Not (rng.Comment Is Nothing) Then
        currentcomment = rng.Comment.Text
    Else
        currentcomment = ""
    End If
    
    If currentcomment <> "" Then
        If Left(currentcomment, 1) = Chr(10) Then
            cmttext = cmttext & currentcomment
        Else
            cmttext = cmttext & Chr(10) & currentcomment
        End If
    End If
        
    If Len(cmttext) > commentabsolutemaxlen Then
        cmttext = Left(cmttext, commentabsolutemaxlen - 3) + "..."
    End If
    If (rng.Comment Is Nothing) Then
        rng.AddComment Text:=cmttext
    Else
        rng.ClearComments
        rng.AddComment Text:=cmttext
    End If
    
    rng.Comment.Visible = commentvisablestate
    rng.Comment.Shape.TextFrame.AutoSize = True 'Remove if you want to size it yourself
    rng.Comment.Shape.Placement = xlMoveAndSize

'
' Adjust row height based upon row and comment heigth
'
    Cells(crow, ccol).EntireRow.AutoFit
    currentrowheight = rng.EntireRow.RowHeight						' Save current row height
    rng.EntireRow.RowHeight = rng.Comment.Shape.Height		' Adjust current row height in accordance to the comment height
    rng.Comment.Shape.Height = rng.EntireRow.RowHeight		' Adjust the comment heigth back to the current row height has grown 
                                                          ' if the row was smaller and we need to remove that extra blank space
                                                          ' at the bottom of the comment
    If (rng.EntireRow.RowHeight < currentrowheight) Then  ' If the original row height was higher after the autofit we need
        rng.EntireRow.RowHeight = currentrowheight        ' to adjust the row heiight back to the original size
    End If
 
    Cells(crow, ccol).Select

Finish:

End Sub