Zoom pour graphes excel

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

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.