How to zoom on charts using VBA

R

Rasm

Well-known Member
Joined
Feb 9, 2011
Messages
505
Just wondering if Excel has a zoom function where I can simply highlight a area on a chart - by click and drag kinda deal - then that area is zoomed in on.

I want to do this using VBA
 
Sort by date Sort by votes
Hi all,

I'm curious if anyone was able to adapt Jaafar's code to work for charts with more than one series? It's way over my head so I dare try.

Thanks,
Darius
 
Upvote 0

Excel Facts

Show numbers in thousands?
Use a custom number format of #,##0,K. Each comma after the final 0 will divide the displayed number by another thousand
I'm right there with you, over my head too. :eeek:

Did you see post #36?

I don't have a downloaded copy in front of me, but might be worth taking a look.
 
Upvote 0
Thanks Jeff. I'm using the excel fox resizer now. It's working great. Would love to also have the ability to zoom in on a particular part of a chart. Unfortunately, I can't get the zoom to work with a chart with more than one series. Jaafar mentioned his code couldn't do that, but didn't know if someone had worked it out yet. I'll only screw it up, lol.

Thanks,
Darius
 
Upvote 0
Hi guys, I know this is a bit old but hopefully this helps someone out. I created an addin 4 years ago to do this very thing using a rectangle shape that the user can drag over a chart and it would zoom in on the area. It works for scattertype charts and works on any number of series. You can zoom in as much as you want and unzoom all the way back to the initial level. Also has an autofit button. I developed it for Excel 2003 and in 2003 and 2000 it creates icons on the right click subcontext menu but in 2007 and above that was taken out. I also had it create its own toolbar but that was also taken out in 2007 and up. In those versions, the icons are on the add-ins tab on the ribbon. It is somewhat glitchy in 2007 and above but it still works for me ok.

https://docs.google.com/open?id=0B47SRKT3rzujQUlkaWhMOWFRUlk - 2003 version
https://docs.google.com/open?id=0B47SRKT3rzujaGw3WE9PWkZmU3M - 2007 and up version

I'm trying to find a better place to host the files. If anyone has any suggestions let me know. And feel free to mod the code to fit your needs just give me credit if you distribute it.
 
Upvote 0
weibull760 said:
Hi guys, I know this is a bit old but hopefully this helps someone out. I created an addin 4 years ago to do this very thing using a rectangle shape that the user can drag over a chart and it would zoom in on the area. It works for scattertype charts and works on any number of series. You can zoom in as much as you want and unzoom all the way back to the initial level. Also has an autofit button. I developed it for Excel 2003 and in 2003 and 2000 it creates icons on the right click subcontext menu but in 2007 and above that was taken out. I also had it create its own toolbar but that was also taken out in 2007 and up. In those versions, the icons are on the add-ins tab on the ribbon. It is somewhat glitchy in 2007 and above but it still works for me ok.

https://docs.google.com/open?id=0B47SRKT3rzujQUlkaWhMOWFRUlk - 2003 version
https://docs.google.com/open?id=0B47SRKT3rzujaGw3WE9PWkZmU3M - 2007 and up version

I'm trying to find a better place to host the files. If anyone has any suggestions let me know. And feel free to mod the code to fit your needs just give me credit if you distribute it.
Click to expand...

Here's the code (2007 and up version) if anyone is interested.

Code: 
'Chart Zoom tool version 2.1
'Date: April 25, 2011
'Author: Jason Vint

Public lastXSettings() As Variant
Public lastYSettings() As Variant
Public lastY2Settings() As Variant
Public zoomCount As Integer
Public activeChartName As String
Public strangeChart As Boolean
Public Const xlDualAxis = -4111
 
Sub removeToolbar()
    Dim menu As CommandBar
    
    On Error Resume Next
    
    Application.CommandBars("ChartZoom").Delete
    
    For i = 1 To 3
       
        Select Case i
            Case 1
                menuName = "Chart"
            Case 2
                menuName = "Chart Menu Bar" '"Plot Area"
            Case 3
                menuName = "Object/Plot"
       End Select
               
       Set menu = Application.CommandBars(menuName)
       menu.Controls("Chart Zoom").Delete
       menu.Controls("AutoFit").Delete
       menu.Controls("Undo Zoom").Delete
    Next
    
End Sub
Sub addToolbar()
    Dim NewItem1 As CommandBar
    Dim menu As CommandBar
    
    
    On Error Resume Next
    Application.CommandBars("ChartZoom").Delete
    On Error GoTo 0
    
    Set NewItem1 = Application.CommandBars.Add(Name:="ChartZoom", Position:=msoBarTop, Temporary:=True)
    NewItem1.Visible = True
    
    
    menuName = "Chart Menu Bar" '"Plot Area"
    
    
                
        Set menu = Application.CommandBars(menuName)
        
        Set NewItem2 = menu.Controls.Add
        With NewItem2
            .Caption = "Chart Zoom"
            .FaceId = 25
            '.Picture = ThisWorkbook.Sheets(1).ImageList1.ListImages(1).Picture
            .OnAction = "zoom"
            .BeginGroup = True
        End With
            
        Set NewItem3 = menu.Controls.Add
        With NewItem3
            .Caption = "AutoFit"
            .FaceId = 202
            .OnAction = "AutoFit"
            .BeginGroup = False
        End With
        
        Set NewItem4 = menu.Controls.Add
        With NewItem4
            .Caption = "Undo Zoom"
            .FaceId = 37
            .OnAction = "UndoZoom"
            .BeginGroup = False
        End With
    
    
    Application.CommandBars("ChartZoom").Visible = False
    
    
