Visual Basic / VB.NET : Zoom à la souris sur un graphique excel

Description

Depuis longtemps, je galère pour zoomer mes graph sous excel alors que certain logiciels font
çà de manière ultra simple (à la souris)
Après de nombreuse recherches sur internet, pour trouver un gentil programmeur qui aurais fais
une macro qui va bien,je n'ai rien trouvé de concluant.
Je me suis donc décidé à me mettre au VBA pour implémenter ce zoom.
Après de long mois de travail (je débutais!!) et de nombreuse approches
et problématiques(dont je vous passerais les détail),
j'ai le plaisir de vous faire partager mon code:

Cet outil de Zoom pour Excel permet:
- de faire un zoom à la souris en traçant un rectangle en cliquant sur "F2"
- de déplacer la courbe en bougeant la souris avec Ctrl appuyé
- faire un retour aux échelles auto en faisant "Ctrl a"
- faire un retour aux échelles auto par clic droit (seulement sur XL2000)

J'utilise les événement graphiques dans un module de classe

pour l'utiliser, copiez la première partie du code dans Thisworkbook
et la seconde dans un module de classe appelé classe_zoom

Source / Exemple :

'Dans Thisworkbook:
Dim myclassmodule As New classe_zoom

Private Sub Workbook_Open()
Call charge_class
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Call charge_class
End Sub

Private Sub charge_class()
   Dim graph As String
  'on cherche si il y a un graph , on passe à l'instruction suivante si il n'y en a pas
    On Error Resume Next
    graph = ActiveChart.Name
    ' on attribut le lancement du zoom à F2 si il y a un graph sur la feuille
    If graph <> Empty Then
    'on déclare le module de classe pour la feuille active
        Set myclassmodule.mychartclass = ActiveChart
        Application.OnKey "{F2}", "ThisWorkbook.zoom"
        Application.OnKey "^a", "thisworkbook.echelle_auto"
        ActiveSheet.Unprotect
    Else
        Application.OnKey "{F2}"
        Application.OnKey "^a"

    End If
    'ajout du menu retour echelle auto
    Application.CommandBars("plot area").Reset
    With Application.CommandBars("plot area").Controls.Add(msoControlButton, Before:=1, temporary:=True)
        .Caption = "Retour echelle auto" 'le nom de la commande
        .BeginGroup = True  'ligne facultative si elle est précisée alors
        .OnAction = "thisworkbook.echelle_auto" ' la macro 1 est lancé
    End With
End Sub

'on met cette macro dans le thisworkbook afin d'avoir tous nos outils de zoom
'dans un seul module de classe classe_zoom (pas d'ajour d'autre module)
Private Sub zoom()
Call myclassmodule.zoom_souris
End Sub

Public Sub echelle_auto()
Call myclassmodule.retour_echelle_auto
End Sub

'Dans un module de classe nommé classe_zoom
Option Explicit
Public WithEvents mychartclass As Chart

Dim X0 As Long, Y0 As Long
Dim top_rect As Long, left_rect As Long
Dim top_graph As Single, left_graph As Single
Dim timer As Long, nb_shape As Integer

Dim ax As Axis
'déclaration des tableaux pour les collections
Dim dimension_graph(2) As Long, dimension_rect(2) As Long
Dim axe_min(2, 2) As Single, axe_max(2, 2) As Single
Dim axe_new_echelle(2, 2) As Single, axe_echelle(2, 2) As Single, ratio_echelle(2, 2) As Single
Dim unite_princ As Variant
Dim axe_max_new(2, 2) As Single, axe_min_new(2, 2) As Single
Dim delta_souris(2) As Long

Dim i As Long, j As Long
Const sensibilite = 5

Private Sub mychartclass_MouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal x As Long, ByVal y As Long)

Application.StatusBar = "x=" & x & "   " & "y=" & y
        
If Shift = 0 Then
    'Quand Ctrl n'est pas enfoncé, on récupére les coordonnées origine et les axes
    X0 = x
    Y0 = y
    For Each ax In ActiveChart.Axes
        With ax
            i = .Type 'type d'axe x ou y
            j = .AxisGroup 'groupe d'axe principal ou secondaire
            axe_min(i, j) = .MinimumScale
            axe_max(i, j) = .MaximumScale
        End With
    Next
    Application.Cursor = xlNormal
