Effet loupe sur une cellule en deux temps

Le
Apitos
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.
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
Apitos
Le #24348551
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ér ique.

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(msoTextOrientationHorizonta l, 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 = msoTextEffectAlignmentStretchJus tify
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 Bo olean)
If Target.Count <> 1 Or Intersect(Target, [Rng]) Is Nothing Then Exit S ub
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
MichD
Le #24350561
Bonjour,

Tu voudrais quelque chose comme ceci :

http://cjoint.com/?BCAqsftIUB8



MichD
------------------------------------------
Publicité
Poster une réponse
Anonyme