Encore une Hitoire de commentaire faite par @+Thie

[Jack]

Bonjour le forum,

Dans ce code du grand Thierry, Les formes de certains commentaires ne sont pas juste à côté de la cellule, (quand on ne veut pas que le commentaire soit visible) mais je n'arrive pas à comprendre à quoi cela est dù.
Pouvez vous m'éclarer?
Merci et bonne journée.
Jack

 

[Jack]

Re bonjour,

C'est un fichier de '@+Thierry 19/04/2005

Lien supprimé

@+
Jack

 

[_Thierry]

Bonjour Jack, le Forum

Je n'ai pas vraiment saisi ton problème ? Cette Démo 'Fun' est surtout la suite d'une démo plus sérieuse...

Pour la position d'un comment, tu peux par exemple faire ceci : (mais attention toutefois, les Shapes Loufoques que j'utilisent ici peuvent déborder de manière imprévue)

With .Comment.Shape

'ici pour Forcer la taille du Commentaire
.Height = TailleHaut
.Width = TailleLarge

'ici pour la position du commentaire
.Top = Target.Top
.Left = Target.Left + Target.Width

On peut aussi indiquer un position absolue :

'ici pour la position du commentaire
.Top = 90
.Left = 120


Bonne Journée (T.G.I.F.)
[ol]@+Thierry[/ol]

 

[Jack]

Bonjour Thierry, le forum,

j'ai essayé ton code pour une position absolue, mais il me met une erreur me disant que la référence est incorecte ou non qualifiée et il met en contraste le '.Comment' de la ligne
With .Comment.Shape
??
Pour répondre à ta question consernant mon Pb, j'aimerais que mon commentaire s'affiche où je veux. Par exemple dans ton Appli. si tu choisis '3', le commentaire est juste à côté (la flèche est courte), par contre si tu choisis '8', la flèche est plus longue. Bien sûr le commentaire n'étant pas visible.
j'espere avoir été plus clair sur mon Pb et je te remercie de te penché dessus. Bonne journée.
Jack

 

[_Thierry]

Bonsoir Jack, le Forum

Non, j'ai la très nette impression que tu n'as pas récupéré l'intégralité du code fourni dans la Démo que tu as mise en lien...

La Ligne :
With .Comment.Shape

Est, bien entendu, subordonnée à la présense d'un With Primaire contenant un Objet Range... (Ici With Range('A1'))

Voici l'intégralité du code :

Option Explicit

'@+Thierry sur www.Excel-Downloads.Com, April 2005
Private Sub Worksheet_Change(ByVal Target As Range)
Dim RangeSetting As Range, Cell As Range
Dim IndexCouleurRGB As Long, IndexCouleur As Long
Dim MessageAlerte As String, FontName As String
Dim IsItalic As Boolean, IsBold As Boolean
Dim RangeRef As Range, ShapeForm As String
Dim FontSize As Integer

Dim TailleHaut As Integer, TailleLarge As Integer

If Me.CheckBox1 = True Then
TailleHaut = Range('C15')
TailleLarge = Range('C16')
End If
       
    If Target.Address(0, 0) = 'A5' Then
    Set RangeSetting = Range('F14:F' & Range('F50').End(xlUp).Row)
        With Range('A1')
            If Not .Comment Is Nothing Then .ClearComments
            For Each Cell In RangeSetting
                If Target.Value = Cell Then
                  Set RangeRef = Cell.Offset(0, 1)
                   
                    'Ici touts les paramétrages de Format
                    IndexCouleurRGB = RangeRef.Interior.Color
                    IndexCouleur = RangeRef.Font.ColorIndex
                    FontName = RangeRef.Font.Name
                    FontSize = RangeRef.Font.Size
                    IsItalic = RangeRef.Font.Italic
                    IsBold = RangeRef.Font.Bold
                    MessageAlerte = RangeRef
                    ShapeForm = IIf(ShapeFinder(Cell.Offset(0, 2)) DIFFERENT DE '', ShapeFinder(Cell.Offset(0, 2)), 1)
                    .AddComment
                    .Comment.Text Text:=MessageAlerte
                   
                            .Comment.Visible = Me.CheckBox2
                           
                            With .Comment.Shape

                                'ici pour Forcer la taille du Commentaire
                                .Height = TailleHaut
                                .Width = TailleLarge
                               
                                'ici pour la position du commentaire
                                .Top = Target.Top
                                .Left = Target.Left + Target.Width

                                    On Error Resume Next 'si on dessine un shape non supporté
                                    .AutoShapeType = ShapeForm
                                    On Error GoTo 0
                                With .Fill
                                    .ForeColor.RGB = IndexCouleurRGB
                                    .Transparency = 0
                                End With
                               
                                With .TextFrame
                                .AutoSize = Not Me.CheckBox1
                               
                                    With .Characters(1, Len(MessageAlerte)).Font
                                        .Name = FontName
                                        .Bold = IsBold
                                        .Italic = IsItalic
                                        .Size = FontSize
                                        .ColorIndex = IndexCouleur
                                    End With
                                End With
                            End With
                    Exit For
                End If
            Next
        End With
    End If
End Sub


Private Function ShapeFinder(ByRef TopAddress As Range) As String
Dim ShapeObject As Shape
    For Each ShapeObject In Me.Shapes
      If ShapeObject.TopLeftCell.Address = TopAddress.Address Then
        ShapeFinder = ShapeObject.AutoShapeType
        Exit For
      End If
    Next
End Function

Pour le reste 'Bien sûr le commentaire n'étant pas visible' je ne saisis pas vraiment la finalité de ce que tu veux obtenir ? Juste des Flèches ? dans ce cas utilise un Shape 'AddLine'....

comme ceci :

Sub MyArrowWhereIWant()
Dim MyWS As Worksheet
Dim BeginYLeft As Long, BeginXTop As Long
Dim EndYLeft As Long, EndYTop As Long

With ActiveCell
    BeginYLeft = .Left + .Width
    BeginXTop = .Top + .Height
End With

With Range('H21')
    EndYLeft = .Left + .Width
    EndXTop = .Top + .Height
End With

Set MyWS = ActiveSheet

With MyWS.Shapes.AddLine(BeginYLeft, BeginXTop, EndYLeft, EndXTop).Line
    .DashStyle = msoLineDashDotDot
    .ForeColor.RGB = RGB(50, 0, 128)
    .BeginArrowheadLength = msoArrowheadShort
    .BeginArrowheadStyle = msoArrowheadOval
    .BeginArrowheadWidth = msoArrowheadNarrow
    .EndArrowheadLength = msoArrowheadLong
    .EndArrowheadStyle = msoArrowheadTriangle
    .EndArrowheadWidth = msoArrowheadWide
End With
End Sub

Bonne Soirée
[ol]@+Thierry[/ol]