End If
If Shift = 2 Then 'si Ctrl est appuyé
    If Button = 0 Then 'pour ne pas activer la fonction si on clique le bouton de la souris
        ActiveChart.Deselect 'On enleve toute selection pour faire plus propre
        Application.Cursor = 1
        Application.ScreenUpdating = False
        'on calcule le mouvement de la souris en X et en Y
        delta_souris(1) = X0 - x
        delta_souris(2) = y - Y0 'sur Y on inverse car le zéro de la souris est en haut du graph
        Application.StatusBar = "Dx=" & delta_souris(1) & "   " & "Dy=" & delta_souris(2)
        For Each ax In ActiveChart.Axes
            With ax
                i = .Type 'type d'axe x ou y
                j = .AxisGroup 'groupe d'axe principal ou secondaire
                unite_princ = .MajorUnit
                'on ajoute aux valeur origine des axes, la variation de la souris divisé
                'par la a sensibilité et pondérée de l'unité principale de l'axe
                axe_min_new(i, j) = axe_min(i, j) + (unite_princ * delta_souris(i) / sensibilite)
                axe_max_new(i, j) = axe_max(i, j) + (unite_princ * delta_souris(i) / sensibilite)
                'on entre les nouvelles echelles arrondi sur la base de l'unité principale
                .MaximumScale = Round((axe_max_new(i, j) / unite_princ), 0) * unite_princ
                .MinimumScale = Round((axe_min_new(i, j) / unite_princ), 0) * unite_princ
                .CrossesAt = .MinimumScale
            End With
        Next
    End If 'if button
End If ' if shift=2
End Sub

Function zoom_souris()
'on trace le rectangle
ActiveChart.Select 'on selectionne la graph pour ne pas planter sous XL2007
Application.CommandBars("Drawing").Controls("Rectangle").Execute
modif_echelle
End Function

Function modif_echelle()
'on attend que le rectangle soit tracé en comptant les shapes sur la feuille
'peut être amélioré si on arrive a créer directement le rectangle nommé fenetre_zoom,
'on testerait alors sur l'existence de celui-ci
nb_shape = ActiveChart.Shapes.Count
timer = 0
Do While ActiveChart.Shapes.Count <= nb_shape
    DoEvents 'Pour ne pas bloquer les actions sur l'userform pendant le tracé du graphe on utilise fonction DoEvents
    'on fait une petite tempo afin de ne pas être bloqué dans la boucle
    If timer = 100000 Then
        MsgBox "zoom annulé"
        Exit Function
    End If
    timer = timer + 1
