Sub test()
AfficheCmt Range("c10"), True, "Il était une fois dans l'ouest", vbBlue
End Sub
Function AfficheCmt(cel, cond, msg, coul)
Dim TB As Excel.TextBox
Dim f As Worksheet
'---
Application.Volatile
On Error Resume Next
Set f = Sheets(Application.Caller.Parent.Name)
If Err <> 0 Then
Set f = ActiveSheet
Err.Clear
End If
On Error GoTo 0
If Not cel.Comment Is Nothing Then cel.Comment.Delete
If cond Then
With cel
If .Comment Is Nothing Then .AddComment
.Comment.Shape.Width = Len(msg) * 6 + 2
.Comment.Shape.Height = 20
.Comment.Shape.Left = .Left + .Width + 5
.Comment.Shape.Top = .Top - 2
.Comment.Visible = True
.Comment.Text Text:=msg
'--- (object Excel.TextBox) ---
Set TB = .Comment.Shape.OLEFormat.Object
'/// Fond (object FillFormat) ///
With TB.ShapeRange.Fill
.ForeColor.RGB = coul 'La couleur du fond
'retirer la quote pour obtenir la transparence
' .Transparency = 0.5 'Transparence
End With
'/// Encadrement (object LineFormat) ///
With TB.ShapeRange.Line
.Weight = 3# 'Un encadrement de 3
.ForeColor.RGB = vbRed 'La couleur de cet encadrement
End With
'/// Police (object Font) ///
With TB.Font
.Name = "Comic sans MS" 'La police
.ColorIndex = 6 'La couleur de cette police
.Size = 12 'La taille de cette police
.Bold = True
.Italic = True
End With
End With
End If
AfficheCmt = ""
End Function