End Sub
Sub zoom()
    Dim temp As Boolean
    
    
    Application.ScreenUpdating = True
    
    On Error Resume Next
    
    shapeCount = ActiveChart.Shapes.Count
    shtShapeCount = ActiveSheet.Shapes.Count
    
    If Err Then
        MsgBox "Please select a chart first.", vbOKOnly + vbExclamation, "No chart selected"
        Exit Sub
    End If
    On Error GoTo 0
    
    'temp = (ActiveChart.ChartType = xlXYScatter Or ActiveChart.ChartType = xlXYScatterSmoothNoMarkers Or _
        ActiveChart.ChartType = xlXYScatterLines Or ActiveChart.ChartType = xlXYScatterLinesNoMarkers Or _
        ActiveChart.ChartType = xlXYScatterSmooth Or ActiveChart.ChartType = xlDualAxis)
        
    If Not (ActiveChart.ChartType = xlXYScatter Or ActiveChart.ChartType = xlXYScatterSmoothNoMarkers Or _
        ActiveChart.ChartType = xlXYScatterLines Or ActiveChart.ChartType = xlXYScatterLinesNoMarkers Or _
        ActiveChart.ChartType = xlXYScatterSmooth Or ActiveChart.ChartType = xlDualAxis) Then
            MsgBox "The zoom tool can only be used on XY (Scatter) type plots.", vbExclamation + vbOKOnly, "Wrong Chart Type."
            Exit Sub
    End If
    
    strangeChart = False
    If ActiveChart.ChartType = xlDualAxis Then
        Err.Clear
        On Error Resume Next
        YMin2 = ActiveChart.Axes(xlValue, xlSecondary).MinimumScale
        If Err Then
            strangeChart = True
            Err.Clear
        End If
        On Error GoTo 0
    End If
    
    If activeChartName <> "" And activeChartName = ActiveChart.Name Then
        ReDim Preserve lastXSettings(9, zoomCount)
        ReDim Preserve lastYSettings(9, zoomCount)
        If ActiveChart.ChartType = xlDualAxis Then
            ReDim Preserve lastY2Settings(9, zoomCount)
        End If
    Else
        zoomCount = 0
        ReDim lastXSettings(9, zoomCount)
        ReDim lastYSettings(9, zoomCount)
        If ActiveChart.ChartType = xlDualAxis Then
            ReDim lastY2Settings(9, zoomCount)
        End If
    End If
    
    activeChartName = ActiveChart.Name
    
    CommandBars("Basic Shapes").Controls("&Rectangle").Execute
    
    'On Error Resume Next
    Do
        DoEvents
    Loop Until ActiveChart.Shapes.Count = shapeCount + 1
    
    If Err Then
        ActiveSheet.Shapes(shtShapeCount + 1).Delete
        CommandBars("ChartZoom").Controls("Chart Zoom").State = msoButtonUp
        Exit Sub
    End If
    On Error GoTo 0
    
    zoomTop = ActiveChart.Shapes(shapeCount + 1).Top
    zoomLeft = ActiveChart.Shapes(shapeCount + 1).Left
    zoomHeight = ActiveChart.Shapes(shapeCount + 1).Height
    zoomWidth = ActiveChart.Shapes(shapeCount + 1).Width
    
    plotTop = ActiveChart.PlotArea.InsideTop
    plotLeft = ActiveChart.PlotArea.InsideLeft
    plotHeight = ActiveChart.PlotArea.InsideHeight
    plotWidth = ActiveChart.PlotArea.InsideWidth
    
    XMin = ActiveChart.Axes(xlCategory).MinimumScale
    XMax = ActiveChart.Axes(xlCategory).MaximumScale
    YMin = ActiveChart.Axes(xlValue).MinimumScale
    YMax = ActiveChart.Axes(xlValue).MaximumScale
    
    
    newXMin = XMin + (XMax - XMin) * (zoomLeft - plotLeft) / plotWidth
    newXMax = XMin + (XMax - XMin) * (zoomWidth + zoomLeft - plotLeft) / plotWidth
    newYMax = YMax - (YMax - YMin) * (zoomTop - plotTop) / plotHeight
    newYMin = YMax - (YMax - YMin) * (zoomTop - plotTop + zoomHeight) / plotHeight
    
    magXmin = Abs(newXMin - Round(newXMin, 0)) / (newXMax - newXMin)
    magXmax = Abs(newXMax - Round(newXMax, 0)) / (newXMax - newXMin)
    magYmin = Abs(newYMin - Round(newYMin, 0)) / (newYMax - newYMin)
    magYmax = Abs(newYMax - Round(newYMax, 0)) / (newYMax - newYMin)
    
    If ActiveChart.ChartType = xlDualAxis And Not strangeChart Then
        YMin2 = ActiveChart.Axes(xlValue, xlSecondary).MinimumScale
        YMax2 = ActiveChart.Axes(xlValue, xlSecondary).MaximumScale
        newYMax2 = YMax2 - (YMax2 - YMin2) * (zoomTop - plotTop) / plotHeight
        newYMin2 = YMax2 - (YMax2 - YMin2) * (zoomTop - plotTop + zoomHeight) / plotHeight
        magYmin2 = Abs(newYMin2 - Round(newYMin2, 0)) / (newYMax2 - newYMin2)
        magYmax2 = Abs(newYMax2 - Round(newYMax2, 0)) / (newYMax2 - newYMin2)
    End If
    
    msg = "Zoom Box info:" & vbCrLf & vbCrLf & _
        "Top: " & vbTab & zoomTop & vbCrLf & _
        "Left: " & vbTab & zoomLeft & vbCrLf & _
        "Height: " & vbTab & zoomHeight & vbCrLf & _
        "Width: " & vbTab & zoomWidth & vbCrLf & vbCrLf & _
        "Plot area info:" & vbCrLf & vbCrLf & _
        "Top: " & vbTab & plotTop & vbCrLf & _
        "Left: " & vbTab & plotLeft & vbCrLf & _
        "Height: " & vbTab & plotHeight & vbCrLf & _
        "Width: " & vbTab & plotWidth & vbCrLf & vbCrLf & _
        "Scale info:" & vbCrLf & vbCrLf & _
        "XMin: " & vbTab & XMin & vbCrLf & _
        "XMax: " & vbTab & XMax & vbCrLf & _
        "YMin: " & vbTab & YMin & vbCrLf & _
        "YMax: " & vbTab & YMax & vbCrLf & vbCrLf & _
        "New X Min: " & vbTab & newXMin & vbCrLf & vbCrLf & _
        "New X Max: " & vbTab & newXMax & vbCrLf & vbCrLf & _
        "New Y Min: " & vbTab & newYMin & vbCrLf & vbCrLf & _
        "New Y Max: " & vbTab & newYMax
        
    
    'MsgBox msg
    
    ActiveChart.Shapes(shapeCount + 1).Delete
    
    
    DoEvents
    
    Application.ScreenUpdating = False
    
    With ActiveChart.Axes(xlValue)
        lastYSettings(0, zoomCount) = .MinimumScale
        lastYSettings(1, zoomCount) = .MaximumScale
        lastYSettings(2, zoomCount) = .MinorUnitIsAuto
        lastYSettings(3, zoomCount) = .MajorUnitIsAuto
        lastYSettings(4, zoomCount) = .Crosses
        lastYSettings(5, zoomCount) = .ReversePlotOrder
        lastYSettings(6, zoomCount) = .ScaleType
        lastYSettings(7, zoomCount) = .DisplayUnit
        lastYSettings(8, zoomCount) = .TickLabels.NumberFormat
        
        
        .MinimumScale = newYMin
        .MaximumScale = newYMax
        .MinorUnitIsAuto = True
        .MajorUnitIsAuto = True
        .Crosses = xlAutomatic
        .ReversePlotOrder = False
        .ScaleType = xlLinear
        .DisplayUnit = xlNone
        .TickLabels.NumberFormat = "0." & String(InStr(1, CStr(magYmin), ".", vbTextCompare) + 1, "0")
    End With
    With ActiveChart.Axes(xlCategory)
        lastXSettings(0, zoomCount) = .MinimumScale
        lastXSettings(1, zoomCount) = .MaximumScale
        lastXSettings(2, zoomCount) = .MinorUnitIsAuto
        lastXSettings(3, zoomCount) = .MajorUnitIsAuto
        lastXSettings(4, zoomCount) = .Crosses
        lastXSettings(5, zoomCount) = .ReversePlotOrder
        lastXSettings(6, zoomCount) = .ScaleType
        lastXSettings(7, zoomCount) = .DisplayUnit
        lastXSettings(8, zoomCount) = .TickLabels.NumberFormat
        
        .MinimumScale = newXMin
        .MaximumScale = newXMax
        .MinorUnitIsAuto = True
        .MajorUnitIsAuto = True
        .Crosses = xlAutomatic
        .ReversePlotOrder = False
        .ScaleType = xlLinear
        .DisplayUnit = xlNone
        .TickLabels.NumberFormat = "0." & String(InStr(1, CStr(magXmin), ".", vbTextCompare) + 1, "0")
    End With
    
    If ActiveChart.ChartType = xlDualAxis And Not strangeChart Then
        With ActiveChart.Axes(xlValue, xlSecondary)
            lastY2Settings(0, zoomCount) = .MinimumScale
            lastY2Settings(1, zoomCount) = .MaximumScale
            lastY2Settings(2, zoomCount) = .MinorUnitIsAuto
            lastY2Settings(3, zoomCount) = .MajorUnitIsAuto
            lastY2Settings(4, zoomCount) = .Crosses
            lastY2Settings(5, zoomCount) = .ReversePlotOrder
            lastY2Settings(6, zoomCount) = .ScaleType
            lastY2Settings(7, zoomCount) = .DisplayUnit
            lastY2Settings(8, zoomCount) = .TickLabels.NumberFormat
            
            
            .MinimumScale = newYMin2
            .MaximumScale = newYMax2
            .MinorUnitIsAuto = True
            .MajorUnitIsAuto = True
            .Crosses = xlAutomatic
            .ReversePlotOrder = False
            .ScaleType = xlLinear
            .DisplayUnit = xlNone
            .TickLabels.NumberFormat = "0." & String(InStr(1, CStr(magYmin2), ".", vbTextCompare) + 1, "0")
        End With
    End If
    
    DoEvents
    
    Application.ScreenUpdating = True
    
    zoomCount = zoomCount + 1
    
    'MsgBox msg
    
    
