Option
Explicit
Public
Sub
Test()
Dim
rngS
As
Excel.Range
Dim
rngT
As
Excel.Range
Set
rngS = Range(
"A2"
)
Set
rngT = Range(
"C2"
)
rngT.Value =
"Kommentar"
Call
rngT.EntireColumn.AutoFit
rngS.Value =
"Ey, hallo Du da!"
rngS.Characters(5, 6).Font.Italic =
True
rngS.Characters(11, 2).Font.Bold =
True
rngS.Characters(11, 2).Font.Underline = xlUnderlineStyleSingle
Call
rngS.EntireColumn.AutoFit
If
Not
rngT.Comment
Is
Nothing
_
Then
Call
rngT.Comment.Delete
Call
CommentAppend(rngT,
"Überschrift"
, Bold:=
True
)
Call
CommentAppend(rngT, vbNewLine & Space$(3))
Call
CommentAppend(rngT,
"* Punkt-1"
, Italic:=
True
)
Call
CommentAppend(rngT, vbNewLine & Space$(3))
Call
CommentAppend(rngT,
"* Punkt-2"
, Bold:=
True
)
Call
CommentAppend(rngT, vbNewLine & Space$(3))
Call
CommentAppend(rngT,
"* Punkt-3"
, Italic:=
True
, Underline:=xlUnderlineStyleSingle)
Call
CommentAppend(rngT, vbNewLine & Space$(3))
Call
CommentAppend(rngT,
"* Punkt-4"
, Bold:=
True
, Italic:=
True
, Underline:=xlUnderlineStyleDouble)
Call
CommentAppend(rngT, vbNewLine & vbNewLine)
Call
CommentAppend(rngT, rngS)
rngT.Comment.Shape.TextFrame.AutoSize =
True
End
Sub
Public
Sub
CommentAppend( _
Target
As
Excel.Range, _
Source
As
Variant
, _
Optional
ByVal
Bold
As
Variant
, _
Optional
ByVal
Italic
As
Variant
, _
Optional
ByVal
Underline
As
Variant
_
)
Const
ERR_INVALID_ARG
As
Long
= 5
Dim
rngSrc
As
Excel.Range
Dim
lngLenPrev
As
Long
If
IsObject(Source)
Then
If
Source
Is
Nothing
Then
Call
Err.Raise(ERR_INVALID_ARG)
ElseIf
TypeOf
Source
Is
Excel.Range
Then
If
Source.Cells.Count = 1
Then
If
IsMissing(Bold)
Then
Bold =
True
If
IsMissing(Italic)
Then
Italic =
True
If
IsMissing(Underline)
Then
Underline =
True
Set
rngSrc = Source
Call
CommentAppendR(Target, rngSrc,
CBool
(Bold),
CBool
(Italic),
CBool
(Underline))
Else
Call
Err.Raise(ERR_INVALID_ARG)
End
If
Else
Call
Err.Raise(ERR_INVALID_ARG)
End
If
Else
If
Target.Comment
Is
Nothing
Then
Call
Target.AddComment(Text:=
CStr
(Source))
Else
lngLenPrev = Len(Target.Comment.Text)
Call
Target.Comment.Text(Text:=
CStr
(Source), Start:=lngLenPrev + 1)
End
If
With
Target.Comment.Shape.TextFrame.Characters(lngLenPrev + 1, Len(
CStr
(Source))).Font
.Underline = IIf(IsMissing(Underline), xlUnderlineStyleNone,
CLng
(Underline))
.Italic = IIf(IsMissing(Italic),
False
,
CBool
(Italic))
.Bold = IIf(IsMissing(Bold),
False
,
CBool
(Bold))
End
With
End
If
End
Sub
Private
Sub
CommentAppendR( _
Target
As
Excel.Range, _
Source
As
Excel.Range, _
ApplyBold
As
Boolean
, _
ApplyItalic
As
Boolean
, _
ApplyUnderline
As
Boolean
_
)
Dim
objCharSrc
As
Excel.Characters
Dim
lngLenPrev
As
Long
Dim
i
As
Long
If
Target.Comment
Is
Nothing
Then
Call
Target.AddComment(Text:=Source.Text)
Else
lngLenPrev = Len(Target.Comment.Text)
Call
Target.Comment.Text(Text:=Source.Text, Start:=lngLenPrev + 1)
End
If
With
Target.Comment.Shape.TextFrame
For
i = 1
To
Source.Characters.Count
Set
objCharSrc = Source.Characters(i, 1)
With
.Characters(lngLenPrev + i, 1).Font
.Underline = IIf(ApplyUnderline, objCharSrc.Font.Underline, xlUnderlineStyleNone)
.Italic = IIf(ApplyItalic, objCharSrc.Font.Italic,
False
)
.Bold = IIf(ApplyBold, objCharSrc.Font.Bold,
False
)
End
With
Next
End
With
End
Sub