Attribute VB_Name = "Modul11"
Option Explicit

'entwickelt von Winfried Radner
'e-mail: Wolf.W.Radzinski@onlinehome.de
'Benutzung frei - ohne Gewähr

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+
'+   Kommentare OHNE Usernamen hinzufügen
'+   copy & paste für Kommentare
'+   leeren Kommentar zur Zelle hinzufügen
'+   Usernamen auch aus der Statusanzeige für Kommentar entfernen
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++

'globale Variablen
Public c_txt As String
Public c_copy As Boolean
Public r_inhalt As String


'+++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+   entfernt den "Usernamen:" aus allen Kommentaren
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++

'Text nimmt Format der Überschrift an!
Public Sub del_author_all()
   Dim c As Comment
   Dim del_str As Long
   For Each c In ActiveSheet.Comments
      del_str = Len(c.Author) + 2
         If InStr(1, c.Text, c.Author) > 0 Then
             c.Text Text:=Right(c.Text, Len(c.Text) - del_str)
             End If
      Next
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+   entfernt den "Usernamen:" aus dem Kommentar
'+   der aktiven Zelle
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++

Public Sub del_author_activecomment()
   Dim c As Comment
   Dim del_str As Long
   For Each c In ActiveSheet.Comments
      If c.Parent.Address = ActiveCell.Address Then
         del_str = Len(c.Author) + 2
         If InStr(1, c.Text, c.Author) > 0 Then
             c.Text Text:=Right(c.Text, Len(c.Text) - del_str)
             End If
         End If
      Next
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+   entfernt den "Usernamen:" aus allen Kommentaren
'+   und aus der angezeigten Statusbarmeldung
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++

Public Sub del2_author_all()
    change_user_to_zero_all
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+   entfernt den "Usernamen:" aus dem Kommentar
'+   der aktiven Zelle und aus der angezeigten Statusbarmeldung
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++

Public Sub del2_author_activecomment()
    change_user_to_zero_activecell
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+   nur intern benutze Prozedur ...
'+   aufgerufen durch del2_author_all
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++

Private Sub change_user_to_zero_all(Optional temp_user As String = " ")
   Dim c As Comment
   Dim nl As String
   Dim user As String
   Dim x As String
   Dim temp As String
   Dim del_str As Long
   nl = Chr(10)
   'hiermit wird verhindert, daß der User in der
   'Statuszeile genannt wird
   'zwischenspeichern
   user = Application.UserName
   'ändern oder chr(32) einsetzen NUR KEIN NULLstring
   If IsMissing(temp_user) Then temp_user = " "
   Application.UserName = temp_user
   For Each c In ActiveSheet.Comments
      del_str = InStr(1, c.Text, nl)
      If InStr(1, c.Text, c.Author) > 0 Then
          temp = Right(c.Text, Len(c.Text) - del_str)
          Else
          temp = c.Text
          End If
      x = c.Parent.Address
      c.Delete
      Range(x).AddComment temp
      Next
   'alten Usernamen zurückholen
   Application.UserName = user
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+   nur intern benutze Prozedur ...
'+   aufgerufen durch del2_author_activecomment
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++

Private Sub change_user_to_zero_activecell(Optional temp_user As String = " ")
   Dim c As Comment
   Dim nl As String
   Dim user As String
   Dim x As String
   Dim temp As String
   Dim del_str As Long
   nl = Chr(10)
   'hiermit wird verhindert, daß der User in der
   'Statuszeile genannt wird
   'zwischenspeichern
   user = Application.UserName
   'ändern oder chr(32) einsetzen NUR KEIN NULLstring
   If IsMissing(temp_user) Then temp_user = " "
   Application.UserName = temp_user
   
   For Each c In ActiveSheet.Comments
      If c.Parent.Address = ActiveCell.Address Then
          del_str = InStr(1, c.Text, nl)
          If InStr(1, c.Text, c.Author) > 0 Then
              temp = Right(c.Text, Len(c.Text) - del_str)
              Else
              temp = c.Text
              End If
          x = c.Parent.Address
          c.Delete
          Range(x).AddComment temp
          End If
       Next
   'alten Usernamen zurückholen
   Application.UserName = user
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+   H.Herber's Lösung mit Inputbox
'+   fehlerbereinigt für den Fall der Auswahl einer
'+   bereits kommentierten Zelle
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++

Sub Kommentar()
On Error GoTo err_kommentar
Dim TMP$
Dim user As String
    With ActiveCell
'existiert schon ein Kommentar?
        If Len(.Comment.Text) > 0 Then
            Exit Sub
'wenn NEIN tritt ein Fehler ein!
err_kommentar:
            TMP = InputBox("Bitte Kommentar eingeben:")
'hiermit wird verhindert, daß der User in der
'Statuszeile genannt wird
            'zwischenspeichern
            user = Application.UserName
            'ändern oder chr(32) einsetzen NUR KEIN NULLstring
            Application.UserName = "unknown user"
            'Kommentar hinzufügen
            .AddComment TMP
            'alten Usernamen zurückholen
            Application.UserName = user
            Resume Next
            End If
    End With
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+   kopiere den Kommentar der aktiven Zelle
'+   in die globale Variable c_txt und
'+   setze bei Erfolg c_copy auf True
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++

Sub copy_comment()
On Error GoTo err_copy_comment
    c_txt = ActiveCell.Comment.Text
    c_copy = True
    Exit Sub
err_copy_comment:
    c_txt = ""
    c_copy = False
    MsgBox "Keinen Kommentar gefunden!"
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+   erzeuge wenn möglich für jedes selektierte Feld
'+   einen Kommentar mit dem Textinhalt
'+   der globalen Variablen c_txt
'+   existierende Kommentare werden überschrieben
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++

Sub paste_comment()
On Error GoTo err_paste_comment
   Dim r As Range
   If Not c_copy Then Exit Sub
   For Each r In Selection
          r.AddComment c_txt
          r.Comment.Visible = False
      Next
      Exit Sub
err_paste_comment:
    r.Comment.Delete
    r.AddComment c_txt
    Resume Next
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+   erzeuge wenn möglich für jedes selektierte Feld
'+   einen Kommentar mit dem Textinhalt
'+   der globalen Variablen c_txt
'+   existierende Kommentare bleiben erhalten
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++

Sub paste_special_comment()
On Error GoTo err_paste_special_comment
   Dim r As Range
   If Not c_copy Then Exit Sub
   For Each r In Selection
          r.AddComment c_txt
          r.Comment.Visible = False
      Next
      Exit Sub
err_paste_special_comment:
    Resume Next
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+   erzeuge wenn möglich für jedes selektierte Feld
'+   einen Kommentar OHNE Inhalt
'+   bereits existierende Kommentare bleiben erhalten
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++

Sub add_empty_comment_sc()
On Error GoTo err_add_empty_comment
   Dim r As Range
   c_txt = ""
   For Each r In Selection
          r.AddComment c_txt
          r.Comment.Visible = False
      Next
      Exit Sub
err_add_empty_comment:
    Resume Next
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+   kopiert den Textinhalt einer Selection
'+   in die globale Variable r_inhalt
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++

Sub copy_inhalt()
Dim r As Range
r_inhalt = ""
  For Each r In Selection
     r_inhalt = r_inhalt & r.Text & " "
     Next
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+   fügt r_inhalt als Kommentar
'+   zu allen selektierten Zellen hinzu
'+   evtl. vorhandene Kommentare werden vorher gelöscht
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++

Sub paste_inhalt()
Dim r As Range
  For Each r In Selection
          r.ClearComments
          r.AddComment r_inhalt
      Next
  r_inhalt = ""
End Sub