1. Accueil
  2. Visual Basic / VB.NET
  3. Sources Visual Basic / VB.NET
  4. Sources Graphique
  5. Zoom pour graphes excel

Zoom pour graphes excel

5/5 (2 avis)

Vue 17 933 fois - Téléchargée 955 fois

Télécharger le projet
Commenter

Description

Une petite macro VBA accompagné d'un UserForm permettant de zoomer sur un graphe excel de type XYScatter (nuage de points) à l'aide des shapes rectangulaires. Avant de se jeter comme un mort de faim sur le bouton zoom, il faut respecer le protocole suivant:
1 - Le graphe sur lequel on souhaite travailler doit toujours se situer en arriere plan
2 - La premiere chose a faire est de tracer une forme rectangulaire (Menu dessin) puis de sélectionner une couleur transparente (comme ca on voit le graphe)
3 - Superposer cette forme rectangulaire au cadre dans lequel se situe le graphe a traiter (PlotArea et pas ChartArea) en ajustant le plus précisément possible les deux cadres.
4 - Cliquer sur calibration
5 - Redimensionner le cadre dans la section a zoomer puis cliquer sur zoom
6 - Unzoom permet de revenir à l'état d'origine

Source / Exemple : 


' Codé Par Manu Heitz le 12/05/07

Option Explicit

Dim MaxYBegin As Double
Dim MinXBegin As Double
Dim MinYBegin As Double
Dim MaxXBegin As Double

Dim nb_ZoomApplied As Integer

Dim CorrectionHeightPlotArea As Double
Dim CorrectionWidthPlotArea As Double
Dim CorrectionShapeLeft As Double
Dim CorrectionShapeTop As Double

Private Sub Calibration_Click()

If ActiveChart.Shapes.Count = 0 Then
    MsgBox ("Draw A rectangular shape first")
    Exit Sub
End If

CorrectionHeightPlotArea = ActiveChart.PlotArea.Height - ActiveChart.Shapes(1).Height
CorrectionWidthPlotArea = ActiveChart.PlotArea.Width - ActiveChart.Shapes(1).Width
CorrectionShapeLeft = ActiveChart.Shapes(1).Left
CorrectionShapeTop = ActiveChart.Shapes(1).Top
End Sub

Private Sub UnZoom_Click()
nb_ZoomApplied = 0
ActiveChart.Axes(xlCategory).MinimumScale = MinXBegin
ActiveChart.Axes(xlCategory).MaximumScale = MaxXBegin
ActiveChart.Axes(xlValue).MinimumScale = MinYBegin
ActiveChart.Axes(xlValue).MaximumScale = MaxYBegin
End Sub

Private Sub zoom_Click()

Dim TopPlotAera As Double
Dim LeftPlotAera As Double
Dim HeightPlotArea As Double
Dim WidthPlotArea As Double

Dim TopChartArea As Double
Dim LeftChartArea As Double
Dim HeightChartArea As Double
Dim WidthChartArea As Double

Dim MaxYCoord As Double
Dim MinXCoord As Double
Dim MinYCoord As Double
Dim MaxXCoord As Double

Dim ShapeTop As Double
Dim ShapeLeft As Double
Dim ShapeHeight As Double
Dim ShapeWidth As Double

Dim new_MaxYCoord As Double
Dim new_MinXCoord As Double
Dim new_MinYCoord As Double
Dim new_MaxXCoord As Double

If ActiveChart.Shapes.Count = 0 Then
    MsgBox ("Draw A rectangular shape first")
    Exit Sub
End If

nb_ZoomApplied = nb_ZoomApplied + 1

LeftChartArea = ActiveChart.ChartArea.Left
TopChartArea = ActiveChart.ChartArea.Top
HeightChartArea = ActiveChart.ChartArea.Height
WidthChartArea = ActiveChart.ChartArea.Width

TopPlotAera = ActiveChart.PlotArea.Top
LeftPlotAera = ActiveChart.PlotArea.Left
HeightPlotArea = ActiveChart.PlotArea.Height - CorrectionHeightPlotArea
WidthPlotArea = ActiveChart.PlotArea.Width - CorrectionWidthPlotArea

