Thema: Farbänderung beim Kommentar-Indikator

StandardModule: Modul1

Sub test_fncCreateCommentIndicator()
    fncCreateCommentIndicator vbBlue, "pat"
End Sub

Private Function fncCreateCommentIndicator( _
   CommentIndicatorColor As Long, _
   CommentIndicatorName As String) As Boolean
   Dim IDnumber As Long
   Dim aCell As Range
   Dim aComment As Comment
   Dim aShape As Shape
   Dim aWorksheet As Worksheet
   Dim aWorkbook As Workbook
   fncCreateCommentIndicator = False
   If CommentIndicatorName = vbNullString Then GoTo ExitFunction
   On Error GoTo ExitFunction
   Set aWorkbook = ActiveWorkbook
   IDnumber = 0
   For Each aWorksheet In aWorkbook.Worksheets
      For Each aShape In aWorksheet.Shapes
         If Left(aShape.Name, Len(CommentIndicatorName)) = _
            CommentIndicatorName Then
            aShape.Delete
         End If
      Next aShape
      For Each aComment In aWorksheet.Comments
         Set aCell = aComment.Parent
         If InStr(1, aComment.Shape.TextFrame.Characters.Text, ":") > 0 Then
            If Left(aComment.Shape.TextFrame.Characters.Text, _
               InStr(1, aComment.Shape.TextFrame.Characters.Text, ":") - 1) = _
                  Application.UserName Then
               GoSub CreateCommentIndicator
            End If
         End If
      Next aComment
   Next aWorksheet
   fncCreateCommentIndicator = True
ExitFunction:
   On Error GoTo 0
   Set aCell = Nothing
   Set aComment = Nothing
   Set aShape = Nothing
   Set aWorksheet = Nothing
   Set aWorkbook = Nothing
   Exit Function
CreateCommentIndicator:
   Set aShape = aWorksheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
      Left:=aCell.Left + aCell.Width - 5, _
      Top:=aCell.Top, _
      Width:=5, _
      Height:=5)
   IDnumber = IDnumber + 1
   With aShape
      .Name = CommentIndicatorName & CStr(IDnumber)
      .IncrementRotation -180#
      .Fill.Visible = msoTrue
      .Fill.Solid
      .Fill.ForeColor.RGB = CommentIndicatorColor
      .Line.Visible = msoTrue
      .Line.Weight = 1
      .Line.Style = msoLineSingle
      .Line.DashStyle = msoLineSolid
      .Line.ForeColor.RGB = CommentIndicatorColor
      .Placement = xlMove
   End With
   Return
End Function

Beiträge aus dem Excel-Forum zu den Themen Allgemein und Kommentar