End Sub

Sub AutoFit()
    On Error Resume Next
    
    shapeCount = ActiveChart.Shapes.Count
    
    If Err Then
        MsgBox "Please select a chart first.", vbOKOnly + vbExclamation, "No chart selected"
        Exit Sub
    End If
    On Error GoTo 0
    
    If Not (ActiveChart.ChartType = xlXYScatter Or ActiveChart.ChartType = xlXYScatterSmoothNoMarkers Or _
        ActiveChart.ChartType = xlXYScatterLines Or ActiveChart.ChartType = xlXYScatterLinesNoMarkers Or _
        ActiveChart.ChartType = xlXYScatterSmooth Or ActiveChart.ChartType = xlDualAxis) Then
            MsgBox "The zoom tool can only be used on XY (Scatter) type plots.", vbExclamation + vbOKOnly, "Wrong Chart Type."
            Exit Sub
    End If
    
    strangeChart = False
    If ActiveChart.ChartType = xlDualAxis Then
        Err.Clear
        On Error Resume Next
        YMin2 = ActiveChart.Axes(xlValue, xlSecondary).MinimumScale
        If Err Then
            strangeChart = True
            Err.Clear
        End If
        On Error GoTo 0
    End If
    
    If activeChartName <> "" And activeChartName = ActiveChart.Name Then
        ReDim Preserve lastXSettings(9, zoomCount)
        ReDim Preserve lastYSettings(9, zoomCount)
        If ActiveChart.ChartType = xlDualAxis Then
            ReDim Preserve lastY2Settings(9, zoomCount)
        End If
    Else
        zoomCount = 0
        ReDim lastXSettings(9, zoomCount)
        ReDim lastYSettings(9, zoomCount)
        If ActiveChart.ChartType = xlDualAxis Then
            ReDim lastY2Settings(9, zoomCount)
        End If
    End If
    
    activeChartName = ActiveChart.Name
    Application.ScreenUpdating = False
    
    With ActiveChart.Axes(xlValue)
        lastYSettings(0, zoomCount) = .MinimumScale
        lastYSettings(1, zoomCount) = .MaximumScale
        lastYSettings(2, zoomCount) = .MinorUnitIsAuto
        lastYSettings(3, zoomCount) = .MajorUnitIsAuto
        lastYSettings(4, zoomCount) = .Crosses
        lastYSettings(5, zoomCount) = .ReversePlotOrder
        lastYSettings(6, zoomCount) = .ScaleType
        lastYSettings(7, zoomCount) = .DisplayUnit
        lastYSettings(8, zoomCount) = .TickLabels.NumberFormat
        
        
        .MinimumScaleIsAuto = True
        .MaximumScaleIsAuto = True
        .MinorUnitIsAuto = True
        .MajorUnitIsAuto = True
        .Crosses = xlAutomatic
        .ReversePlotOrder = False
        .ScaleType = xlLinear
        .DisplayUnit = xlNone
        .TickLabels.NumberFormat = "0.00"
    End With
    
    With ActiveChart.Axes(xlCategory)
        lastXSettings(0, zoomCount) = .MinimumScale
        lastXSettings(1, zoomCount) = .MaximumScale
        lastXSettings(2, zoomCount) = .MinorUnitIsAuto
        lastXSettings(3, zoomCount) = .MajorUnitIsAuto
        lastXSettings(4, zoomCount) = .Crosses
        lastXSettings(5, zoomCount) = .ReversePlotOrder
        lastXSettings(6, zoomCount) = .ScaleType
        lastXSettings(7, zoomCount) = .DisplayUnit
        lastXSettings(8, zoomCount) = .TickLabels.NumberFormat
        
        
        .MinimumScaleIsAuto = True
        .MaximumScaleIsAuto = True
        .MinorUnitIsAuto = True
        .MajorUnitIsAuto = True
        .Crosses = xlAutomatic
        .ReversePlotOrder = False
        .ScaleType = xlLinear
        .DisplayUnit = xlNone
        .TickLabels.NumberFormat = "0.00"
    End With
    
    If ActiveChart.ChartType = xlDualAxis And Not strangeChart Then
        With ActiveChart.Axes(xlValue, xlSecondary)
            lastY2Settings(0, zoomCount) = .MinimumScale
            lastY2Settings(1, zoomCount) = .MaximumScale
            lastY2Settings(2, zoomCount) = .MinorUnitIsAuto
            lastY2Settings(3, zoomCount) = .MajorUnitIsAuto
            lastY2Settings(4, zoomCount) = .Crosses
            lastY2Settings(5, zoomCount) = .ReversePlotOrder
            lastY2Settings(6, zoomCount) = .ScaleType
            lastY2Settings(7, zoomCount) = .DisplayUnit
            lastY2Settings(8, zoomCount) = .TickLabels.NumberFormat
            
            
            .MinimumScaleIsAuto = True
            .MaximumScaleIsAuto = True
            .MinorUnitIsAuto = True
            .MajorUnitIsAuto = True
            .Crosses = xlAutomatic
            .ReversePlotOrder = False
            .ScaleType = xlLinear
            .DisplayUnit = xlNone
            .TickLabels.NumberFormat = "0." & String(InStr(1, CStr(magYmin2), ".", vbTextCompare) + 1, "0")
        End With
    End If
    
    DoEvents
    
    Application.ScreenUpdating = True
    
    zoomCount = zoomCount + 1
    
End Sub
Sub UndoZoom()
    On Error Resume Next
    
    If zoomCount = 0 Or ActiveChart.Name <> activeChartName Then Exit Sub
    zoomCount = zoomCount - 1
    
    Application.ScreenUpdating = False
    
    With ActiveChart.Axes(xlValue)
        .MinimumScale = lastYSettings(0, zoomCount)
        .MaximumScale = lastYSettings(1, zoomCount)
        .MinorUnitIsAuto = lastYSettings(2, zoomCount)
        .MajorUnitIsAuto = lastYSettings(3, zoomCount)
        .Crosses = lastYSettings(4, zoomCount)
        .ReversePlotOrder = lastYSettings(5, zoomCount)
        .ScaleType = lastYSettings(6, zoomCount)
        .DisplayUnit = lastYSettings(7, zoomCount)
        .TickLabels.NumberFormat = lastYSettings(8, zoomCount)
    End With
    With ActiveChart.Axes(xlCategory)
        .MinimumScale = lastXSettings(0, zoomCount)
        .MaximumScale = lastXSettings(1, zoomCount)
        .MinorUnitIsAuto = lastXSettings(2, zoomCount)
        .MajorUnitIsAuto = lastXSettings(3, zoomCount)
        .Crosses = lastXSettings(4, zoomCount)
        .ReversePlotOrder = lastXSettings(5, zoomCount)
        .ScaleType = lastXSettings(6, zoomCount)
        .DisplayUnit = lastXSettings(7, zoomCount)
        .TickLabels.NumberFormat = lastXSettings(8, zoomCount)
    End With
    
    If ActiveChart.ChartType = xlDualAxis And Not strangeChart Then
        With ActiveChart.Axes(xlValue, xlSecondary)
            .MinimumScale = lastY2Settings(0, zoomCount)
            .MaximumScale = lastY2Settings(1, zoomCount)
            .MinorUnitIsAuto = lastY2Settings(2, zoomCount)
            .MajorUnitIsAuto = lastY2Settings(3, zoomCount)
            .Crosses = lastY2Settings(4, zoomCount)
            .ReversePlotOrder = lastY2Settings(5, zoomCount)
            .ScaleType = lastY2Settings(6, zoomCount)
            .DisplayUnit = lastY2Settings(7, zoomCount)
            .TickLabels.NumberFormat = lastY2Settings(8, zoomCount)
        End With
    End If
    
    DoEvents
    
    Application.ScreenUpdating = True
    
End Sub


In the workbook module put this:
Code: 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call removeToolbar
End Sub
Private Sub Workbook_Open()
    Call removeToolbar
    Call addToolbar
End Sub
 
Upvote 0
weibull760,

Thank you! Your code worked perfectly for me!

In my case, there is only one plot (with five 4000-point waveforms from a numerical solution of differential equations). So rather than make the users select the plot before they can zoom, et al, I inserted the following near the end of my main "calculate" subroutine:

