How to zoom on charts using VBA

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
 
ohhh boy - lots of read flag - I did read Jon's article on MouseDown and the problems he is having. I do have MouseUp & MouseDown working (I used some code that Andrew P had posted to add Textboxes when you click a specific datapoint) - This works by placing the chart events in a class module.
I also found a thread using Application.CommandBars("Zoom Tools") - but that I cannot get to work.

I will mess around some more - but this may be over my head.
Anyway - I am going to give it a try - I will post code (if I make any progress) - Sounds like there is interest. Good thing my wife is a very forgiving person - hehehe:ROFLMAO:
 
Upvote 0

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.
SHG
I did try you code - it workds file (I get error 2023 when using the application.caller - so I changed that) - however it simply resizes the chart - it does not Zoom (by that I mean changes the axis values)
 
Upvote 0
Ok – Had a look at the Chart Events – OMG – This article made me think twice http://www.cpearson.com/excel/Events.aspx - Then I came down to earth.
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:eek:ffice:eek:ffice" /><o:p></o:p>
So I decided to write a Zoom program without the use of Chart Events. Guess showing my real color – my apologies to the professionals. But this actually works quite well.
I have focused on XYscatter charts as both axes are numeric. However I would be very interested in anybody wanting to add to the code to include Line charts or any other improvements.
I show codes for two programs below
1) The Chart Zoomer program --- It is an Add-in – so save as XLAM file(optional)
2) Chartmaker – this program simply allow you to create 3 charts by a single click. So if you want to develop using your own charts – go for it.
The Chart Zoomer program works as follows (Click Tab ‘Add-Ins’ in Excel then <LOAD Zoomer>).
a) Click on a chart to Activate it.
b) 'Set Area' -- pressing this adds a textbox into the chart (width = ½ chart, Height=3/4 chart). Simply move and resize the textbox to select the area of the chart to be Zoomed.
c) 'Zoom in' - The chart is now zoomed to match your select.
d) <ZOOM Original>- 'Zoom Original' -- The charts is Zoomed Out to be like it existed before we started.
Note: The Zoomer program saves the original settings of the chart in the sheets(“Chart_size_Original”) – Make sure that SheetName exists – it can be blank – but name must exists. The sheet is emptied when you initialize Excel. But will track of any charts manipulated as long as you don’t shut down Excel – so you can always set focus to a chart and then Zoom Out to its original axes.
<o:p></o:p>
If you use the ChartMaker program (option2 above) for development – then it contains two macros or run the userform:
1) Creates charts from Arrays – all data is included.
2) Deletes all charts on active sheet.
<o:p></o:p>
So here is where I struggle (well big struggles – LOL):
a) How to show the Add-in tab in Excel if a Chart has focus (embedded into a worksheet – rather than a chart tab).
b) Having trouble getting the Xaxis coordinates just right – I compute what each pixel = on each of the axis (assuming that the .left/.width/.... properties are expressed in pixels) – But is doing this wrong – just off by 5% relative or so.
c) How to rescale none numeric axes – rescale is wrong word – I simply want to drop stuff in beginning and stuff in the end – But how is that done if scales are none numeric.
 
Last edited by a moderator:
Upvote 0
THIS IS A CORRECTION - SORRY FOR POSTING BAD CODE EARLIER. Hope I did not waste your time.

I have tested the code extensively - I moved code around - deleted comments and so fourth - then posted - did not check it properly


Ok – Had a look at the Chart Events – OMG – This article made me think twice http://www.cpearson.com/excel/Events.aspx - Then I came down to earth.<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:eek:ffice:eek:ffice" /><o:p></o:p>
<o:p> </o:p>
So I decided to write a Zoom program without the use of Chart Events. Guess showing my real color – my apologies to the professionals. But this actually works quite well.<o:p></o:p>
I have focused on XYscatter charts as both axes are numeric. However I would be very interested in anybody wanting to add to the code to include Line charts or any other improvements.<o:p></o:p>
I show codes for two programs below<o:p></o:p>
1) The Chart Zoomer program --- It is an Add-in – so save as XLAM file(optional)<o:p></o:p>
2) Chartmaker – this program simply allow you to create 3 charts by a single click. So if you want to develop using your own charts – go for it.<o:p></o:p>
The Chart Zoomer program works as follows (Click Tab ‘Add-Ins’ in Excel then <Load Zoomer>).<o:p></o:p>
a) Click on a chart to Activate it.<o:p></o:p>
b) ‘Set Area’ - pressing this adds a textbox into the chart (width = ½ chart, Height=3/4 chart). Simply move and resize the textbox to select the area of the chart to be Zoomed.<o:p></o:p>
c) ‘Zoom In’ - The chart is now zoomed to match your select.<o:p></o:p>
d) ‘Zoom Original’ - The charts is Zoomed Out to be like it existed before we started.<o:p></o:p>
Note: The XLAM program saves the original settings of the chart in the sheets(“Chart_size_Original”) – Make sure that SheetName exists – it can be blank – but name must exists. The sheet is emptied when you initialize Excel. But will keep track of any charts manipulated as long as you don’t shut down Excel – so you can always set focus to a chart and then Zoom Out to its original axes.<o:p></o:p>
<o:p> </o:p>
If you use the ChartMaker program (option2 above) for development – then it contains two macros or just run the userform:<o:p></o:p>
1) Creates charts from Arrays – all data is included.<o:p></o:p>
2) Deletes all charts on active sheet.<o:p></o:p>
<o:p> </o:p>
So here is where I struggle (well big struggles – LOL):<o:p></o:p>
a) How to show the Add-in tab in Excel if a Chart has focus (embedded into a worksheet – rather than a chart tab).<o:p></o:p>
b) Having trouble getting the Xaxis coordinates just right – I compute what each pixel = on each of the axis (assuming that the .left/.width/.... properties are expressed in pixels) – But is doing this wrong – just off by 5% relative or so.<o:p></o:p>
c) How to rescale none numeric axes – rescale is wrong word – I simply want to drop stuff in beginning and stuff in the end – But how is that done if scales are none numeric.<o:p></o:p>
d) How to adjust for secondary axes.<o:p></o:p>

Zoom tool - ThisWorkBook
Code:
Option Explicit
Private Sub Workbook_Open()
    On Error Resume Next
    Dim LastRow As Long
    Dim i As Long
    With ThisWorkbook.Sheets("Chart_size_Original")
        .UsedRange.ClearContents
        .Cells(1, 1) = "WorkBookName"
        .Cells(1, 2) = "SheetName"
        .Cells(1, 3) = "ChartName"
        .Cells(1, 4) = "X_Type"
        .Cells(1, 5) = "X_Min_primary"
        .Cells(1, 6) = "X_Max_primary"
        .Cells(1, 7) = "X_Min_Secondary"
        .Cells(1, 8) = "X_Max_Secondary"
        .Cells(1, 9) = "Y_Type"
        .Cells(1, 10) = "Y_Min_primary"
        .Cells(1, 11) = "Y_Max_primary"
        .Cells(1, 12) = "Y_Min_Secondary"
        .Cells(1, 13) = "Y_Max_Secondary"
    End With
    Dim ctrl As CommandBarControl
    Set ctrl = Application.CommandBars.FindControl(Tag:="Zoom Tool")
    If Not ctrl Is Nothing Then CleanUp
    Create_Menu
End Sub


Zoom Tool - Useform Nmae - FormZoom
Code:
Option Explicit
Option Compare Text
Private Sub CmdSetZoomArea_Click()
    Call SetZoomArea
End Sub
Private Sub CmdZoomIn_Click()
    Call ZoomIn
End Sub
Private Sub CmdZoomOut_Click()
    Call ZoomOut
End Sub