MaxYCoord = ActiveChart.Axes(xlValue).MaximumScale
MaxXCoord = ActiveChart.Axes(xlCategory).MaximumScale
MinXCoord = ActiveChart.Axes(xlCategory).MinimumScale
MinYCoord = ActiveChart.Axes(xlValue).MinimumScale

If nb_ZoomApplied = 1 Then
    MaxYBegin = MaxYCoord
    MinXBegin = MinXCoord
    MinYBegin = MinYCoord
    MaxXBegin = MaxXCoord
End If

ActiveChart.Shapes(1).Select
ShapeTop = Selection.Top - CorrectionShapeTop  '- TopPlotAera
ShapeLeft = Selection.Left - CorrectionShapeLeft  '- LeftPlotAera
ShapeHeight = Selection.Height
ShapeWidth = Selection.Width

new_MinXCoord = MinXCoord + (ShapeLeft * (MaxXCoord - MinXCoord) / WidthPlotArea)
new_MaxXCoord = new_MinXCoord + (ShapeWidth * (MaxXCoord - MinXCoord) / WidthPlotArea)
new_MaxYCoord = MaxYCoord - (ShapeTop * (MaxYCoord - MinYCoord) / HeightPlotArea)
new_MinYCoord = new_MaxYCoord - (ShapeHeight * (MaxYCoord - MinYCoord) / HeightPlotArea)

ActiveChart.Axes(xlCategory).MinimumScale = new_MinXCoord
ActiveChart.Axes(xlCategory).MaximumScale = new_MaxXCoord
ActiveChart.Axes(xlValue).MinimumScale = new_MinYCoord
ActiveChart.Axes(xlValue).MaximumScale = new_MaxYCoord

End Sub

Conclusion :


Je sais pas si ca marche avec d'autres types de graphes, J ai pas testé. Merci de me donner vos impressions
Télécharger le projet

Codes Sources

A voir également

Ajouter un commentaire Commentaires
cs_fbobo
Messages postés
1
Date d'inscription
jeudi 22 décembre 2005
Statut
Membre
Dernière intervention
14 mai 2007
14 mai 2007 à 20:48
Une bonne idée, qui me trottait dans la tête depuis longtemps...
Cependant réalisation (fonctionnelle) trop complexe (que je n'ai pas réussi à utiliser d'ailleurs, mais sans grands efforts !).

