Effet loupe sur une cellule en deux temps

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 lou=
pe en deux temps :

1- Afficher en premier, un petit carré blanc au centre de la cellule acti=
ve.

2- Puis afficher un grand carré (loupe) avec des dimensions qui entoure t=
oute la cellule active avec le texte dedans.



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

Private Sub CreeShape()
On Error Resume Next
ActiveSheet.Shapes(KShCom).Delete
Set ShCom = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizonta=
l, 1, 1, ActiveCell.Width + 16, ActiveCell.Height + 16)
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 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 CreeShape
If Not ShCom.Visible Then Exit Sub
ShCom.Left = .Left - 10
ShCom.Top = .Top - 10
.Height = Target.Height + 16
.Width = Target.Width + 16
ShCom.DrawingObject.Text = .Text
Else
ShCom.Visible = msoFalse
End If
End With
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Bo=
olean)
If Target.Count <> 1 Or Intersect(Target, [Rng]) Is Nothing Then Exit S=
ub
If ShCom Is Nothing Then CreeShape
With ShCom
.Visible = Not .Visible
If .Visible Then
.Left = Target.Left - 10
.Top = Target.Top - 10
.Height = Target.Height + 16
.Width = Target.Width + 16
.DrawingObject.Text = Target.Text
End If
End With
Cancel = True
End Sub


Merci.