Zoom Tool - Module1
Code:
Option Explicit
Option Compare Text
Dim i As Long, ii As Long
Dim Astr As String, AAstr As String, AAAstr As String
Dim Asingle As Single, AAsingle As Single, AAAsingle As Single, AAAAsingle As Single
Dim strMsg As String
Dim intMsgType As Integer
Dim intResponse As Integer
Dim LeftBox, TopBox, HeightBox, WidthBox As Single
Dim PlotAreaLeft As Single, PlotAreatop As Single, PlotAreaHeight As Single, PlotAreaWidth As Single
Public ZoomTop As Single, ZoomLeft As Single, ZoomHeight As Single, ZoomWidth As Single
Public XaxisMin As Variant, XaxisMax As Variant, YaxisMin As Variant, YaxisMax As Variant
Public Status As String
Private Sub ChkIfChartExists(Status)
    On Error Resume Next
    Err.Clear
    Astr = ActiveChart.Name
    If Err.Number <> 0 Then
            Status = "No Charts"
            MsgBox "You need to Activate the chart to be manipulated"
            Exit Sub
    End If
    Status = "Ok"
    Err.Clear
End Sub
Public Sub SaveChartsMinMax()
    Dim LastRow As Long
    Dim NotExist As Boolean
    Dim Aint As Integer
    Dim Along As Long
    Dim Xvlue() As Variant
    Dim WrkBookName As String
    Dim ActiveShtName As String
    Dim ActChartName As String
    Dim Xmin As Single
    Dim Xmax As Single
    Dim Ymin As Single
    Dim Ymax As Single
    Dim Xtype As String
    Dim Ytype As String
    On Error Resume Next
    Err.Clear
    WrkBookName = ActiveWorkbook.Name
    ActiveShtName = ActiveSheet.Name
    ActChartName = ActiveChart.Name
    Aint = InStr(1, ActChartName, ActiveShtName)
    If Aint > 0 Then ActChartName = Right(ActChartName, Len(ActChartName) - Len(ActiveShtName) - 1)
    With ActiveChart
        Xmin = .Axes(xlValue).MinimumScale
        If Err.Number <> 0 Then MsgBox "ok what now"
        Xmax = .Axes(xlValue).MaximumScale
        If Err.Number <> 0 Then MsgBox "ok what now"
        Xtype = "Number"
        Ymin = .Axes(xlCategory).MinimumScale
        If Err.Number <> 0 Then
                Err.Clear
                Xvlue = .SeriesCollection(1).XValues
                If Err.Number <> 0 Then MsgBox "ok what now"
                Ytype = "String"
            Else
                Ymax = .Axes(xlCategory).MaximumScale
        End If
    End With
   
    With ThisWorkbook.Sheets("Chart_size_Original").UsedRange
        LastRow = .Rows(.Rows.Count).Row
    End With
    
    With ThisWorkbook.Sheets("Chart_size_Original")
        'see if settings already recorded
        NotExist = True
        For i = 2 To LastRow
            If .Cells(i, 2) = ActiveShtName And .Cells(i, 1) = WrkBookName Then
                Aint = InStr(1, ActChartName, .Cells(i, 3))
                If Aint > 0 Then NotExist = False
            End If
        Next i
        If NotExist Then
            .Cells(i, 1) = WrkBookName
            .Cells(i, 2) = ActiveShtName
            .Cells(i, 3) = ActChartName
            .Cells(i, 4) = Xtype
            .Cells(i, 5) = Xmin
            .Cells(i, 6) = Xmax
            .Cells(i, 7) = "Xmin_Not Implemented"
            .Cells(i, 8) = "Xmax_Not Implemented"
            .Cells(i, 9) = Ytype
            If Ytype = "String" Then
                    .Cells(i, 10) = UBound(Xvlue) & " Values"
                    For ii = 1 To UBound(Xvlue)
                        .Cells(i, ii + 10) = Xvlue(ii)
                    Next ii
                Else
                    .Cells(i, 10) = Ymin
                    .Cells(i, 11) = Ymax
                    .Cells(i, 12) = "Ymin_Not Implemented"
                    .Cells(i, 13) = "Ymax_Not Implemented"
            End If
        End If
    End With
End Sub
Public Sub SetZoomArea()
    Call ChkIfChartExists(Status)
    If Status = "No Charts" Then Exit Sub
    Call CheckIfXYtype(Status)
    If Status <> "XYscatter Type" Then
        strMsg = "The 'Zoomer' program is been developed for XYscatter type plots." & vbCrLf & "Not the type selected." & vbCrLf & "Do you wish to continue (may not work)"
        intMsgType = vbExclamation + vbYesNo
        intResponse = MsgBox(strMsg, intMsgType, ".ChartType property not tested")
        If intResponse <> 6 Then Exit Sub
    End If
    Call SaveChartsMinMax
    With ActiveChart
        For i = 1 To .Shapes.Count
            If .Shapes(i).Name = "X_ZoomArea_X" Then .Shapes(i).Delete
        Next i
        Err.Clear
        LeftBox = (.PlotArea.InsideWidth / 4) + .PlotArea.InsideLeft
        TopBox = (.PlotArea.InsideHeight / 4) + .PlotArea.Top
        HeightBox = .PlotArea.InsideHeight / 4 * 3
        WidthBox = .PlotArea.InsideWidth / 2
        .Shapes.AddTextbox(msoTextOrientationHorizontal, LeftBox, TopBox, WidthBox, HeightBox).Name = "X_ZoomArea_X"
        .Shapes("X_ZoomArea_X").TextEffect.Alignment = msoTextEffectAlignmentCentered
        .Shapes("X_ZoomArea_X").Select
        Astr = "Area to be zoomed." & vbCrLf
        Astr = Astr & "Adjust size to suit." & vbCrLf
        Astr = Astr & "After press <Zoom In>"
        Selection.Characters.Text = Astr
        With Selection.Characters.Font
            .Name = "Arial"
            .FontStyle = "Bold"
            Select Case WidthBox * HeightBox
                Case Is >= 80000
                    .Size = 36
                Case Is >= 40000
                    .Size = 24
                Case Is >= 20000
                    .Size = 18
                Case Is >= 15000
                    .Size = 16
                Case Is >= 10000
                    .Size = 12
                Case Else
                    .Size = 8
            End Select
            .Strikethrough = False
            .Superscript = True
            .Subscript = False
            .OutlineFont = False
            .Shadow = False
            .Underline = xlUnderlineStyleNone
            .ColorIndex = 1 'xlAutomatic
        End With
    End With
End Sub
Public Sub ZoomIn()
    Call ChkIfChartExists(Status)
    If Status = "No Charts" Then Exit Sub
    Err.Clear
    If ActiveChart.Shapes.Count <= 0 Then
        MsgBox "You need to 'Set Area' first"
        Status = "No Textbox"
        Exit Sub
    End If
    Status = ""
    For i = ActiveChart.Shapes.Count To 1 Step -1
        If ActiveChart.Shapes(i).Name = "X_ZoomArea_X" Then Status = "Found Box"
    Next i
    If Status <> "Found Box" Then
        MsgBox "You need to 'Set Area' first"
        Status = "No Textbox"
        Exit Sub
    End If
   
    Dim YaxisLabelWidth As Single
    Dim XaxisLabelHeight As Single
    Dim Xtype As String
    Dim PlotWidthDiff As Single
    Dim PlotHeightDiff As Single
    Dim Xvlue() As Variant
    Dim YnewMax As Single, YnewMin As Single, XnewMax As Single, XnewMin As Single
    Dim XaxisCurrentMin As Single
    Dim XaxisCurrentMax As Single
    With ActiveChart
        For i = .Shapes.Count To 1 Step -1
            If .Shapes(i).Name = "X_ZoomArea_X" Then
                ZoomTop = .Shapes(i).Top
                ZoomLeft = .Shapes(i).Left
                ZoomHeight = .Shapes(i).Height
                ZoomWidth = .Shapes(i).Width
                .Shapes(i).Delete
            End If
        Next i
      
        PlotAreaLeft = .PlotArea.Left  'InsideLeft
        PlotAreaHeight = .PlotArea.Height   'InsideHeight
        PlotAreaWidth = .PlotArea.Width  'InsideWidth
        PlotAreatop = .PlotArea.Top   'InsideTop
    End With
    With ActiveChart
        If .HasAxis(xlValue, xlSecondary) Then 'this is a problem to be solved
            MsgBox "Secondary 'xlValue' axis not implemented." & vbCrLf & "Make sure program behaves as expected."
        End If
        If .HasAxis(xlCategory, xlSecondary) Then 'this is a problem to be solved
            MsgBox "Secondary 'xlCategory' axis not implemented." & vbCrLf & "Make sure program behaves as expected."
        End If
        On Error Resume Next
        Err.Clear
        XaxisCurrentMin = .Axes(xlCategory).MinimumScale
        If Err.Number <> 0 Then
                Xtype = "string"
                'Err.Clear
                'Xvlue = .SeriesCollection(1).Values
                'If Err.Number <> 0 Then Stop
                'XaxisCurrentMin = Xvlue(1)
                'XaxisCurrentMax = Xvlue(UBound(Xvlue))
            Else
                XaxisCurrentMax = .Axes(xlCategory).MaximumScale
        End If
    End With
        
    YaxisMin = ActiveChart.Axes(xlValue).MinimumScale
    YaxisMax = ActiveChart.Axes(xlValue).MaximumScale
    XaxisMin = ActiveChart.Axes(xlCategory).MinimumScale
    XaxisMax = ActiveChart.Axes(xlCategory).MaximumScale
    
    YaxisLabelWidth = ActiveChart.PlotArea.InsideLeft - ActiveChart.PlotArea.Left
    XaxisLabelHeight = ActiveChart.PlotArea.Top + ActiveChart.PlotArea.Height - (ActiveChart.PlotArea.Top + ActiveChart.PlotArea.InsideHeight)
    
    'Works - do not touch
    YnewMax = YaxisMax - (ZoomTop - ActiveChart.PlotArea.InsideTop) * ((YaxisMax - YaxisMin) / ActiveChart.PlotArea.InsideHeight)
   'Works do not touch
    YnewMin = YnewMax - (ZoomHeight * (YaxisMax - YaxisMin) / ActiveChart.PlotArea.InsideHeight)
    XnewMin = XaxisMin + (ZoomLeft - ActiveChart.PlotArea.Left) * ((XaxisMax - XaxisMin) / (ActiveChart.PlotArea.InsideWidth + (YaxisLabelWidth * 2)))
     
    If ActiveChart.HasAxis(xlValue, xlSecondary) Then
            YnewMax = YaxisMax - (ZoomTop - ActiveChart.PlotArea.InsideTop) _
                * ((YaxisMax - YaxisMin) / (ActiveChart.PlotArea.InsideHeight + YaxisLabelWidth))
        Else
            XnewMax = XnewMin + (ZoomWidth * ((XaxisMax - XaxisMin) / (ActiveChart.PlotArea.InsideWidth)))
    End If
    
    ActiveChart.Axes(xlValue).MinimumScale = YnewMin 'Format(minimumX, "#####.##")
    ActiveChart.Axes(xlValue).MaximumScale = YnewMax 'Format(maximumX, "#####.##")
    
    If Xtype = "string" Then
            MsgBox "Only XYscatter types supported - Xaxis will not be rescaled"
            
        Else
 
            ActiveChart.Axes(xlCategory).MinimumScale = XnewMin  ' Format(minimumX, "#####.##")
            ActiveChart.Axes(xlCategory).MaximumScale = XnewMax  'Format(maximumX, "#####.##")
    End If
    
End Sub
Public Sub ZoomOut()
    Call ChkIfChartExists(Status)
    If Status = "No Charts" Then Exit Sub
    Dim LastRow As Long
    Dim Aint As Integer
    Dim WrkBookName As String
    Dim ActiveShtName As String
    Dim ActChartName As String
    Dim Xmin As Single
    Dim Xmax As Single
    Dim Ymin As Single
    Dim Ymax As Single
    On Error Resume Next
    Err.Clear
    WrkBookName = ActiveWorkbook.Name
    If Err.Number <> 0 Then MsgBox "Weird"
    ActiveShtName = ActiveSheet.Name
    If Err.Number <> 0 Then MsgBox "Weird"
    ActChartName = ActiveChart.Name
    If Err.Number <> 0 Then MsgBox "Weird"
    Aint = InStr(1, ActChartName, ActiveShtName)
    If Aint > 0 Then
        ActChartName = Right(ActChartName, Len(ActChartName) - Len(ActiveShtName) - 1)
    End If
    With ThisWorkbook.Sheets("Chart_size_Original").UsedRange
        LastRow = .Rows(.Rows.Count).Row
    End With
    With ThisWorkbook.Sheets("Chart_size_Original")
        For i = 2 To LastRow
            If .Cells(i, 2) = ActiveShtName And .Cells(i, 1) = WrkBookName Then
                Aint = InStr(1, ActChartName, .Cells(i, 3))
                If Aint > 0 Then
                    If .Cells(i, 4) = "String" Then Stop 'Never seen this before
                    If .Cells(i, 9) = "String" Then
                          
                            ActiveChart.Axes(xlValue).MinimumScale = .Cells(i, 5)
                            ActiveChart.Axes(xlValue).MaximumScale = .Cells(i, 6)
                   
                            'ActiveChart.Axes(xlCategory).MinimumScale = 9
                            'ActiveChart.Axes(xlCategory).MaximumScale = 14
                            
                        Else
                            ActiveChart.Axes(xlValue).MinimumScale = .Cells(i, 5)
                            ActiveChart.Axes(xlValue).MaximumScale = .Cells(i, 6)
                    
                            ActiveChart.Axes(xlCategory).MinimumScale = .Cells(i, 10)
                            ActiveChart.Axes(xlCategory).MaximumScale = .Cells(i, 11)
            
                    End If
                End If
            End If
        Next i
    End With
End Sub
Private Sub CheckIfXYtype(Status)
    Select Case ActiveChart.ChartType
        Case -4169, -4151, 72, 73, 74, 75
            Status = "XYscatter Type"
        Case Else
            Status = "Not XYscatter Type"
    End Select
End Sub

Zoom Tool - Module Name - mUI
Code:
Option Explicit
Option Compare Text
Sub Create_Menu()
    Dim cmdbr As CommandBar, cbc As CommandBarControl, cbcNew As CommandBarControl
    Dim cbcOpt As CommandBarControl
    Set cmdbr = Application.CommandBars("Worksheet Menu Bar")
    Set cbc = cmdbr.Controls.Add(Type:=msoControlPopup, temporary:=True)
    With cbc
        .Caption = "&Zoom Tool"
        .Visible = True
        .Tag = "Zoom Tool"
        .TooltipText = "Zoom your Excel charts"
        .Move before:=cmdbr.Controls.Count - 1
    End With
    Set cbcNew = CreateControl(cbc, "&Open Zoomer", "Load Zoomer", msoControlButton, , "LoadFormZoom")
    Set cbcNew = CreateControl(cbc, "&Close Zoomer", "Unload Zoomer", msoControlButton, , "UnLoadFormZoom")
End Sub
Sub CleanUp()
    Dim cbc As CommandBarControl
    On Error Resume Next
    Set cbc = Application.CommandBars("Worksheet Menu Bar").Controls("Zoom Tool")
    If Not cbc Is Nothing Then
        Do
            cbc.Delete
            Set cbc = Nothing
            Set cbc = Application.CommandBars("Worksheet Menu Bar").Controls("Zoom Tool")
        Loop Until cbc Is Nothing
    End If
    
    Set cbc = Application.CommandBars("Cell").Controls("&Open Zoomer")
    Do While Not cbc Is Nothing
        cbc.Delete
        Set cbc = Nothing
        Set cbc = Application.CommandBars("Cell").Controls("&Open Zoomer")
    Loop
    Set cbc = Application.CommandBars("Cell").Controls("&Close Zoomer")
    Do While Not cbc Is Nothing
        cbc.Delete
        Set cbc = Nothing
        Set cbc = Application.CommandBars("Cell").Controls("&Close Zoomer")
    Loop
End Sub
Function CreateControl(container As Variant, strCap As String, strTip As String, lngType As MsoControlType, Optional tagLine, Optional Macro) As CommandBarControl
    Dim ctrl
    Set ctrl = container.Controls.Add(lngType)
    With ctrl
        .Caption = strCap
        .TooltipText = strTip
        If Not IsMissing(tagLine) Then .Tag = tagLine
        If Not IsMissing(Macro) Then .OnAction = Macro
    End With
    Set CreateControl = ctrl
End Function
Private Sub LoadFormZoom()
    Load FormZoom
    FormZoom.Show vbModeless
End Sub
Private Sub UnLoadFormZoom()
    Unload FormZoom
End Sub




ChartMaker - optional