A mon avis, s'inspirant du look and feel d'autres applis graphiques, il faudrait utiliser un évènement "Chart_MouseDown" associé automatiquement aux graphiques présents (tous et quelque soit leur emplacement feuille graphique ou incorporé.
Cet évènement initiant le tracé du rectangle de zoom (bouton maintenu), qui serait abandonné si on relâche (Chart_MouseUp) le bouton SANS s'être déplacé, pour permettre les actions "normales" de clic d'Excel.
Au relâchement du bouton (Chart_MouseUp) après déplacement (donc tracé d'un rectangle), le zoom s'afficherait dans ce rectangle, avec un facteur par défaut (x4 p.ex.).
Un clic DROIT dans le rectangle de zoom ferait apparaitre un menu contextuel avec des commandes "changer le facteur de zoom", "annuler zoom", "avec/sans axes dans zoom", "zoom translucide" etc....
Les commandes normales de drag and drop du rectangle (forme) permettraient de se déplacer sur le graphique, avec prise en compte des déplacements à l'extérieur (soit on n'affiche que ce qui est affichable, soit la dimension du rectangle s'ajuste à ce qui est traçable).
G4industri
Messages postés
6
Date d'inscription
mardi 18 octobre 2005
Statut
Membre
Dernière intervention
14 mai 2007
14 mai 2007 à 09:15
L'idée est originale. Mais la mise en oeuvre un peu trop lourde a mon goût.
Il y a une manière plus "élégante" de le faire.

Tout d'abord vérifier que la personne a bien un graph sur l'écran.
Et ensuite modifier directement l'échelle de ce graphe sans passer par ton cadre.

Tu verras dans mes bouts de codes qu'il y a des répétitions qui méritent la création de fonctions. Le but pourrait être de proposer un menu du type GoogleEarth [Monter/descendre/Droite/Gauche // Zoom+ // Zoom+ // RESET]

Je te met un 5 pour l'originalité mais pas plus a cause de la complexité de ta solution.

Voici mes exemples:

Function TestPresenceGraph() As Boolean
'On test la présence d'un objet dans ActiveGraph
TestPresenceGraph = False
If ActiveChart Is Nothing Then
MsgBox "Rien de sélectionné"
Else
TestPresenceGraph = True
End If
End Function


Sub ZoomBy2_ActivGraph()
'
' Macro enregistrée le 14/05/2007 par G4industri
'

Dim ValMin As Long
Dim ValMax As Long
Dim ValRange As Long

'Pour un programme entier il faudrait memoriser les valeurs Xmin, Xmax, Ymin, Ymax
'pour y revenir suite a une demande de RESET

' On controle qu'il y ait un graph a zoomer
If Not TestPresenceGraph Then Exit Sub
'

'On travail sur les ordonnees
ActiveChart.Axes(xlValue).Select
With ActiveChart.Axes(xlValue)
'on recupere les infos pour determiner l'amplitude
ValMin = .MinimumScale
ValMax = .MaximumScale
ValRange = ValMax - ValMin

'on modifie les valeurs de l'echelle
.MinimumScale = ValMin + ValRange / 4
.MaximumScale = ValMax - ValRange / 4
End With

'Puis sur les abscisses
ActiveChart.Axes(xlCategory).Select
With ActiveChart.Axes(xlCategory)
'on recupere les infos pour determiner l'amplitude
ValMin = .MinimumScale
ValMax = .MaximumScale
ValRange = ValMax - ValMin

'on modifie les valeurs de l'echelle
.MinimumScale = ValMin + ValRange / 4
.MaximumScale = ValMax - ValRange / 4
End With
End Sub

Sub UnZoomBy2_ActivGraph()


Dim ValMin As Long
Dim ValMax As Long
Dim ValRange As Long

' On controle qu'il y ait un graph a zoomer
If Not TestPresenceGraph Then Exit Sub
'

'On travail sur les ordonnees
ActiveChart.Axes(xlValue).Select
With ActiveChart.Axes(xlValue)
'on recupere les infos pour determiner l'amplitude
ValMin = .MinimumScale
ValMax = .MaximumScale
ValRange = ValMax - ValMin

'on modifie les valeurs de l'echelle
.MinimumScale = ValMin - ValRange / 4
.MaximumScale = ValMax + ValRange / 4
End With

'Puis sur les abscisses
ActiveChart.Axes(xlCategory).Select
With ActiveChart.Axes(xlCategory)
'on recupere les infos pour determiner l'amplitude
ValMin = .MinimumScale
ValMax = .MaximumScale
ValRange = ValMax - ValMin

'on modifie les valeurs de l'echelle
.MinimumScale = ValMin - ValRange / 4
.MaximumScale = ValMax + ValRange / 4
End With
End Sub


'Autres fonctionalités : le déplacement
Sub AllerVersDroite_ActivGraph()

Dim ValMin As Long
Dim ValMax As Long
Dim ValRange As Long

' On controle qu'il y ait un graph a zoomer
If Not TestPresenceGraph Then Exit Sub
'

'On ne touche pas les ordonnees
'ActiveChart.Axes(xlValue).Select

'Mais bien les abscisses
ActiveChart.Axes(xlCategory).Select
With ActiveChart.Axes(xlCategory)
'on recupere les infos pour determiner l'amplitude
ValMin = .MinimumScale
ValMax = .MaximumScale
ValRange = ValMax - ValMin

'on modifie les valeurs de l'echelle
.MinimumScale = ValMin + ValRange / 10
.MaximumScale = ValMax + ValRange / 10
End With
End Sub
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.