Code: 
ActiveSheet.ChartObjects(1).Activate ' Select the chart, so we can call Autofit()
Call AutoFit

(I wouldn't have had to include the call to autofit(), there, but it was better that way, in my particular application.)

Now the users can immediately select Zoom, Undo Zoom, and Autofit (for which I also created buttons, just above the chart).


BUT ALSO, I used the first part of your zoom() routine and created a measure() subroutine!

I just copied and pasted the whole zoom() subroutine and renamed it measure(). Then, just after you calculate the new X and Y min and max values, where you have a large msg statement followed by a commented-out MsgBox statement, I changed the msg statement to include only the new ymin, ymax, xmin, and xmax, and added Delta Y and Delta X (which are just newYMax minus newYMin and newXmax minus newXMin), and then un-commented the MsgBox statement. I simply deleted everything after that, except for "End Sub".

It works perfectly and now the users can take measurements from the plots. For example, they can zoom in and measure the amplitude of a waveform, or a time interval. It's great!

P.S. Just FYI, this is a free Excel app that I created and posted at diyaudio.com. It simulates and analyzes Transformer-Rectifier-Capacitor power supply circuits, with a constant-current step-input load. (Naturally, I left your name/date/etc header in the code, at least in this latest version. It got lost somehow and was left out of some previous versions, although I did mention in the code header that it was posted on line by weibull760, in all of those.)

Now I guess I'll want to make a separate 2003 version.

Thanks again!

Tom Gootee
 
Last edited:
Upvote 0
Actually, after creating the new measure() subroutine, in order to keep the xlsm file's size smaller, instead of using a copy of the first part of the zoom() routine, I went back in and changed the zoom() routine to izoom(measure_only). Then I made "wrappers" called zoom() and measure(), which just call izoom(0) and izoom(1). Then I put an If measure_only = 1 after the msg statement, which executes the MsgBox statement and goes straight to a line number that I inserted just before End Sub, so it skips the parts that actually zoom the plot.
 
Last edited:
Upvote 0
Fantastic Tool !

a) Just a hint. In the code the word "Rectangle" must be substituted in the proper language of the excel version one has bought (german, french and so on).
b) I have already an Add-In section so the zoom feature comes only up when I click on the chart which is fine for me. However I noticed that once I activated the chart and use the zoom feature OUTSIDE the chart I do get an error (no wonder) and the code creates a "rectangular form" outside the graph. Anyway to block this "unintentional use" ?


weibull760 said:
Here's the code (2007 and up version) if anyone is interested.

Code: 
'Chart Zoom tool version 2.1
'Date: April 25, 2011
'Author: Jason Vint

Public lastXSettings() As Variant
Public lastYSettings() As Variant
Public lastY2Settings() As Variant
Public zoomCount As Integer
Public activeChartName As String
Public strangeChart As Boolean
Public Const xlDualAxis = -4111
 
Sub removeToolbar()
    Dim menu As CommandBar
    
    On Error Resume Next
    
    Application.CommandBars("ChartZoom").Delete
    
    For i = 1 To 3
       
        Select Case i
            Case 1
                menuName = "Chart"
            Case 2
                menuName = "Chart Menu Bar" '"Plot Area"
            Case 3
                menuName = "Object/Plot"
       End Select
               
       Set menu = Application.CommandBars(menuName)
       menu.Controls("Chart Zoom").Delete
       menu.Controls("AutoFit").Delete
       menu.Controls("Undo Zoom").Delete
    Next
    
End Sub
Sub addToolbar()
    Dim NewItem1 As CommandBar
    Dim menu As CommandBar
    
    
    On Error Resume Next
    Application.CommandBars("ChartZoom").Delete
    On Error GoTo 0
    
    Set NewItem1 = Application.CommandBars.Add(Name:="ChartZoom", Position:=msoBarTop, Temporary:=True)
    NewItem1.Visible = True
    
    
    menuName = "Chart Menu Bar" '"Plot Area"
    
    
                
        Set menu = Application.CommandBars(menuName)
        
        Set NewItem2 = menu.Controls.Add
        With NewItem2
            .Caption = "Chart Zoom"
            .FaceId = 25
            '.Picture = ThisWorkbook.Sheets(1).ImageList1.ListImages(1).Picture
            .OnAction = "zoom"
            .BeginGroup = True
        End With
            
        Set NewItem3 = menu.Controls.Add
        With NewItem3
            .Caption = "AutoFit"
            .FaceId = 202
            .OnAction = "AutoFit"
            .BeginGroup = False
        End With
        
        Set NewItem4 = menu.Controls.Add
        With NewItem4
            .Caption = "Undo Zoom"
            .FaceId = 37
            .OnAction = "UndoZoom"
            .BeginGroup = False
        End With
    
    
    Application.CommandBars("ChartZoom").Visible = False
    
    