Shhet1
Code:
Option Explicit
Option Compare Text
Private Sub CommandButton1_Click()
    Load FormMakeCharts
    FormMakeCharts.Show vbModeless
End Sub


ChartMaker - Userform name- FormMakeCharts
Code:
Option Explicit
Option Compare Text
Dim Astr As String
Dim Along As Long
Dim i As Long
Dim Asingle As Single, AAsingle As Single, AAAsingle As Single, AAAAsingle As Single
Private Sub MakeNewCharts_Click()
     Call AddHistochart
End Sub
Private Sub CmdClearCharts_Click()
    Dim NumCharts As Long
    NumCharts = ActiveSheet.ChartObjects.Count
    If NumCharts > 0 Then
        For i = NumCharts To 1 Step -1
            ActiveSheet.ChartObjects(i).Delete
        Next i
    End If
End Sub

ChartMaker - Module1
Code:
Option Explicit
Option Compare Text
Dim i As Long, ii As Long
Dim Astr As String
Dim Asingle As Single, AAsingle As Single, AAAsingle As Single, AAAAsingle As Single
Public Sub AddHistochart()
    Dim NumCharts As Long
    Dim YPlotValues() As Variant
    Dim XPlotValues() As Single
    Dim i As Long, ii As Long
    Dim frequency() As Long 'As Variant
    Dim binlabel() As Single 'As Variant
    Dim binsize As Single 'As Variant
    Dim minimumX As Single
    Dim maximumX As Single
    Dim NumBins As Long
    Dim Along As Long, AAlong As Long
    Dim NumParameters As Long
    Dim HighFrequency As Long
    Dim Asingle As Single
    Dim Avar As Variant
    Dim MeanVal() As Single
    Dim CounterVal() As Long
    Dim WrkBookName As String
    Dim ActiveShtName As String
    Dim ActChartName As String
    Dim Aint As Integer
    
    Application.StatusBar = "Making Histogram"
    NumBins = 11
    NumParameters = 1
   
    ReDim frequency(1 To NumBins)
    ReDim binlabel(1 To NumBins)
    
    Call GetArrayValue(YPlotValues, XPlotValues, minimumX, maximumX)
    binsize = (maximumX - minimumX) / NumBins
    For i = 1 To NumBins
        binlabel(i) = Format(minimumX + 0.5 * binsize + (i - 1) * binsize, "####0.00")
    Next i
    HighFrequency = 0
    For i = 1 To NumBins - 1
        For ii = 1 To UBound(YPlotValues)
            If YPlotValues(ii) >= binlabel(i) - 0.5 * binsize And YPlotValues(ii) < binlabel(i + 1) - 0.5 * binsize Then
                frequency(i) = frequency(i) + 1
                If frequency(i) > HighFrequency Then HighFrequency = frequency(i)
            End If
        Next ii
    Next i
    '******* last bin
    For i = 1 To UBound(YPlotValues)
        If YPlotValues(i) >= binlabel(NumBins) - 0.5 * binsize And YPlotValues(i) < maximumX Then
            frequency(NumBins) = frequency(NumBins) + 1
            If frequency(NumBins) > HighFrequency Then HighFrequency = frequency(i)
        End If
    Next i
    NumCharts = ActiveSheet.ChartObjects.Count
    If NumCharts > 0 Then
        For i = NumCharts To 1 Step -1
            ActiveSheet.ChartObjects(i).Delete
        Next i
    End If
    Along = 1
    ReDim MeanVal(1 To HighFrequency)
    ReDim CounterVal(1 To HighFrequency)
    Along = UBound(YPlotValues)
    Asingle = 0
    AAlong = 0
    For i = 1 To UBound(YPlotValues)
        Asingle = Asingle + YPlotValues(i)
        AAlong = AAlong + 1
    Next i
    Asingle = Asingle / AAlong
    For i = 1 To HighFrequency
        CounterVal(i) = i '- 1
        MeanVal(i) = Asingle
    Next i
  
StartMakingCharts:
    
    ActiveSheet.ChartObjects.Add Left:=50, Top:=50, Width:=600, Height:=300
    NumCharts = ActiveSheet.ChartObjects.Count
    If NumCharts = 2 Then
        ActiveSheet.ChartObjects(NumCharts).Left = ActiveSheet.ChartObjects(NumCharts - 1).Left
        ActiveSheet.ChartObjects(NumCharts).Top = ActiveSheet.ChartObjects(NumCharts - 1).Top + ActiveSheet.ChartObjects(NumCharts - 1).Height + 20
        ActiveSheet.ChartObjects(NumCharts).Height = ActiveSheet.ChartObjects(NumCharts - 1).Height
        ActiveSheet.ChartObjects(NumCharts).Width = ActiveSheet.ChartObjects(NumCharts - 1).Width
    End If
    If NumCharts = 3 Then
        ActiveSheet.ChartObjects(NumCharts).Left = ActiveSheet.ChartObjects(1).Left + ActiveSheet.ChartObjects(1).Width + 20
        ActiveSheet.ChartObjects(NumCharts).Top = ActiveSheet.ChartObjects(1).Top
        ActiveSheet.ChartObjects(NumCharts).Height = ActiveSheet.ChartObjects(1).Height
        ActiveSheet.ChartObjects(NumCharts).Width = ActiveSheet.ChartObjects(1).Width
    End If
    'NumCharts = ActiveSheet.ChartObjects.Count
    ActiveSheet.ChartObjects(NumCharts).Activate
    Dim Achart As ChartObject
    Set Achart = ActiveSheet.ChartObjects(NumCharts)
    
    With Achart.Chart     'Set chart properties
        Select Case NumCharts
            Case 1
                .ChartType = xlColumnClustered
                '.ChartType = xlLineMarkers
            Case 2
                .ChartType = xlXYScatterSmoothNoMarkers
                '.ChartType = xlLine
            Case 3
                .ChartType = xlXYScatter
                '.ChartType = xlLineMarkers
            Case Else
                MsgBox "Not implemented"
        End Select
        .SeriesCollection.NewSeries
        .HasLegend = False
        .Axes(xlCategory).MajorTickMark = xlTickMarkOutside
        .Axes(xlValue).MajorTickMark = xlTickMarkOutside 'xlTickMarkNone
        If NumCharts = 3 Then
            .Axes(xlValue).MinimumScale = Format(minimumX, "#####.##")
            .Axes(xlValue).MaximumScale = Format(maximumX, "#####.##")
            .Axes(xlCategory).MinimumScale = Format(minimumX, "#####.##")
            .Axes(xlCategory).MaximumScale = Format(maximumX, "#####.##")
            .SeriesCollection(NumParameters).Values = Array(XPlotValues)
            .SeriesCollection(NumParameters).XValues = Array(YPlotValues)
            .Axes(xlCategory).HasTitle = True
            .Axes(xlCategory).AxisTitle.Characters.Text = "Reference data"
            .Axes(xlValue).HasTitle = True
            .Axes(xlValue).AxisTitle.Characters.Text = "Predicted values"
        End If
        If NumCharts = 1 Or NumCharts = 2 Then
            .Axes(xlValue).MinimumScale = 0
            .Axes(xlValue).MaximumScale = HighFrequency + 1
            .SeriesCollection(NumParameters).Values = Array(frequency)
            .SeriesCollection(NumParameters).XValues = Array(binlabel)
        
            .Axes(xlCategory).HasTitle = True
            .Axes(xlCategory).AxisTitle.Characters.Text = "Predictions"
            .Axes(xlValue).HasTitle = True
            .Axes(xlValue).AxisTitle.Characters.Text = "Frequency"
        End If
        If NumCharts = 2 Then
            .SeriesCollection.NewSeries
            .SeriesCollection(NumParameters + 1).Values = Array(frequency)
            .SeriesCollection(NumParameters + 1).XValues = Array(binlabel)
            .SeriesCollection(NumParameters + 1).Smooth = True
             
            '.SeriesCollection.NewSeries 'Fonny series
            '.SeriesCollection(NumParameters + 2).Values = Array(CounterVal)
            '.SeriesCollection(NumParameters + 2).XValues = Array(MeanVal) ' creates bars
            '.SeriesCollection(NumParameters + 2).Smooth = True
            '.HasAxis(xlValue, xlSecondary) = True
            '.SeriesCollection(NumParameters + 2).AxisGroup = 2
    
               
    .Axes(xlCategory).MinimumScale = Format(minimumX, "#####.##")
    .Axes(xlCategory).MaximumScale = Format(maximumX, "#####.##")
    
    GoTo dasjdhjahda
            .HasAxis(xlCategory, xlSecondary) = True
            .Axes(xlCategory, xlSecondary).HasTitle = True
            .Axes(xlCategory, xlSecondary).AxisTitle.Caption = "This is it" '.Characters.Text = "2nd axis"
       
            With .Axes(xlValue, xlSecondary)
                .MinimumScale = 0
                .MaximumScale = 25
                .MinorUnitIsAuto = True
                .MajorUnit = 5
                .Crosses = xlCustom
                .CrossesAt = 0
                .ReversePlotOrder = False
                .ScaleType = xlLinear
                .DisplayUnit = xlNone
            End With
dasjdhjahda:
    
            'Selection.TickLabels.NumberFormat = "0"
            
           
            
            ActiveChart.Axes(xlValue).Select
        End If
        WrkBookName = ActiveWorkbook.Name
        ActiveShtName = ActiveSheet.Name
        ActChartName = ActiveChart.Name
        Aint = InStr(1, ActChartName, ActiveShtName)
        If Aint > 0 Then
            ActChartName = Right(ActChartName, Len(ActChartName) - Len(ActiveShtName) - 1)
        End If
       
        .HasTitle = True
        .ChartTitle.Text = WrkBookName & "--" & ActiveShtName & "--" & ActChartName 'Adds header for entire chart
            
    End With
    'ActiveChart.Select
    Set Achart = Nothing
    If NumCharts < 3 Then GoTo StartMakingCharts
    Application.StatusBar = "Completed ---- Making Histogram/Curve Histogram - Start new Task"
End Sub
 
Private Sub GetArrayValue(YPlotValues, XPlotValues, minimumX, maximumX)
Dim NumObvs As Long
NumObvs = 177
minimumX = 9.1
maximumX = 14
ReDim YPlotValues(1 To NumObvs)
ReDim XPlotValues(1 To NumObvs)
YPlotValues(1) = 10.496: XPlotValues(1) = 10.4
YPlotValues(2) = 10.3: XPlotValues(2) = 10.2
YPlotValues(3) = 10.469: XPlotValues(3) = 10.6
YPlotValues(4) = 10.381: XPlotValues(4) = 10.4
YPlotValues(5) = 10.148: XPlotValues(5) = 10.1
YPlotValues(6) = 10.306: XPlotValues(6) = 10.6
YPlotValues(7) = 10.457: XPlotValues(7) = 10.5
YPlotValues(8) = 9.893: XPlotValues(8) = 9.9
YPlotValues(9) = 9.881: XPlotValues(9) = 9.7
YPlotValues(10) = 9.44: XPlotValues(10) = 10
YPlotValues(11) = 9.276: XPlotValues(11) = 9.3
YPlotValues(12) = 9.162: XPlotValues(12) = 9.2
YPlotValues(13) = 9.721: XPlotValues(13) = 9.6
YPlotValues(14) = 9.61: XPlotValues(14) = 9.6
YPlotValues(15) = 9.804: XPlotValues(15) = 9.7
YPlotValues(16) = 9.794: XPlotValues(16) = 9.93
YPlotValues(17) = 10.27: XPlotValues(17) = 10.21
YPlotValues(18) = 10.416: XPlotValues(18) = 10.38
YPlotValues(19) = 10.571: XPlotValues(19) = 10.62
YPlotValues(20) = 10.793: XPlotValues(20) = 11
YPlotValues(21) = 11.061: XPlotValues(21) = 11
YPlotValues(22) = 11.28: XPlotValues(22) = 11.25
YPlotValues(23) = 11.472: XPlotValues(23) = 11.41
YPlotValues(24) = 11.527: XPlotValues(24) = 11.58
YPlotValues(25) = 11.809: XPlotValues(25) = 11.82
YPlotValues(26) = 11.962: XPlotValues(26) = 11.9
YPlotValues(27) = 12.141: XPlotValues(27) = 12.11
YPlotValues(28) = 12.328: XPlotValues(28) = 12.28
YPlotValues(29) = 12.49: XPlotValues(29) = 12.45
YPlotValues(30) = 12.677: XPlotValues(30) = 12.58
YPlotValues(31) = 12.871: XPlotValues(31) = 12.92
YPlotValues(32) = 12.951: XPlotValues(32) = 12.97
YPlotValues(33) = 13.15: XPlotValues(33) = 13.11
YPlotValues(34) = 13.305: XPlotValues(34) = 13.28
YPlotValues(35) = 13.272: XPlotValues(35) = 13.26
YPlotValues(36) = 13.168: XPlotValues(36) = 13.14
YPlotValues(37) = 13.457: XPlotValues(37) = 13.44
YPlotValues(38) = 13.411: XPlotValues(38) = 1344
YPlotValues(39) = 13.613: XPlotValues(39) = 13.62
YPlotValues(40) = 13.651: XPlotValues(40) = 13.62
YPlotValues(41) = 13.91: XPlotValues(41) = 13.82
YPlotValues(42) = 11.053: XPlotValues(42) = 11.12
YPlotValues(43) = 11.176: XPlotValues(43) = 11.32
YPlotValues(44) = 11.153: XPlotValues(44) = 11.22
YPlotValues(45) = 11.902: XPlotValues(45) = 11.72
YPlotValues(46) = 11.111: XPlotValues(46) = 11.02
YPlotValues(47) = 11.316: XPlotValues(47) = 11.42
YPlotValues(48) = 11.839: XPlotValues(48) = 11.62
YPlotValues(49) = 11.633: XPlotValues(49) = 11.562
YPlotValues(50) = 11.752: XPlotValues(50) = 11.862
YPlotValues(51) = 11.709: XPlotValues(51) = 11.762
YPlotValues(52) = 11.868: XPlotValues(52) = 11.762
YPlotValues(53) = 12.061: XPlotValues(53) = 12.062
YPlotValues(54) = 12.223: XPlotValues(54) = 12.262
YPlotValues(55) = 12.164: XPlotValues(55) = 12.162
YPlotValues(56) = 12.308: XPlotValues(56) = 12.462
YPlotValues(57) = 12.541: XPlotValues(57) = 12.62
YPlotValues(58) = 12.389: XPlotValues(58) = 12.562
YPlotValues(59) = 12.697: XPlotValues(59) = 12.62
YPlotValues(60) = 12.722: XPlotValues(60) = 12.62
YPlotValues(61) = 12.458: XPlotValues(61) = 12.562
YPlotValues(62) = 12.888: XPlotValues(62) = 12.62
YPlotValues(63) = 12.999: XPlotValues(63) = 12.92
YPlotValues(64) = 12.072: XPlotValues(64) = 12.22
YPlotValues(65) = 12.953: XPlotValues(65) = 12.62
YPlotValues(66) = 11.03: XPlotValues(66) = 11.12
YPlotValues(67) = 11.192: XPlotValues(67) = 11.32
YPlotValues(68) = 11.086: XPlotValues(68) = 11.6
YPlotValues(69) = 11.197: XPlotValues(69) = 11.42
YPlotValues(70) = 11.236: XPlotValues(70) = 11.62
YPlotValues(71) = 11.324: XPlotValues(71) = 11.362
YPlotValues(72) = 11.696: XPlotValues(72) = 11.62
YPlotValues(73) = 11.732: XPlotValues(73) = 11.562
YPlotValues(74) = 11.943: XPlotValues(74) = 11.862
YPlotValues(75) = 12.113: XPlotValues(75) = 12.362
YPlotValues(76) = 12.17: XPlotValues(76) = 12.162
YPlotValues(77) = 12.475: XPlotValues(77) = 12.462
YPlotValues(78) = 12.349: XPlotValues(78) = 12.262
YPlotValues(79) = 13.006: XPlotValues(79) = 13.22
YPlotValues(80) = 12.688: XPlotValues(80) = 12.62
YPlotValues(81) = 12.655: XPlotValues(81) = 12.62
YPlotValues(82) = 12.869: XPlotValues(82) = 12.72
YPlotValues(83) = 13.098: XPlotValues(83) = 13.12
YPlotValues(84) = 13.127: XPlotValues(84) = 13.22
YPlotValues(85) = 13.146: XPlotValues(85) = 13.12
YPlotValues(86) = 13.493: XPlotValues(86) = 13.42
YPlotValues(87) = 13.746: XPlotValues(87) = 13.62
YPlotValues(88) = 13.729: XPlotValues(88) = 13.62
YPlotValues(89) = 13.833: XPlotValues(89) = 13.92
YPlotValues(90) = 14.026: XPlotValues(90) = 14.02
YPlotValues(91) = 13.958: XPlotValues(91) = 13.62
YPlotValues(92) = 11.208: XPlotValues(92) = 11.32
YPlotValues(93) = 11.098: XPlotValues(93) = 11.22
YPlotValues(94) = 11.4: XPlotValues(94) = 11.52
YPlotValues(95) = 11.221: XPlotValues(95) = 11.32
YPlotValues(96) = 11.22: XPlotValues(96) = 11.02
YPlotValues(97) = 11.191: XPlotValues(97) = 11.02
YPlotValues(98) = 10.946: XPlotValues(98) = 10.72
YPlotValues(99) = 11.353: XPlotValues(99) = 11.42
YPlotValues(100) = 11.274: XPlotValues(100) = 11.32
YPlotValues(101) = 11.361: XPlotValues(101) = 11.32
YPlotValues(102) = 11.173: XPlotValues(102) = 11.22
YPlotValues(103) = 11.034: XPlotValues(103) = 11.12
YPlotValues(104) = 10.986: XPlotValues(104) = 10.02
YPlotValues(105) = 11.025: XPlotValues(105) = 11.02
YPlotValues(106) = 10.88: XPlotValues(106) = 10.72
YPlotValues(107) = 10.862: XPlotValues(107) = 10.72
YPlotValues(108) = 10.852: XPlotValues(108) = 10.72
YPlotValues(109) = 11.185: XPlotValues(109) = 11.32
YPlotValues(110) = 10.71: XPlotValues(110) = 10.42
YPlotValues(111) = 10.83: XPlotValues(111) = 10.72
YPlotValues(112) = 10.961: XPlotValues(112) = 10.92
YPlotValues(113) = 10.71: XPlotValues(113) = 10.52
YPlotValues(114) = 10.895: XPlotValues(114) = 10.72
YPlotValues(115) = 10.66: XPlotValues(115) = 10.62
YPlotValues(116) = 10.712: XPlotValues(116) = 10.72
YPlotValues(117) = 10.86: XPlotValues(117) = 10.52
YPlotValues(118) = 10.777: XPlotValues(118) = 10.72
YPlotValues(119) = 10.779: XPlotValues(119) = 10.72
YPlotValues(120) = 10.596: XPlotValues(120) = 10.52
YPlotValues(121) = 10.754: XPlotValues(121) = 10.92
YPlotValues(122) = 10.488: XPlotValues(122) = 10.42
YPlotValues(123) = 10.829: XPlotValues(123) = 10.72
YPlotValues(124) = 10.667: XPlotValues(124) = 10.62
YPlotValues(125) = 10.527: XPlotValues(125) = 10.52
YPlotValues(126) = 10.378: XPlotValues(126) = 10.32
YPlotValues(127) = 10.188: XPlotValues(127) = 10.22
YPlotValues(128) = 10.566: XPlotValues(128) = 10.42
YPlotValues(129) = 10.468: XPlotValues(129) = 10.32
YPlotValues(130) = 10.488: XPlotValues(130) = 10.32
YPlotValues(131) = 10.389: XPlotValues(131) = 10.22
YPlotValues(132) = 10.188: XPlotValues(132) = 10.12
YPlotValues(133) = 10.29: XPlotValues(133) = 10.32
YPlotValues(134) = 10.313: XPlotValues(134) = 10.32
YPlotValues(135) = 10.289: XPlotValues(135) = 10.22
YPlotValues(136) = 10.214: XPlotValues(136) = 10.22
YPlotValues(137) = 10.194: XPlotValues(137) = 10.12
YPlotValues(138) = 10.126: XPlotValues(138) = 10.12
YPlotValues(139) = 10.125: XPlotValues(139) = 10.12
YPlotValues(140) = 10.071: XPlotValues(140) = 10.02
YPlotValues(141) = 10.248: XPlotValues(141) = 10.32
YPlotValues(142) = 10.157: XPlotValues(142) = 10.22
YPlotValues(143) = 10.242: XPlotValues(143) = 10.32
YPlotValues(144) = 10.128: XPlotValues(144) = 10.12
YPlotValues(145) = 10.028: XPlotValues(145) = 10.02
YPlotValues(146) = 10.304: XPlotValues(146) = 10.32
YPlotValues(147) = 10.092: XPlotValues(147) = 10.02
YPlotValues(148) = 10.038: XPlotValues(148) = 10.12
YPlotValues(149) = 9.995: XPlotValues(149) = 9.62
YPlotValues(150) = 10.132: XPlotValues(150) = 10.32
YPlotValues(151) = 10.131: XPlotValues(151) = 10.22
YPlotValues(152) = 9.857: XPlotValues(152) = 9.62
YPlotValues(153) = 10.22: XPlotValues(153) = 10.42
YPlotValues(154) = 9.977: XPlotValues(154) = 9.92
YPlotValues(155) = 10.135: XPlotValues(155) = 10.62
YPlotValues(156) = 10.181: XPlotValues(156) = 10.32
YPlotValues(157) = 10.042: XPlotValues(157) = 10.02
YPlotValues(158) = 9.988: XPlotValues(158) = 10.02
YPlotValues(159) = 10.151: XPlotValues(159) = 10.12
YPlotValues(160) = 10.108: XPlotValues(160) = 10.22
YPlotValues(161) = 10.16: XPlotValues(161) = 10.02
YPlotValues(162) = 10.088: XPlotValues(162) = 10.12
YPlotValues(163) = 10.224: XPlotValues(163) = 10.12
YPlotValues(164) = 10.078: XPlotValues(164) = 10.02
YPlotValues(165) = 10.05: XPlotValues(165) = 10.02
YPlotValues(166) = 9.901: XPlotValues(166) = 10.02
YPlotValues(167) = 9.915: XPlotValues(167) = 10.12
YPlotValues(168) = 9.988: XPlotValues(168) = 9.829
YPlotValues(169) = 9.999: XPlotValues(169) = 9.72
YPlotValues(170) = 10.005: XPlotValues(170) = 10.02
YPlotValues(171) = 9.962: XPlotValues(171) = 9.62
YPlotValues(172) = 9.971: XPlotValues(172) = 10.02
YPlotValues(173) = 10.075: XPlotValues(173) = 10.12
YPlotValues(174) = 9.989: XPlotValues(174) = 10.02
YPlotValues(175) = 10.015: XPlotValues(175) = 10.12
YPlotValues(176) = 10.086: XPlotValues(176) = 10.9
YPlotValues(177) = 10.172: XPlotValues(177) = 10.32 
End Sub
 
