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.
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.
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
Tu voudrais quelque chose comme ceci :
http://cjoint.com/?BCAqsftIUB8
MichD
------------------------------------------