End Sub
Sub zoom()
    Dim temp As Boolean
    
    
    Application.ScreenUpdating = True
    
    On Error Resume Next
    
    shapeCount = ActiveChart.Shapes.Count
    shtShapeCount = ActiveSheet.Shapes.Count
    
    If Err Then
        MsgBox "Please select a chart first.", vbOKOnly + vbExclamation, "No chart selected"
        Exit Sub
    End If
    On Error GoTo 0
    
    'temp = (ActiveChart.ChartType = xlXYScatter Or ActiveChart.ChartType = xlXYScatterSmoothNoMarkers Or _
        ActiveChart.ChartType = xlXYScatterLines Or ActiveChart.ChartType = xlXYScatterLinesNoMarkers Or _
        ActiveChart.ChartType = xlXYScatterSmooth Or ActiveChart.ChartType = xlDualAxis)
        
    If Not (ActiveChart.ChartType = xlXYScatter Or ActiveChart.ChartType = xlXYScatterSmoothNoMarkers Or _
        ActiveChart.ChartType = xlXYScatterLines Or ActiveChart.ChartType = xlXYScatterLinesNoMarkers Or _
        ActiveChart.ChartType = xlXYScatterSmooth Or ActiveChart.ChartType = xlDualAxis) Then
            MsgBox "The zoom tool can only be used on XY (Scatter) type plots.", vbExclamation + vbOKOnly, "Wrong Chart Type."
            Exit Sub
    End If
    
    strangeChart = False
    If ActiveChart.ChartType = xlDualAxis Then
        Err.Clear
        On Error Resume Next
        YMin2 = ActiveChart.Axes(xlValue, xlSecondary).MinimumScale
        If Err Then
            strangeChart = True
            Err.Clear
        End If
        On Error GoTo 0
    End If
    
    If activeChartName <> "" And activeChartName = ActiveChart.Name Then
        ReDim Preserve lastXSettings(9, zoomCount)
        ReDim Preserve lastYSettings(9, zoomCount)
        If ActiveChart.ChartType = xlDualAxis Then
            ReDim Preserve lastY2Settings(9, zoomCount)
        End If
    Else
        zoomCount = 0
        ReDim lastXSettings(9, zoomCount)
        ReDim lastYSettings(9, zoomCount)
        If ActiveChart.ChartType = xlDualAxis Then
            ReDim lastY2Settings(9, zoomCount)
        End If
    End If
    
    activeChartName = ActiveChart.Name
    
    CommandBars("Basic Shapes").Controls("&Rectangle").Execute
    
    'On Error Resume Next
    Do
        DoEvents
    Loop Until ActiveChart.Shapes.Count = shapeCount + 1
    
    If Err Then
        ActiveSheet.Shapes(shtShapeCount + 1).Delete
        CommandBars("ChartZoom").Controls("Chart Zoom").State = msoButtonUp
        Exit Sub
    End If
    On Error GoTo 0
    
    zoomTop = ActiveChart.Shapes(shapeCount + 1).Top
    zoomLeft = ActiveChart.Shapes(shapeCount + 1).Left
    zoomHeight = ActiveChart.Shapes(shapeCount + 1).Height
    zoomWidth = ActiveChart.Shapes(shapeCount + 1).Width
    
    plotTop = ActiveChart.PlotArea.InsideTop
    plotLeft = ActiveChart.PlotArea.InsideLeft
    plotHeight = ActiveChart.PlotArea.InsideHeight
    plotWidth = ActiveChart.PlotArea.InsideWidth
    
    XMin = ActiveChart.Axes(xlCategory).MinimumScale
    XMax = ActiveChart.Axes(xlCategory).MaximumScale
    YMin = ActiveChart.Axes(xlValue).MinimumScale
    YMax = ActiveChart.Axes(xlValue).MaximumScale
    
    
    newXMin = XMin + (XMax - XMin) * (zoomLeft - plotLeft) / plotWidth
    newXMax = XMin + (XMax - XMin) * (zoomWidth + zoomLeft - plotLeft) / plotWidth
    newYMax = YMax - (YMax - YMin) * (zoomTop - plotTop) / plotHeight
    newYMin = YMax - (YMax - YMin) * (zoomTop - plotTop + zoomHeight) / plotHeight
    
    magXmin = Abs(newXMin - Round(newXMin, 0)) / (newXMax - newXMin)
    magXmax = Abs(newXMax - Round(newXMax, 0)) / (newXMax - newXMin)
    magYmin = Abs(newYMin - Round(newYMin, 0)) / (newYMax - newYMin)
    magYmax = Abs(newYMax - Round(newYMax, 0)) / (newYMax - newYMin)
    
    If ActiveChart.ChartType = xlDualAxis And Not strangeChart Then
        YMin2 = ActiveChart.Axes(xlValue, xlSecondary).MinimumScale
        YMax2 = ActiveChart.Axes(xlValue, xlSecondary).MaximumScale
        newYMax2 = YMax2 - (YMax2 - YMin2) * (zoomTop - plotTop) / plotHeight
        newYMin2 = YMax2 - (YMax2 - YMin2) * (zoomTop - plotTop + zoomHeight) / plotHeight
        magYmin2 = Abs(newYMin2 - Round(newYMin2, 0)) / (newYMax2 - newYMin2)
        magYmax2 = Abs(newYMax2 - Round(newYMax2, 0)) / (newYMax2 - newYMin2)
    End If
    
    msg = "Zoom Box info:" & vbCrLf & vbCrLf & _
        "Top: " & vbTab & zoomTop & vbCrLf & _
        "Left: " & vbTab & zoomLeft & vbCrLf & _
        "Height: " & vbTab & zoomHeight & vbCrLf & _
        "Width: " & vbTab & zoomWidth & vbCrLf & vbCrLf & _
        "Plot area info:" & vbCrLf & vbCrLf & _
        "Top: " & vbTab & plotTop & vbCrLf & _
        "Left: " & vbTab & plotLeft & vbCrLf & _
        "Height: " & vbTab & plotHeight & vbCrLf & _
        "Width: " & vbTab & plotWidth & vbCrLf & vbCrLf & _
        "Scale info:" & vbCrLf & vbCrLf & _
        "XMin: " & vbTab & XMin & vbCrLf & _
        "XMax: " & vbTab & XMax & vbCrLf & _
        "YMin: " & vbTab & YMin & vbCrLf & _
        "YMax: " & vbTab & YMax & vbCrLf & vbCrLf & _
        "New X Min: " & vbTab & newXMin & vbCrLf & vbCrLf & _
        "New X Max: " & vbTab & newXMax & vbCrLf & vbCrLf & _
        "New Y Min: " & vbTab & newYMin & vbCrLf & vbCrLf & _
        "New Y Max: " & vbTab & newYMax
        
    
    'MsgBox msg
    
    ActiveChart.Shapes(shapeCount + 1).Delete
    
    
    DoEvents
    
    Application.ScreenUpdating = False
    
    With ActiveChart.Axes(xlValue)
        lastYSettings(0, zoomCount) = .MinimumScale
        lastYSettings(1, zoomCount) = .MaximumScale
        lastYSettings(2, zoomCount) = .MinorUnitIsAuto
        lastYSettings(3, zoomCount) = .MajorUnitIsAuto
        lastYSettings(4, zoomCount) = .Crosses
        lastYSettings(5, zoomCount) = .ReversePlotOrder
        lastYSettings(6, zoomCount) = .ScaleType
        lastYSettings(7, zoomCount) = .DisplayUnit
        lastYSettings(8, zoomCount) = .TickLabels.NumberFormat
        
        
        .MinimumScale = newYMin
        .MaximumScale = newYMax
        .MinorUnitIsAuto = True
        .MajorUnitIsAuto = True
        .Crosses = xlAutomatic
        .ReversePlotOrder = False
        .ScaleType = xlLinear
        .DisplayUnit = xlNone
        .TickLabels.NumberFormat = "0." & String(InStr(1, CStr(magYmin), ".", vbTextCompare) + 1, "0")
    End With
    With ActiveChart.Axes(xlCategory)
        lastXSettings(0, zoomCount) = .MinimumScale
        lastXSettings(1, zoomCount) = .MaximumScale
        lastXSettings(2, zoomCount) = .MinorUnitIsAuto
        lastXSettings(3, zoomCount) = .MajorUnitIsAuto
        lastXSettings(4, zoomCount) = .Crosses
        lastXSettings(5, zoomCount) = .ReversePlotOrder
        lastXSettings(6, zoomCount) = .ScaleType
        lastXSettings(7, zoomCount) = .DisplayUnit
        lastXSettings(8, zoomCount) = .TickLabels.NumberFormat
        
        .MinimumScale = newXMin
        .MaximumScale = newXMax
        .MinorUnitIsAuto = True
        .MajorUnitIsAuto = True
        .Crosses = xlAutomatic
        .ReversePlotOrder = False
        .ScaleType = xlLinear
        .DisplayUnit = xlNone
        .TickLabels.NumberFormat = "0." & String(InStr(1, CStr(magXmin), ".", vbTextCompare) + 1, "0")
    End With
    
    If ActiveChart.ChartType = xlDualAxis And Not strangeChart Then
        With ActiveChart.Axes(xlValue, xlSecondary)
            lastY2Settings(0, zoomCount) = .MinimumScale
            lastY2Settings(1, zoomCount) = .MaximumScale
            lastY2Settings(2, zoomCount) = .MinorUnitIsAuto
            lastY2Settings(3, zoomCount) = .MajorUnitIsAuto
            lastY2Settings(4, zoomCount) = .Crosses
            lastY2Settings(5, zoomCount) = .ReversePlotOrder
            lastY2Settings(6, zoomCount) = .ScaleType
            lastY2Settings(7, zoomCount) = .DisplayUnit
            lastY2Settings(8, zoomCount) = .TickLabels.NumberFormat
            
            
            .MinimumScale = newYMin2
            .MaximumScale = newYMax2
            .MinorUnitIsAuto = True
            .MajorUnitIsAuto = True
            .Crosses = xlAutomatic
            .ReversePlotOrder = False
            .ScaleType = xlLinear
            .DisplayUnit = xlNone
            .TickLabels.NumberFormat = "0." & String(InStr(1, CStr(magYmin2), ".", vbTextCompare) + 1, "0")
        End With
    End If
    
    DoEvents
    
    Application.ScreenUpdating = True
    
    zoomCount = zoomCount + 1
    
    'MsgBox msg
    
    
