J'ai repris la d=E9mo loupe de Jacques Boisgontier.
Alors j'aimerais lors d'un clic sur une cellule r=E9alis=E9 un effet de lou=
pe en deux temps :
1- Afficher en premier, un petit carr=E9 blanc au centre de la cellule acti=
ve.
2- Puis afficher un grand carr=E9 (loupe) avec des dimensions qui entoure t=
oute la cellule active avec le texte dedans.
Option Explicit
Const KShCom =3D "CmtSh"
Dim ShCom As Shape
Private Sub CreeShape()
On Error Resume Next
ActiveSheet.Shapes(KShCom).Delete
Set ShCom =3D ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizonta=
l, 1, 1, ActiveCell.Width + 16, ActiveCell.Height + 16)
With ShCom
.DrawingObject.Font.Name =3D "Verdana"
.DrawingObject.Font.Size =3D 13
.Name =3D KShCom
.Left =3D ActiveCell.Left - 10
.Top =3D ActiveCell.Top - 10
End With
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
With Target
If .Count =3D 1 And Not Intersect(Target, [Rng]) Is Nothing Then
If ShCom Is Nothing Then CreeShape
If Not ShCom.Visible Then Exit Sub
ShCom.Left =3D .Left - 10
ShCom.Top =3D .Top - 10
.Height =3D Target.Height + 16
.Width =3D Target.Width + 16
ShCom.DrawingObject.Text =3D .Text
Else
ShCom.Visible =3D 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 =3D Not .Visible
If .Visible Then
.Left =3D Target.Left - 10
.Top =3D Target.Top - 10
.Height =3D Target.Height + 16
.Width =3D Target.Width + 16
.DrawingObject.Text =3D Target.Text
End If
End With
Cancel =3D True
End Sub
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire
Veuillez sélectionner un problème
Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Apitos
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
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
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
