Effet loupe sur une cellule

[apt]

Bonsoir à tous,

J'ai repris la démo loupe de Jacques Boisgontier.

Alors j'aimerais lors d'un clic sur une cellule réalisé un effet de loupe avec deux pas :

- Afficher un petit carré blanc au centre de la cellule en premier

- Puis afficher un grand carré avec des dimensions qui entoure toute la cellule active avec le texte.

J'espère avoir bien expliqué ma problématique.

Merci.

 

[Pierrot93]

Re : Effet loupe sur une cellule

Bonjour,

voir ici :
[XL-2007] Effet de loupe sur une cellule en deux temps - Forum des professionnels en informatique

 

[apt]

Effet de loupe sur une cellule en deux temps

Bonsoir,

Une nouvelle tentative.

Mais reste que j'aimerais voir le petit carré ensuite le grand (La loupe) ensuite centrer au milieu le contenu de la cellule active s'il est numérique.

Option Explicit
Const KShCom = "CmtSh"
Dim ShCom As Shape
Dim ShHg As Long

Private Sub CreateBigShape()
    On Error Resume Next
    With ShCom
        .DrawingObject.Font.Name = "Verdana"
        .DrawingObject.Font.Size = 13
        .Name = KShCom
        .Left = ActiveCell.Left - 10
        .Top = ActiveCell.Top - 10
    End With
End Sub
Private Sub CreateSmallShape()
    On Error Resume Next
    ActiveSheet.Shapes(KShCom).Delete
    Set ShCom = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 1, 1, 20, 20)
    With ShCom
        .Name = KShCom
        .Left = ActiveCell.Left + 7
        .Top = ActiveCell.Top + 7
    End With
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    On Error Resume Next
    With Target
        If .Count = 1 And Not Intersect(Target, [Rng]) Is Nothing Then
            If ShCom Is Nothing Then
                CreateSmallShape
                Application.Wait (Now + TimeValue("0:00:05"))
                CreateBigShape
            End If
            If Not ShCom.Visible Then Exit Sub
            CreateSmallShape
            Application.Wait (Now + TimeValue("0:00:05"))
            ShCom.Left = .Left - 8
            ShCom.Top = .Top - 8
            ShCom.Height = .Height + 18
            ShHg = .Height + 18
            ShCom.Width = .Width + 18
            ShCom.DrawingObject.Text = .Text
            ShCom.TextFrame.AutoSize = True
            ShCom.TextEffect.Alignment = msoTextEffectAlignmentStretchJustify
            If ShCom.Height < ShHg Then ShCom.Height = ShHg
        Else
            ShCom.Visible = msoFalse
        End If
    End With
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Count <> 1 Or Intersect(Target, [Rng]) Is Nothing Then Exit Sub
    If ShCom Is Nothing Then
        CreateSmallShape
        Application.Wait (Now + TimeValue("0:00:05"))
        CreateBigShape
    End If
    CreateSmallShape
    Application.Wait (Now + TimeValue("0:00:05"))
    With ShCom
        .Visible = Not .Visible
        If .Visible Then
            .Left = Target.Left - 8
            .Top = Target.Top - 8
            ShHg = Target.Height + 18
            .Width = Target.Width + 18
            .DrawingObject.Text = Target.Text
            .TextFrame.AutoSize = True
            .TextEffect.Alignment = msoTextEffectAlignmentCentered
            If .Height < ShHg Then .Height = ShHg
        End If
    End With
    Cancel = True
End Sub