End Sub

Sub AutoFit()
    On Error Resume Next
    
    shapeCount = ActiveChart.Shapes.Count
    
    If Err Then
        MsgBox "Please select a chart first.", vbOKOnly + vbExclamation, "No chart selected"
        Exit Sub
    End If
    On Error GoTo 0
    
    If Not (ActiveChart.ChartType = xlXYScatter Or ActiveChart.ChartType = xlXYScatterSmoothNoMarkers Or _
        ActiveChart.ChartType = xlXYScatterLines Or ActiveChart.ChartType = xlXYScatterLinesNoMarkers Or _
        ActiveChart.ChartType = xlXYScatterSmooth Or ActiveChart.ChartType = xlDualAxis) Then
            MsgBox "The zoom tool can only be used on XY (Scatter) type plots.", vbExclamation + vbOKOnly, "Wrong Chart Type."
            Exit Sub
    End If
    
    strangeChart = False
    If ActiveChart.ChartType = xlDualAxis Then
        Err.Clear
        On Error Resume Next
        YMin2 = ActiveChart.Axes(xlValue, xlSecondary).MinimumScale
        If Err Then
            strangeChart = True
            Err.Clear
        End If
        On Error GoTo 0
    End If
    
    If activeChartName <> "" And activeChartName = ActiveChart.Name Then
        ReDim Preserve lastXSettings(9, zoomCount)
        ReDim Preserve lastYSettings(9, zoomCount)
        If ActiveChart.ChartType = xlDualAxis Then
            ReDim Preserve lastY2Settings(9, zoomCount)
        End If
    Else
        zoomCount = 0
        ReDim lastXSettings(9, zoomCount)
        ReDim lastYSettings(9, zoomCount)
        If ActiveChart.ChartType = xlDualAxis Then
            ReDim lastY2Settings(9, zoomCount)
        End If
    End If
    
    activeChartName = ActiveChart.Name
    Application.ScreenUpdating = False
    
    With ActiveChart.Axes(xlValue)
        lastYSettings(0, zoomCount) = .MinimumScale
        lastYSettings(1, zoomCount) = .MaximumScale
        lastYSettings(2, zoomCount) = .MinorUnitIsAuto
        lastYSettings(3, zoomCount) = .MajorUnitIsAuto
        lastYSettings(4, zoomCount) = .Crosses
        lastYSettings(5, zoomCount) = .ReversePlotOrder
        lastYSettings(6, zoomCount) = .ScaleType
        lastYSettings(7, zoomCount) = .DisplayUnit
        lastYSettings(8, zoomCount) = .TickLabels.NumberFormat
        
        
        .MinimumScaleIsAuto = True
        .MaximumScaleIsAuto = True
        .MinorUnitIsAuto = True
        .MajorUnitIsAuto = True
        .Crosses = xlAutomatic
        .ReversePlotOrder = False
        .ScaleType = xlLinear
        .DisplayUnit = xlNone
        .TickLabels.NumberFormat = "0.00"
    End With
    
    With ActiveChart.Axes(xlCategory)
        lastXSettings(0, zoomCount) = .MinimumScale
        lastXSettings(1, zoomCount) = .MaximumScale
        lastXSettings(2, zoomCount) = .MinorUnitIsAuto
        lastXSettings(3, zoomCount) = .MajorUnitIsAuto
        lastXSettings(4, zoomCount) = .Crosses
        lastXSettings(5, zoomCount) = .ReversePlotOrder
        lastXSettings(6, zoomCount) = .ScaleType
        lastXSettings(7, zoomCount) = .DisplayUnit
        lastXSettings(8, zoomCount) = .TickLabels.NumberFormat
        
        
        .MinimumScaleIsAuto = True
        .MaximumScaleIsAuto = True
        .MinorUnitIsAuto = True
        .MajorUnitIsAuto = True
        .Crosses = xlAutomatic
        .ReversePlotOrder = False
        .ScaleType = xlLinear
        .DisplayUnit = xlNone
        .TickLabels.NumberFormat = "0.00"
    End With
    
    If ActiveChart.ChartType = xlDualAxis And Not strangeChart Then
        With ActiveChart.Axes(xlValue, xlSecondary)
            lastY2Settings(0, zoomCount) = .MinimumScale
            lastY2Settings(1, zoomCount) = .MaximumScale
            lastY2Settings(2, zoomCount) = .MinorUnitIsAuto
            lastY2Settings(3, zoomCount) = .MajorUnitIsAuto
            lastY2Settings(4, zoomCount) = .Crosses
            lastY2Settings(5, zoomCount) = .ReversePlotOrder
            lastY2Settings(6, zoomCount) = .ScaleType
            lastY2Settings(7, zoomCount) = .DisplayUnit
            lastY2Settings(8, zoomCount) = .TickLabels.NumberFormat
            
            
            .MinimumScaleIsAuto = True
            .MaximumScaleIsAuto = True
            .MinorUnitIsAuto = True
            .MajorUnitIsAuto = True
            .Crosses = xlAutomatic
            .ReversePlotOrder = False
            .ScaleType = xlLinear
            .DisplayUnit = xlNone
            .TickLabels.NumberFormat = "0." & String(InStr(1, CStr(magYmin2), ".", vbTextCompare) + 1, "0")
        End With
    End If
    
    DoEvents
    
    Application.ScreenUpdating = True
    
    zoomCount = zoomCount + 1
    
