Effet de loupe sur une cellule en deux temps

**apt** · 20/03/2012, 23h05

Bonsoir à tous,

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

Alors j'aimerais lors d'un clic sur une cellule réaliser un effet de loupe en deux temps :

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

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
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(msoTextOrientationHorizontal, 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 Boolean) 
    If Target.Count <> 1 Or Intersect(Target, [Rng]) Is Nothing Then Exit Sub 
    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.

EDIT :

Peut-être un petit éclairci le problème

**apt** · 25/03/2012, 19h15

Bonsoir le forum,

Une nouvelle tentative, avec création d'un petit carré au début (CreateSmallShape) puis l'élargir (CreateBigShape) pour obtenir l'effet de loupe en enfin.

Seulement l'effet n'est visible entre le premier carré et le deuxième (On ne voit que le deuxième).

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
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

**mercatog** · 25/03/2012, 21h31

Une proposition

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
Option Explicit
 
Const KShCom = "CmtSh"
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
If Not Intersect(Target, [Rng]) Is Nothing Then
    If Target.Count = 1 Then CreateShape
Else
    DeleteShape
End If
End Sub
 
Private Sub DeleteShape()
Dim ShCom As Shape
 
For Each ShCom In ActiveSheet.Shapes
    If ShCom.Name = KShCom Then
        ShCom.Delete
        Exit For
    End If
Next ShCom
End Sub
 
Private Sub CreateShape()
Dim G As Integer, T As Integer, L As Integer, H As Integer
Dim ShCom As Shape
Dim Cont As String
Dim i As Byte
Const P As Byte = 48
 
DeleteShape
Cont = ActiveCell.Value
If Cont <> "" Then
    With ActiveCell
        G = .Left
        T = .Top
        L = .Width
        H = .Height
    End With
 
    Set ShCom = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, G + L / 2, T + H / 2, 0, 0)
    With ShCom
        .DrawingObject.Font.Name = "Verdana"
        .DrawingObject.Text = Cont
        .Name = KShCom
        For i = 1 To P
            DoEvents
            .Left = .Left - L / (2 * P - 48)
            .Top = .Top - H / (2 * P - 12)
            .Width = i * L / (P - 24)
            .Height = i * H / (P - 6)
            .DrawingObject.Font.Size = Int(i / 4)
        Next i
    End With
End If
End Sub

EDIT

Une autre approche, faire une image de la cellule sélectionnée et de l'agrandir par une petite boucle.
L'image est initialisée par un double clique sur une cellule de la plage Rng, par la suite, la sélection de chaque cellule ou plage montrera la plage sélectionnée.
Le clique ailleurs que Rng, supprime l'image.
Par cette proposition, on peut agrandir une seule cellule ou un plage de plusieurs cellules.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
Option Explicit
 
Const KShCom = "CmtSh"
 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
 
If Not Intersect(Target, [Rng]) Is Nothing Then
    Cancel = True
    CreateShape Target
End If
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
If Not Intersect(Target, [Rng]) Is Nothing Then
        If Existe Then CreateShape Target
Else
    DeleteShape
End If
End Sub
 
Private Sub DeleteShape()
 
If Existe Then ActiveSheet.Shapes(KShCom).Delete
End Sub
 
Private Function Existe()
Dim Sh As Shape
 
For Each Sh In ActiveSheet.Shapes
    If Sh.Name = KShCom Then
        Existe = True
        Exit For
    End If
Next Sh
End Function
 
Private Sub CreateShape(ByVal Target As Range)
Dim G As Integer, T As Integer, L As Integer, H As Integer
Dim Shp As Shape
Dim i As Byte
Const P As Byte = 40
 
DeleteShape
With Target
    G = .Left
    T = .Top
    L = .Width
    H = .Height
    .Copy
End With
ActiveSheet.Pictures.Paste
Set Shp = Shapes(Shapes.Count)
Application.CutCopyMode = False
With Shp
    .Width = 0
    .Height = 0
    .Left = G + L / 2
    .Top = T + H / 2
    .Name = KShCom
    For i = 1 To P
        DoEvents
        .Left = .Left - L / P
        .Top = .Top - H / P
        .Width = .Width + L / P
        .Height = .Height + H / P
    Next i
End With
Set Shp = Nothing
End Sub

**apt** · 25/03/2012, 23h59

C'est ingénieux ce que tu fais.

Les deux exemples fonctionnent très bien, sauf qu'il manque quelques retouches :

- Au début de chaque création de la zone de texte et quand les dimensions sont presque nulles, il est mieux de ne pas afficher le texte dans la petite forme, parce qu'il apparait sur un fil horizontal puisque les dimensions tend vers zéro

- Quand la forme s'arrête de croitre, s'il y a un long texte contenu dans la cellule active, on pourra remarquer qu'il manque une ligne ou plus d'afficher dans la cadre final

- Pourrais-je avoir l'affichage centré au milieu seulement si les cellules contenaient des chiffres ?

Merci.

**mercatog** · 26/03/2012, 00h01

Je propose le 2ème code (image d'une cellule ou plage de cellules).

**apt** · 26/03/2012, 00h40

Salut mercatog,

Est-il possible avec la deuxième approche, de ne rien manquer pour afficher tout le texte contenu dans la cellule à agrandir ?

Et n'y a-t-il pas moyen de voir les chiffres centrés dans le cadre final ?

Sinon un grand merci pour tous ce que tu as fait pour résoudre cette problématique.