5/5 (8 avis)
Vue 11 510 fois - Téléchargée 953 fois
'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
4 nov. 2016 à 15:01
Modifié par Ecirbaf11 le 16/05/2014 à 16:29
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
23 juil. 2011 à 08:43
22 juil. 2011 à 23:04
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,
@+
22 juil. 2011 à 18:31
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
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.