Loop

    Application.ScreenUpdating = False
    'Selection.ShapeRange.Fill.Visible = msoFalse
    Selection.Name = "fenetre_zoom"
    'mesure du rectangle
    With ActiveChart.Shapes("fenetre_zoom")
        top_rect = .Top
        left_rect = .Left
        dimension_rect(1) = .Width 'Largeur
        dimension_rect(2) = .Height 'hauteur
        .Delete 'on efface le rectangle
    End With
    'mesure du cadre graphique
    With ActiveChart.PlotArea
        top_graph = .InsideTop
        left_graph = .InsideLeft
        dimension_graph(1) = .InsideWidth 'Largeur
        dimension_graph(2) = .InsideHeight 'hauteur
    End With
    
    For Each ax In ActiveChart.Axes
        With ax
            i = .Type 'type d'axe x ou y
            j = .AxisGroup 'groupe d'axe principal ou secondaire
            axe_min(i, j) = .MinimumScale
            axe_max(i, j) = .MaximumScale
            axe_echelle(i, j) = axe_max(i, j) - axe_min(i, j)
            'On calcule le ratio entre les échelle actuelle et les dimensions du graph
            ratio_echelle(i, j) = (axe_echelle(i, j) / dimension_graph(i))
            'On calcule donc la nouvelle échelle a partir du rectangle dessiné (Largeur en X et hauteur en Y)
            axe_new_echelle(i, j) = dimension_rect(i) * ratio_echelle(i, j)
            
            'On calcule l'échelle des X
            'ici on part de la gauche on commence donc par Xmin
            axe_min_new(1, 1) = axe_min(1, 1) + ((left_rect - left_graph) * ratio_echelle(1, 1))
            axe_max_new(1, 1) = axe_min_new(1, 1) + axe_new_echelle(1, 1)
        
            'on modifie les echelles Y principale et secondaire
            'On soustrait la position du rectangle(rationnée et recalé) a l'echelle max
            axe_max_new(2, j) = axe_max(2, j) - ((top_rect - top_graph) * ratio_echelle(2, j))
            axe_min_new(2, j) = axe_max_new(2, j) - axe_new_echelle(2, j)
    
            'On détermine le format de l'axe  pour arrondir au nombre de chiffres
            'de l'unité principale (cela évite d'avoir 12 chiffres après la virgule)
            unite_princ = .MajorUnit
            'on entre les nouvelles echelles arrondi sur la base de l'unité principale
            .MinimumScale = Round((axe_min_new(i, j) / unite_princ), 0) * unite_princ
            .MaximumScale = Round((axe_max_new(i, j) / unite_princ), 0) * unite_princ
            .MajorUnitIsAuto = True 'on active l'unité principale pour avoir un recalcul
            .MajorUnitIsAuto = False 'on la désactive pour ne pas avoir de recalcul quand on glisse la courbe
        End With
    Next
Application.ScreenUpdating = True
End Function

Function retour_echelle_auto()
Application.ScreenUpdating = False
For Each ax In ActiveChart.Axes
    With ax
        .MinimumScaleIsAuto = True
        .MaximumScaleIsAuto = True
        .MinorUnitIsAuto = True
        .MajorUnitIsAuto = True
        .MinorUnitIsAuto = False
        .MajorUnitIsAuto = False
        .CrossesAt = 0
    End With
Next
Application.ScreenUpdating = True
End Function

Conclusion :

Je l'ai pas mal testé sur XL2000 mais quasiment pas sur 2007 et pas du tout sur 2010

Je n'arrive pas à faire fonctionner le menu contextuel sur 2007, j'ai l'impression que ce n'est pas
possible, mais si quelqu'un à la réponse, je suis preneur.

De même j'ai un léger effet sapin de noël sur le déplacement de courbe sous XL2000.

J'avais aussi pensé à en faire une macro complémentaire afin de pouvoir l'utiliser sur n'importe
quel fichier. Mais je ne sais pas encore comment faire et je ne me suis pas encore penché sur la
question.
Je pense que ce seras pour un prochaine évolution.

Je suis à votre écoute pour toutes correction de bug éventuel ou pour des amélioration

Télécharger le projet

Codes Sources

Télécharger
zoom_mobile 1.2.xls

A voir également

Zoom graphique excel
Excel zoom graphique - Meilleures réponses
Zoomer sur un graphique excel - Meilleures réponses
Visual Basic / VB.NET : Personnaliser les labels d'un graphique excel - CodeS SourceS - Guide
Visual Basic / VB.NET : Graphique excel dans son prog !!!! - CodeS SourceS - Guide
Enregistrement d'un graphique excel sous forme d'image jpg - Codes sources - Visual Basic / VB.NET (Graphique)
Graphiques excel piloté par delphi - Codes sources - Delphi / Pascal (Graphique)
Visual Basic / VB.NET : Info point de courbe de graphique excel, qui fonctionne comme un év&e - Guide

Ajouter un commentaire Commentaires

Signaler

quenelle69
4 nov. 2016 à 15:01

Tu es un put1 de génie

Signaler

Philippe734

Messages postés: 308
Date d'inscription: lundi 16 décembre 2002
Statut: Membre
Dernière intervention: 15 juin 2015

1
23 juil. 2011 à 08:43

Sur 2003, ça fonctionne très bien

Signaler

Ecirbaf11 > Philippe734

Messages postés: 308
Date d'inscription: lundi 16 décembre 2002
Statut: Membre
Dernière intervention: 15 juin 2015

Modifié par Ecirbaf11 le 16/05/2014 à 16:29

Sur 2010 aussi !
Merci pour cet utilitaire vraiment pratique... J'arrive pas à comprendre pourquoi il ne l'implante pas directement sur EXCEL ou au moins sur 1 add-ind en option ?
Je désire installer cet utilitaire de façon général (utilisable sur tous les fichiers Excel), quelqu'un aurait-il la solution ?

Merci d'avance

Signaler

cs_coyote26

Messages postés: 4
Date d'inscription: mardi 19 août 2003
Statut: Membre
Dernière intervention: 22 juillet 2011

22 juil. 2011 à 23:04

Je suis désolé, j'ai travaillé le code sur XL200 car c'est celui que j'utilise au boulot et je n'ai pas encore 2007 installé. Normalement, on doit me l'installer la semaine prochaine. Je pourrais alors tester et apporter quelques améliorations à mon code.
Pour le message zoom annulé, j'avais vu que le timer était plus rapide sous 2007, il faut l'augmenter dans la Function modif_echelle()

Sinon, je suis preneur de toutes vos bonnes idées d'optimisation.

Merci pour vos commentaire,
@+

Signaler

mimiZanzan

Messages postés: 301
Date d'inscription: lundi 27 février 2006
Statut: Membre
Dernière intervention: 17 décembre 2017

22 juil. 2011 à 18:31

Salut,
Très bon travail(surtout pour un débutant, chapeau!), il y a plein de trucs intéressants dans ton code.
Il peut bien sûr être amélioré, en particulier pour le déplacement des courbes (la modification de la sensibilité semble peu efficace), et le déclenchement du zoom (message "zoom annulé" apparaissant fréquemment).
Il serait bon aussi que le code fonctionne au moins pour la version Excel 2007, la version 2000 étant quand même assez dépassée maintenant..., et pour les graphiques intégrés aux feuilles classiques.
Je vais l'étudier et voir ce que je peux t'apporter.
Cdt

Afficher les 8 commentaires

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Source / Exemple :

Conclusion :

A voir également

Vous n'êtes pas encore membre ? inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !