hi,
i would like to share with you a tool for dynamic zooming in XY-charts using the mouse to set up a zoom area. The axes scalings are changed to zoom in/out, the link to the original data is left untouched.
The zoom history is stored to conveniently scroll through the chart data.
(Currently, the number of charts for my application is limited to 30 with max. 10 levels of zoom each. Quite enough.)
Suggestions to further improve the code are welcome!
Unfortunately, I was unable to include a sample file.
Enjoy,
Richard.
(using Excel 2002)
This code goes into the Chart sheet (each Chart separately)
This code goes into a std. Module (Here's where the actual zooming takes place; most of the code is for logging the zoom history. Curious? Jump to "ZoomInOnChart()")
This goes into the ThisWorkbook module (create zoom toolbar at FileOpen)
i would like to share with you a tool for dynamic zooming in XY-charts using the mouse to set up a zoom area. The axes scalings are changed to zoom in/out, the link to the original data is left untouched.
The zoom history is stored to conveniently scroll through the chart data.
(Currently, the number of charts for my application is limited to 30 with max. 10 levels of zoom each. Quite enough.)
Suggestions to further improve the code are welcome!
Unfortunately, I was unable to include a sample file.
Enjoy,
Richard.
(using Excel 2002)
This code goes into the Chart sheet (each Chart separately)
Code:
Option Explicit
Private Sub Chart_Activate()
On Error Resume Next
Application.CommandBars("Zoom Tools").Visible = True
End Sub
Private Sub Chart_Deactivate()
On Error Resume Next
Application.CommandBars("Zoom Tools").Visible = False
ZoomDisable
End Sub
Private Sub Chart_MouseDown(ByVal Button As Long, ByVal Shift As Long, ByVal x As Long, ByVal y As Long)
If Not ZoomEnabled Then
Exit Sub
End If
'start drawing the rectangle to zoom
Application.CommandBars("Drawing").Controls("Rectangle").Execute
End Sub
Private Sub Chart_Select(ByVal ElementID As Long, ByVal Arg1 As Long, ByVal Arg2 As Long)
If ZoomEnabled Then
Select Case TypeName(Selection)
Case "Rectangle"
'copy newly created rectangle into ZoomBox object
Set shpTemp = Selection
shpTemp.Name = "ZoomBox"
shpTemp.Visible = False
'change zoom on chart
ZoomInOnChart
'remove ZoomBox object and clear ZoomEnabled-flag
shpTemp.Delete
ZoomEnabled = False
Case Else
ZoomEnabled = False
End Select
End If
ActiveChart.Refresh
End Sub
Code:
Public ZoomEnabled As Boolean
Public ZoomPrev As Boolean
Public ZoomNxt As Boolean
Private Type AxisXYMinMax
minX1 As Single
minX2 As Single
minY1 As Single
minY2 As Single
maxX1 As Single
maxX2 As Single
maxY1 As Single
maxY2 As Single
End Type
Private Type ZmHis
chrtname(30) As String
current(30) As Long
last(30) As Long
axs(30, 10) As AxisXYMinMax
End Type
Public ZoomHistory As ZmHis
Public shpTemp As Object
Sub ZoomDisable()
ZoomEnabled = False
End Sub
Sub ZoomIn()
ZoomEnabled = True
End Sub
Sub ZoomAll()
Dim i As Single, j As Single
Application.ScreenUpdating = False
' find current chart name or introduce new chart name to array to store zoom history
For i = 1 To 30
If ZoomHistory.chrtname(i) = ActiveChart.Name Then
Exit For
ElseIf ZoomHistory.chrtname(i) = "" Then
ZoomHistory.chrtname(i) = ActiveChart.Name
Exit For
End If
Next i
'set axes to max. scales
With ActiveChart.Axes(xlValue)
.MinimumScaleIsAuto = True
.MaximumScaleIsAuto = True
End With
With ActiveChart.Axes(xlCategory)
.MinimumScaleIsAuto = True
.MaximumScaleIsAuto = True
End With
'check for secondary axes
If ActiveChart.HasAxis(xlCategory, xlSecondary) Then
With ActiveChart.Axes(xlCategory, xlSecondary)
.MinimumScaleIsAuto = True
.MaximumScaleIsAuto = True
End With
End If
If ActiveChart.HasAxis(xlValue, xlSecondary) Then
With ActiveChart.Axes(xlValue, xlSecondary)
.MinimumScaleIsAuto = True
.MaximumScaleIsAuto = True
End With
End If
'reset ZoomHistory after <ZOOMALL>
ZoomHistory.current(i) = 0
ZoomHistory.last(i) = 0
Application.ScreenUpdating = True
End Sub
Sub ZoomPrevious()
Dim i As Long
' find current chart name in zoom history
For i = 1 To 30
If ZoomHistory.chrtname(i) = ActiveChart.Name Then
Exit For
ElseIf ZoomHistory.chrtname(i) = "" Then 'no zoom history for this chart
Exit Sub
End If
Next i
Application.ScreenUpdating = False
With ZoomHistory
If .current(i) = 0 Then Exit Sub 'status after ZoomAll
.current(i) = WorksheetFunction.Max(.current(i) - 1, 1) 'using "Max" iso. If-Then loop
' ".last" is unchanged
ActiveChart.Axes(xlCategory, xlPrimary).MinimumScale = .axs(i, .current(i)).minX1
ActiveChart.Axes(xlValue, xlPrimary).MinimumScale = .axs(i, .current(i)).minY1
ActiveChart.Axes(xlCategory, xlPrimary).MaximumScale = .axs(i, .current(i)).maxX1
ActiveChart.Axes(xlValue, xlPrimary).MaximumScale = .axs(i, .current(i)).maxY1
If ActiveChart.HasAxis(xlCategory, xlSecondary) Then
ActiveChart.Axes(xlCategory, xlSecondary).MinimumScale = .axs(i, .current(i)).minX2
ActiveChart.Axes(xlCategory, xlSecondary).MaximumScale = .axs(i, .current(i)).maxX2
End If
If ActiveChart.HasAxis(xlValue, xlSecondary) Then
ActiveChart.Axes(xlValue, xlSecondary).MinimumScale = .axs(i, .current(i)).minY2
ActiveChart.Axes(xlValue, xlSecondary).MaximumScale = .axs(i, .current(i)).maxY2
End If
End With
Application.ScreenUpdating = True
End Sub
Sub ZoomNext()
Dim i As Long
' find current chart name in zoom history
For i = 1 To 30
If ZoomHistory.chrtname(i) = ActiveChart.Name Then
Exit For
ElseIf ZoomHistory.chrtname(i) = "" Then 'no zoom history for this chart
Exit Sub
End If
Next i
Application.ScreenUpdating = False
With ZoomHistory
If .current(i) = 0 Then Exit Sub 'status after ZoomAll
.current(i) = WorksheetFunction.Min(.current(i) + 1, .last(i)) 'using "Min" iso. If-Then loop
' .last is unchanged
ActiveChart.Axes(xlCategory, xlPrimary).MinimumScale = .axs(i, .current(i)).minX1
ActiveChart.Axes(xlValue, xlPrimary).MinimumScale = .axs(i, .current(i)).minY1
ActiveChart.Axes(xlCategory, xlPrimary).MaximumScale = .axs(i, .current(i)).maxX1
ActiveChart.Axes(xlValue, xlPrimary).MaximumScale = .axs(i, .current(i)).maxY1
If ActiveChart.HasAxis(xlCategory, xlSecondary) Then
ActiveChart.Axes(xlCategory, xlSecondary).MinimumScale = .axs(i, .current(i)).minX2
ActiveChart.Axes(xlCategory, xlSecondary).MaximumScale = .axs(i, .current(i)).maxX2
End If
If ActiveChart.HasAxis(xlValue, xlSecondary) Then
ActiveChart.Axes(xlValue, xlSecondary).MinimumScale = .axs(i, .current(i)).minY2
ActiveChart.Axes(xlValue, xlSecondary).MaximumScale = .axs(i, .current(i)).maxY2
End If
End With
Application.ScreenUpdating = True
End Sub
Sub ShowDataSeries()
'TBW
MsgBox "Sorry, not implemented yet :-("
End Sub
Sub ZoomHelp()
'TBW
MsgBox "Sorry, not implemented yet :-("
End Sub
Sub ZoomInOnChart()
'overlapping rectangle parameters
Dim x_min_pnts As Single, y_min_pnts As Single
Dim x_max_pnts As Single, y_max_pnts As Single
'axis length for scaling
Dim XAxesLength As Single, YAxesLength As Single
'new min/max values for X/Y axis
Dim xax_min(2) As Single, xax_max(2) As Single
Dim yax_min(2) As Single, yax_max(2) As Single
'plotarea params
Dim plInsW As Single, plInsH As Single
Dim i As Long
' find current chart name or introduce new chart name to array to store zoom history
For i = 1 To 30
If ZoomHistory.chrtname(i) = ActiveChart.Name Then
Exit For
ElseIf ZoomHistory.chrtname(i) = "" Then
ZoomHistory.chrtname(i) = ActiveChart.Name
Exit For
End If
Next i
'store current axes settings in ZoomHistory table
If ZoomHistory.current(i) = 0 Then ExpandZoomHistory 'store initial view
'define overlap of rectangles <ZOOMBOX>and
| units: points</P> With ActiveChart
x_min_pnts = shpTemp.Left - .PlotArea.InsideLeft
y_min_pnts = (.PlotArea.InsideTop + .PlotArea.InsideHeight) - (shpTemp.Top + shpTemp.Height)
x_max_pnts = x_min_pnts + shpTemp.Width
y_max_pnts = y_min_pnts + shpTemp.Height
End With
'define new scaling parameters
With ActiveChart
plInsW = .PlotArea.InsideWidth
With .Axes(xlCategory) 'prim. x-axis (always present)
XAxesLength = (.MaximumScale - .MinimumScale)
xax_min(xlPrimary) = .MinimumScale + (x_min_pnts / plInsW) * XAxesLength
xax_max(xlPrimary) = .MinimumScale + (x_max_pnts / plInsW) * XAxesLength
End With
plInsH = .PlotArea.InsideHeight
With .Axes(xlValue) 'prim. y-axis (always present)
YAxesLength = (.MaximumScale - .MinimumScale)
yax_min(xlPrimary) = .MinimumScale + (y_min_pnts / plInsH) * YAxesLength
yax_max(xlPrimary) = .MinimumScale + (y_max_pnts / plInsH) * YAxesLength
End With
'check for secondary axis X or Y
If ActiveChart.HasAxis(xlCategory, xlSecondary) Then
With .Axes(xlCategory, xlSecondary)
XAxesLength = (.MaximumScale - .MinimumScale)
xax_min(xlSecondary) = .MinimumScale + (x_min_pnts / plInsW) * XAxesLength
xax_max(xlSecondary) = .MinimumScale + (x_max_pnts / plInsW) * XAxesLength
End With
End If
If ActiveChart.HasAxis(xlValue, xlSecondary) Then
With .Axes(xlValue, xlSecondary)
YAxesLength = (.MaximumScale - .MinimumScale)
yax_min(xlSecondary) = .MinimumScale + (y_min_pnts / plInsH) * YAxesLength
yax_max(xlSecondary) = .MinimumScale + (y_max_pnts / plInsH) * YAxesLength
End With
End If
End With
'adjust chart scaling
Application.ScreenUpdating = False
With ActiveChart
With .Axes(xlCategory, xlPrimary) 'prim. x-axis
.MinimumScale = xax_min(xlPrimary)
.MaximumScale = xax_max(xlPrimary)
End With
With .Axes(xlValue, xlPrimary) 'prim. y-axis
.MinimumScale = yax_min(xlPrimary)
.MaximumScale = yax_max(xlPrimary)
End With
If ActiveChart.HasAxis(xlCategory, xlSecondary) Then
With .Axes(xlCategory, xlSecondary) 'sec. x-axis
.MinimumScale = xax_min(xlSecondary)
.MaximumScale = xax_max(xlSecondary)
End With
End If
If ActiveChart.HasAxis(xlValue, xlSecondary) Then
With .Axes(xlValue, xlSecondary) 'sec. y-axis
.MinimumScale = yax_min(xlSecondary)
.MaximumScale = yax_max(xlSecondary)
End With
End If
End With
Application.ScreenUpdating = True
'store current axis settings in ZoomHistory table
ExpandZoomHistory 'store actual view
End Sub
Sub ExpandZoomHistory()
' store zoom history
' <.current(i)> points to the latest view
Dim i As Long
' find current chart name or introduce new chart name to array to store zoom history
For i = 1 To 30
If ZoomHistory.chrtname(i) = ActiveChart.Name Then
Exit For
ElseIf ZoomHistory.chrtname(i) = "" Then
ZoomHistory.chrtname(i) = ActiveChart.Name
Exit For
End If
Next i
With ZoomHistory
.current(i) = WorksheetFunction.Min(.current(i) + 1, 10) 'max. 10 history levels
.last(i) = .current(i) ' if some ZoomPrevious took place in between Zooms, Last will be reset to Current
.axs(i, .current(i)).minX1 = ActiveChart.Axes(xlCategory, xlPrimary).MinimumScale
.axs(i, .current(i)).minY1 = ActiveChart.Axes(xlValue, xlPrimary).MinimumScale
.axs(i, .current(i)).maxX1 = ActiveChart.Axes(xlCategory, xlPrimary).MaximumScale
.axs(i, .current(i)).maxY1 = ActiveChart.Axes(xlValue, xlPrimary).MaximumScale
If ActiveChart.HasAxis(xlCategory, xlSecondary) Then
.axs(i, .current(i)).minX2 = ActiveChart.Axes(xlCategory, xlSecondary).MinimumScale
.axs(i, .current(i)).maxX2 = ActiveChart.Axes(xlCategory, xlSecondary).MaximumScale
End If
If ActiveChart.HasAxis(xlValue, xlSecondary) Then
.axs(i, .current(i)).minY2 = ActiveChart.Axes(xlValue, xlSecondary).MinimumScale
.axs(i, .current(i)).maxY2 = ActiveChart.Axes(xlValue, xlSecondary).MaximumScale
End If
End With
End Sub
Code:
[INDENT]Option Explicit
Private Sub Workbook_Open()
' actions at file open:
' toolbar(s) creation
CreateZoomToolbar 'zoom toolbar for charts
'activate Zoom Toolbar if active sheet is chart object
On Error Resume Next
If ActiveChart.Name <> "" Then
'check if active sheet is chart object
End If
If Err.Number = 0 Then 'active sheet is chart object
Application.CommandBars("Zoom Tools").Visible = True
End If
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
' actions at file close:
' toolbar(s) delete
On Error Resume Next
DeleteZoomToolbar 'Zoom Toolbar delete
End Sub
Sub DeleteZoomToolbar()
On Error Resume Next
Application.CommandBars("Zoom Tools").Delete
End Sub
Sub CreateZoomToolbar()
Dim cbWSMenuBar As CommandBar
DeleteZoomToolbar
On Error Resume Next
Set cbWSMenuBar = Application.CommandBars.Add("Zoom Tools")
With cbWSMenuBar
With .Controls.Add(Type:=msoControlButton)
.Caption = "Zoom Disable"
.Style = msoButtonCaption
.OnAction = "ZoomDisable"
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "Zoom "
.Style = msoButtonCaption
.OnAction = "ZoomIn"
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "Zoom All "
.Style = msoButtonCaption
.OnAction = "ZoomAll"
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "Zoom Previous"
.Style = msoButtonCaption
.OnAction = "ZoomPrevious"
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "Zoom Next "
.Style = msoButtonCaption
.OnAction = "ZoomNext"
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "Show Data Series"
.Style = msoButtonCaption
.OnAction = "ShowDataSeries"
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "Help "
.Style = msoButtonCaption
.OnAction = "ZoomHelp"
End With
End With
End Sub
[/INDENT]