Upvote 0
I've been working on this over the weekend and after some painstaking debugging work here is what I 've come up with.

Workbook demo.

The code uses Windows GDI functions to do the zooming. After enabling the zooming , the chart is zoomed-in by simply moving the mouse over the chart area and goes back to its initial zoom when the mouse is moved away.

One known limitation to this API aproach is the gradual blurring of the image as you zoom-in. The greater the zoom the worst the image but all in all I think it is not that bad.

Here is the code for the record: (In a Standard Module)

Code:
'/Jaafar Tribak.
'/This code uses GDI functions
'/to zoom worksheet embeeded charts.

Option Explicit

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type Rect
    left As Long
    top As Long
    right As Long
    bottom As Long
End Type


Private Type COLORADJUSTMENT
        caSize As Integer
        caFlags As Integer
        caIlluminantIndex As Integer
        caRedGamma As Integer
        caGreenGamma As Integer
        caBlueGamma As Integer
        caReferenceBlack As Integer
        caReferenceWhite As Integer
        caContrast As Integer
        caBrightness As Integer
        caColorfulness As Integer
        caRedGreenTint As Integer
End Type


Private Declare Function GetDeviceCaps Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal nIndex As Long) As Long

Private Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long

Private Declare Function ReleaseDC Lib "user32" ( _
ByVal hwnd As Long, _
ByVal hdc As Long) As Long