End Sub
Sub UndoZoom()
    On Error Resume Next
    
    If zoomCount = 0 Or ActiveChart.Name <> activeChartName Then Exit Sub
    zoomCount = zoomCount - 1
    
    Application.ScreenUpdating = False
    
    With ActiveChart.Axes(xlValue)
        .MinimumScale = lastYSettings(0, zoomCount)
        .MaximumScale = lastYSettings(1, zoomCount)
        .MinorUnitIsAuto = lastYSettings(2, zoomCount)
        .MajorUnitIsAuto = lastYSettings(3, zoomCount)
        .Crosses = lastYSettings(4, zoomCount)
        .ReversePlotOrder = lastYSettings(5, zoomCount)
        .ScaleType = lastYSettings(6, zoomCount)
        .DisplayUnit = lastYSettings(7, zoomCount)
        .TickLabels.NumberFormat = lastYSettings(8, zoomCount)
    End With
    With ActiveChart.Axes(xlCategory)
        .MinimumScale = lastXSettings(0, zoomCount)
        .MaximumScale = lastXSettings(1, zoomCount)
        .MinorUnitIsAuto = lastXSettings(2, zoomCount)
        .MajorUnitIsAuto = lastXSettings(3, zoomCount)
        .Crosses = lastXSettings(4, zoomCount)
        .ReversePlotOrder = lastXSettings(5, zoomCount)
        .ScaleType = lastXSettings(6, zoomCount)
        .DisplayUnit = lastXSettings(7, zoomCount)
        .TickLabels.NumberFormat = lastXSettings(8, zoomCount)
    End With
    
    If ActiveChart.ChartType = xlDualAxis And Not strangeChart Then
        With ActiveChart.Axes(xlValue, xlSecondary)
            .MinimumScale = lastY2Settings(0, zoomCount)
            .MaximumScale = lastY2Settings(1, zoomCount)
            .MinorUnitIsAuto = lastY2Settings(2, zoomCount)
            .MajorUnitIsAuto = lastY2Settings(3, zoomCount)
            .Crosses = lastY2Settings(4, zoomCount)
            .ReversePlotOrder = lastY2Settings(5, zoomCount)
            .ScaleType = lastY2Settings(6, zoomCount)
            .DisplayUnit = lastY2Settings(7, zoomCount)
            .TickLabels.NumberFormat = lastY2Settings(8, zoomCount)
        End With
    End If
    
    DoEvents
    
    Application.ScreenUpdating = True
    
End Sub


In the workbook module put this:
Code: 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call removeToolbar
End Sub
Private Sub Workbook_Open()
    Call removeToolbar
    Call addToolbar
End Sub
Click to expand...
 
Upvote 0
This is a simpler solution for adding a zoom button (shape) to your chart to enlarge the chart for easier viewing. Works great with panel charts or sparklines on a dashboard. You can download the workbook containing the macro and instructions for free at

http://www.excelcampus.com/vba/zoom-on-excel-charts

Zoom-on-Excel-Charts.gif
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question Question
VBA code for zooming data validation menus but in 365 shared online
Replies
1
Views
289
myall_blues
myall_blues
R
  • Question Question
Trying to create a line chart in Excel with NO experience.
Replies
1
Views
242
Rhothgar
R
P
  • Solved
Excel Window Autozoom based on cell
Replies
3
Views
356
myall_blues
myall_blues
T
  • Question Question
Number of Pages Doesn't Update in Loop
Replies
1
Views
237
bobsan42
bobsan42
A
  • Solved
VBA not working fully
Replies
5
Views
119
ausswe
A

Forum statistics

Threads
1,224,592
Messages
6,179,787
Members
452,942
Latest member
VijayNewtoExcel

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top