Private Declare Function DeleteDC Lib "gdi32" _
(ByVal hdc As Long) As Long

Private Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hdc As Long) As Long

Private Declare Function CreateCompatibleBitmap Lib "gdi32" _
(ByVal hdc As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long) As Long

Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long

Private Declare Function SetStretchBltMode Lib "gdi32" _
(ByVal hdc As Long, ByVal nStretchMode As Long) As Long

Private Declare Function GetColorAdjustment Lib "gdi32" _
(ByVal hdc As Long, lpca As COLORADJUSTMENT) As Long

Private Declare Function SetColorAdjustment Lib "gdi32" _
(ByVal hdc As Long, lpca As COLORADJUSTMENT) As Long

Private Declare Function GetStretchBltMode Lib "gdi32" _
(ByVal hdc As Long) As Long

Private Declare Function BitBlt Lib "gdi32" _
(ByVal hDestDC As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hSrcDC As Long, _
ByVal xSrc As Long, _
ByVal ySrc As Long, _
ByVal dwRop As Long) As Long

Private Declare Function StretchBlt Lib "gdi32" _
(ByVal hdc As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hSrcDC As Long, _
ByVal xSrc As Long, _
ByVal ySrc As Long, _
ByVal nSrcWidth As Long, _
ByVal nSrcHeight As Long, _
ByVal dwRop As Long) As Long

Private Declare Function InvalidateRect Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal lpRect As Long, _
ByVal bErase As Long) As Long

Private Declare Function RedrawWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal lprcUpdate As Long, _
ByVal hrgnUpdate As Long, _
ByVal fuRedraw As Long) As Long

Private Declare Function SetRect Lib "user32.dll" _
(ByRef lpRect As Rect, _
ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long

Private Declare Function CreateRectRgn Lib "gdi32.dll" _
(ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long

Private Declare Function GetCurrentProcessId Lib _
"kernel32" () As Long

Private Declare Function GetWindowThreadProcessId Lib "user32" _
(ByVal hwnd As Long, ByRef lpdwProcessId As Long) As Long

Private Declare Function GetCursorPos Lib "user32" _
(lpPoint As POINTAPI) As Long

Private Declare Function PtInRect Lib "user32" _
(lpRect As Rect, ByVal x As Long, ByVal y As Long) As Long

Private Declare Function WindowFromPoint Lib "user32" _
(ByVal xPoint As Long, ByVal yPoint As Long) As Long

Private Declare Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As Long)

Private Const SRCCOPY As Long = &HCC0020
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const PointsPerInch As Long = 72
Private Const RDW_INVALIDATE As Long = &H1
Private Const RDW_ALLCHILDREN As Long = &H80
Private Const HALFTONE As Long = 4

Private tInitRect As Rect
Private lMemoryDC As Long
Private lDC As Long
Private i As Long
Private lRgn As Long
Private lInitScrRow As Long
Private lInitScrCol As Long
Private bInside As Boolean
Private bEnableZooming As Boolean
Private oChart As ChartObject


'/Public Procedures...
Public Sub EnableZooming()

    Call ZoomChart(Sheets("Test").ChartObjects(1))

End Sub

Public Sub DisableZooming()

    bEnableZooming = False
    InvalidateRect 0, 0, 0
    ReleaseDC lDC, 0
    DeleteDC lMemoryDC
    If Not oChart Is Nothing Then
     oChart.OnAction = ""
    End If
    
End Sub


'/Private Procedures...
Private Sub ZoomChart(ByVal Chart As ChartObject, Optional ByVal Zoom As Long)

    Dim CA As COLORADJUSTMENT
    Dim tpt1 As POINTAPI
    Dim tpt2 As POINTAPI
    Dim lBmp As Long

    
    If bEnableZooming Then _
    MsgBox "Zoomed already enabled": Exit Sub
    
    lInitScrRow = Application.ActiveWindow.ScrollRow
    lInitScrCol = Application.ActiveWindow.ScrollColumn
    bEnableZooming = True
    i = 0
    
    Set oChart = Chart
    oChart.OnAction = "DummyMacro"

    With tInitRect
        tInitRect = GetChartRect(Chart)
        .left = tInitRect.left - 4
        .top = .top - 4
        .right = .right + 2
        .bottom = .bottom + 2
    End With
    
    With tInitRect
        lDC = GetDC(0)
        lMemoryDC = CreateCompatibleDC(lDC)
        lBmp = CreateCompatibleBitmap _
        (lDC, .right - .left, .bottom - .top)
        DeleteObject SelectObject(lMemoryDC, lBmp)
        BitBlt lMemoryDC, 0, 0, .right - .left, .bottom - .top, _
        lDC, .left, .top, SRCCOPY
        tpt1.x = .left
        tpt1.y = .top
        tpt2.x = .right
        tpt2.y = .bottom
        lRgn = CreateRectRgn(tpt1.x, tpt1.y, tpt2.x, tpt2.y)
    End With
    
    
    GetColorAdjustment lDC, CA
    CA.caSize = Len(CA)
    'CA.caBrightness = -100
    CA.caColorfulness = 100
    If GetStretchBltMode(lDC) <> HALFTONE Then
        SetStretchBltMode lDC, HALFTONE
    End If
    SetColorAdjustment lDC, CA
    Call StartZooming(Zoom)

End Sub

Private Sub StartZooming(Optional ByVal Zoom As Long)

    Dim tZoomedRect As Rect
    Dim tLeftRgn As Rect
    Dim tTopRgn As Rect
    Dim tRightRgn As Rect
    Dim tBottomRgn As Rect
    Dim tCurPos As POINTAPI
    Dim h As Long
    Dim lActiveProcessID As Long
    Dim lRgn1 As Long
    Dim lRgn2 As Long
    Dim lRgn3 As Long
    Dim lRgn4 As Long
    Dim bZoomingIN As Boolean
    
    On Error Resume Next
    
    Do
        GetCursorPos tCurPos
        Call GetWindowThreadProcessId _
        (WindowFromPoint(tCurPos.x, tCurPos.y), lActiveProcessID)
        If lActiveProcessID <> GetCurrentProcessId Then
            bZoomingIN = False
            GoTo MaxZoomReached
        End If
        If Not ActiveSheet Is oChart.Parent Then
            bZoomingIN = False
            GoTo MaxZoomReached
        End If
        If Application.ActiveWindow.ScrollColumn <> lInitScrCol _
        Or Application.ActiveWindow.ScrollRow <> lInitScrRow Then
            bZoomingIN = False
            InvalidateRect 0, 0, 0
            lInitScrCol = ActiveWindow.ScrollColumn
            lInitScrRow = ActiveWindow.ScrollRow
            With tInitRect
                tInitRect = GetChartRect(oChart)
                .left = tInitRect.left - 4
                .top = .top - 4
                .right = .right + 2
                .bottom = .bottom + 2
                End With
                bZoomingIN = False
                GoTo MaxZoomReached
        End If
        Zoom = oChart.Parent.OLEObjects("cbZoomFactor").Object.Value - 100
        Sleep 10
        If CBool(PtInRect(tInitRect, tCurPos.x, tCurPos.y)) Then
            If i >= Zoom Then GoTo MaxZoomReached
                bZoomingIN = True
                With tInitRect
                StretchBlt _
                lDC, .left - i, _
                .top - i, _
                (.right - .left) + (i * 2), (.bottom - .top) + (i * 2), _
                lMemoryDC, 0, 0, (.right - .left), _
                (.bottom - .top), SRCCOPY
                SetRect tZoomedRect, .left - Zoom, .top - Zoom, _
                .right + Zoom, .bottom + Zoom
                End With
            ElseIf Not CBool(PtInRect(tZoomedRect, tCurPos.x, tCurPos.y)) Then
                i = 0
                If bZoomingIN Then
                bZoomingIN = False
                Do
                    StretchBlt _
                    lDC, tZoomedRect.left + h, _
                    tZoomedRect.top + h, _
                    (tZoomedRect.right - tZoomedRect.left) - ((h) * 2), _
                    (tZoomedRect.bottom - tZoomedRect.top) - ((h) * 2), _
                    lMemoryDC, 0, 0, (tInitRect.right - tInitRect.left), _
                    (tInitRect.bottom - tInitRect.top), SRCCOPY
                    With tLeftRgn
                        .left = tZoomedRect.left + h
                        .top = tZoomedRect.top + h + 2
                        .right = tZoomedRect.right - h
                        .bottom = tZoomedRect.top + h - 2
                        lRgn1 = CreateRectRgn _
                        (.left, .top, .right, .bottom)
                    End With
                    With tTopRgn
                        .left = tZoomedRect.left + h
                        .top = tZoomedRect.bottom - h - 2
                        .right = tZoomedRect.right - h
                        .bottom = tZoomedRect.bottom - h + 2
                        lRgn2 = CreateRectRgn _
                        (.left, .top, .right, .bottom)
                    End With
                    With tRightRgn
                        .left = tZoomedRect.left + h - 2
                        .top = tZoomedRect.top + h
                        .right = tZoomedRect.left + h + 2
                        .bottom = tZoomedRect.bottom - h
                        lRgn3 = CreateRectRgn _
                        (.left, .top, .right, .bottom)
                    End With
                    With tBottomRgn
                        .left = tZoomedRect.right - h - 2
                        .top = tZoomedRect.top + h
                        .right = tZoomedRect.right - h + 2
                        .bottom = tZoomedRect.bottom - h
                        lRgn4 = CreateRectRgn _
                        (.left, .top, .right, .bottom)
                    End With
                    RedrawWindow 0, 0, lRgn1, RDW_INVALIDATE + RDW_ALLCHILDREN
                    RedrawWindow 0, 0, lRgn2, RDW_INVALIDATE + RDW_ALLCHILDREN
                    RedrawWindow 0, 0, lRgn3, RDW_INVALIDATE + RDW_ALLCHILDREN
                    RedrawWindow 0, 0, lRgn4, RDW_INVALIDATE + RDW_ALLCHILDREN
                    DoEvents
                    h = h + 1
                    If bEnableZooming = False Then bZoomingIN = True: Exit Sub
                Loop Until h > Zoom
                RedrawWindow 0, 0, lRgn, RDW_INVALIDATE + RDW_ALLCHILDREN
                Call StartZooming(Zoom)
            End If
        End If
        i = i + 1
        ReleaseDC lDC, 0
MaxZoomReached:
        DoEvents
    Loop Until bEnableZooming = False
    ReleaseDC lDC, 0

End Sub

Private Function ScreenDPI(bVert As Boolean) As Long
 
    Static lDPI(1), lDC
 
    If lDPI(0) = 0 Then
        lDC = GetDC(0)
        lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
        lDC = ReleaseDC(0, lDC)
    End If
 
    ScreenDPI = lDPI(Abs(bVert))
 
End Function

Private Function PTtoPX _
(Points As Single, bVert As Boolean) As Long
 
    PTtoPX = Points * ScreenDPI(bVert) / PointsPerInch
 
End Function

Private Function GetChartRect(ByVal Chart As ChartObject) As Rect
    
    Dim tpt1 As POINTAPI
    Dim tpt2 As POINTAPI
    Dim OWnd  As Window
 
    On Error Resume Next
    
    Set OWnd = Chart.Parent.Parent.Windows(1)
 
    With Chart
        GetChartRect.left = _
        PTtoPX((.left) * OWnd.Zoom / 100, 0) _
        + OWnd.PointsToScreenPixelsX(0)
        GetChartRect.top = _
        PTtoPX((.top) * OWnd.Zoom / 100, 1) _
        + OWnd.PointsToScreenPixelsY(0)
        GetChartRect.right = _
        PTtoPX((.Width) * OWnd.Zoom / 100, 0) _
        + GetChartRect.left
        GetChartRect.bottom = _
        PTtoPX((.Height) * OWnd.Zoom / 100, 1) _
        + GetChartRect.top
    End With

End Function

Private Sub DummyMacro()

End Sub
 
Upvote 0
Jaafar

I luv the routine - I can definitely use this. Cool - thanks a bunch.

Having said that - My original request was how to Zoom in on a specific area of the chart - But I guess that was not clear - so say in you example where the Y value is >100 and <300 and the X axis is >5 and < 10 - so only that region of area of the chart is shown. In other words I want an chart where the Axes are changed and only the corresponding values are displayed.

PS Your comment about religion is so true.
 
Upvote 0
Jaafar

I luv the routine - I can definitely use this. Cool - thanks a bunch.

Having said that - My original request was how to Zoom in on a specific area of the chart - But I guess that was not clear - so say in you example where the Y value is >100 and <300 and the X axis is >5 and < 10 - so only that region of area of the chart is shown. In other words I want an chart where the Axes are changed and only the corresponding values are displayed.

PS Your comment about religion is so true.

Rasm.

My bad. Your original request was in fact clear. I just didn't read it properly. I see what you mean.I like the idea to be able to zoom parts of the chart using the mouse.I'll take another look and if anything comes up i'll post back.
 
Upvote 0
If you're not married to the draw a box type of zoom, perhaps a a user form with slider controls would suit your needs.

Blow is very simple code (for illustration purposes) for a userform with two scroll bar slider controls to zoom and scroll the X axis. The user form also has two command buttons, and two labels irrelevant to the code. Again, it's proof-of-concept type code rather than a bullet-proof-ready-for-public-use application.

User Form name:
FormZoomChart

Scroll bar 1: Sets the "zoom" of scaling on the X axis
scrZoomX

Scroll bar 2: Sets the left-right display range of the x-axis once the zoom is increased greater than 100%
scrRangeX

Command Button 1: Resets the two scroll bars and the chart
cmbResetChart

Command Button 2: Closes the user form and resets the Chart on close.
cmbClose

Code:
Public MajUnit As Variant, MajTickCount As Long
Public MaxScale As Variant, MinScale As Variant
Public ScaleRange As Variant

Private Sub UserForm_Initialize()

    With ActiveChart.Axes(xlCategory)

        ' Original settings
        MaxScale = .MaximumScale
        MinScale = .MinimumScale
        ScaleRange = .MaximumScale - .MinimumScale
        MajUnit = .MajorUnit
        MajTickCount = ScaleRange / MajUnit

        ' Zoom X scroll bar
        scrZoomX.Max = MajTickCount
        scrZoomX.Min = 1
        scrZoomX.SmallChange = 1
        scrZoomX.LargeChange = 1
        scrZoomX.Value = 1

        ' Range X scroll bar
        scrRangeX.Max = MajTickCount
        scrRangeX.Min = MajTickCount
        scrRangeX.SmallChange = 1
        scrRangeX.LargeChange = 1
        scrRangeX.Value = MajTickCount

    End With

End Sub

Private Sub scrRangeX_Change()

    With ActiveChart.Axes(xlCategory)
        .MinimumScale = MinScale + (MajUnit * (MajTickCount - scrRangeX.Value))
        .MaximumScale = .MinimumScale + (MajUnit * (MajTickCount - scrZoomX.Value + 1))
    End With

End Sub

Private Sub scrZoomX_Change()

    With ActiveChart.Axes(xlCategory)

        .MaximumScaleIsAuto = False
        .MaximumScale = .MinimumScale + (MajUnit * (MajTickCount - scrZoomX.Value + 1))
        scrRangeX.Max = MajTickCount - scrZoomX.Value + 1
        
    End With

End Sub

Private Sub cmbClose_Click()

    cmbResetChart_Click
    Unload FormZoomChart
    
End Sub

Private Sub cmbResetChart_Click()
    With ActiveChart.Axes(xlCategory)
        .MaximumScale = MaxScale
        .MinimumScale = MinScale
        .MajorUnit = MajUnit
    End With
    
    scrZoomX.Value = 1
    scrRangeX.Value = MajTickCount
    
End Sub

There is no error trapping in the code. It assumes you have an XY Scatter chart selected when you initialize the user form. It's expecting a chart with values on the x axis and not a categorical x-axis.

I'm sure you could add many other features like two additional scroll bars for the Y axis, the ability to scroll a category-type x-axis instead of a values-type x-axis, etc.
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,215
Members
448,554
Latest member
Gleisner2

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