How to zoom on charts using VBA

[Rasm]

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

 

[RoryA]

Hi Jaafar,
Just been looking through the code and I think the issue is here:

ActiveWindow.PointsToScreenPixelsY(0)

In 2003 and prior, the chart has its own window when you activate it (EXCELE class - quite useful for positioning userforms, incidentally) but in 2007+ that window no longer exists. It is that chart window that you are getting the 0 point from in 2003, rather than the worksheet window.

 

[Jaafar Tribak]

Sorry for getting back on this so late. I have been very busy.

Download the ChartZoomer Workbook demo. (Excel 2007 Only)

Essentially,the main code relies on a system mouse hook to overcome the problems related to the chart built-in mouse events which not only don't work as expected but also the chart has to be first selected to catch the events.The present approach although more code-involved offers pretty smooth results.

The code also offers the possibility to go back to the previous charts .

I am not very familiar with the Chart object model so hopefully this could be further improved like making it work for charts with more than 1 serie , uncontinious source data ranges etc... by someone more knowledgeable working with charts

Word of caution: Anyone editing/adapting the code, please save your work first !


Below is the whole code for futur reference should the above workbook demo link expire.


Main code in a standard module :

Option Explicit

'Public Vars:
'============
Public oChartObj As ChartObject
Public Col_PrevVals As New Collection
Public lSerieNumber As Long


'Private declarations:
'====================

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 MSLLHOOKSTRUCT
    pt As POINTAPI
    mouseData As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type

Type tSeriePoints
    x As Long
    Y As Long
End Type

Private Declare Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" _
(ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
 
Private Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, _
ByVal nCode As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
 
Private Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook 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 GetDeviceCaps Lib "gdi32" _
(ByVal hdc As Long, ByVal nIndex As Long) As Long

Private Declare Function GetActiveWindow Lib "user32" () As Long

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

Private Const HC_ACTION As Long = 0
Private Const WH_MOUSE_LL As Long = 14
Private Const WM_LBUTTONDOWN As Long = &H201
Private Const WM_LBUTTONUP As Long = &H202
Private Const WM_MOUSEMOVE As Long = &H200
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const POINTSPERINCH As Long = 72

Private XVals() As Range
Private Vals() As Range
Private tSeriePoints() As POINTAPI
Private tZoomRect As Rect
Private tChartRect As Rect
Private tInitPt As POINTAPI
Private oZoomRect As Shape
Private bFirstMouseDown As Boolean
Private bXValueFound As Boolean
Private blnHookEnabled As Boolean
Private hhkLowLevelMouse As Long


'Public routines :
'==================


Public Sub EnableZooming(ChartObj As ChartObject, SerieNumber As Long)

If blnHookEnabled = False Then
    lSerieNumber = SerieNumber
    Set oChartObj = ChartObj
    bXValueFound = False
    ChartObj.OnAction = "Dummy"
    ChartObj.TopLeftCell.Select
    bFirstMouseDown = False
    tChartRect = GetObjRect(ChartObj)
    Application.Cursor = xlNorthwestArrow
    hhkLowLevelMouse = SetWindowsHookEx _
    (WH_MOUSE_LL, AddressOf LowLevelMouseProc, Application.hInstance, 0)
    blnHookEnabled = True
End If



End Sub

Public Sub DisableZooming(ChartObj As ChartObject)
          
    If hhkLowLevelMouse <> 0 Then
        UnhookWindowsHookEx hhkLowLevelMouse
        blnHookEnabled = False
        ChartObj.OnAction = ""
        Application.Cursor = xlDefault
        Set Col_PrevVals = Nothing
        On Error Resume Next
        If Not oZoomRect Is Nothing Then oZoomRect.Delete
        Set oZoomRect = Nothing
    End If

End Sub


'Private routines :
'==================

Private Function LowLevelMouseProc _
(ByVal nCode As Long, ByVal wParam As Long, _
ByRef lParam As MSLLHOOKSTRUCT) As Long

    Dim oNewXVals As Range
    Dim oNewVals As Range
    Dim oPrevXRange As Range
    Dim oPrevRange As Range
    Dim oMySeries As New ChartSeries
    Dim oPrevChart As New PrevCharts
    Dim i As Long

     
    On Error Resume Next
    
    If (nCode = HC_ACTION) Then
    
    'process mouse actions only if the mouse is over the chart.
    If CBool(PtInRect(tChartRect, lParam.pt.x, lParam.pt.Y)) And _
    GetActiveWindow = Application.hwnd Then
   
        If wParam = WM_LBUTTONDOWN Then
            
            'set this flag to inidicate the
            'user's first mouse down.
            bFirstMouseDown = True
            
            'create a rectangle to delimit the boundaries
            'of the area to be zoomed.
            Set oZoomRect = ActiveSheet.Shapes.AddShape _
            (msoShapeRectangle, 0, 0, 0.1, 0.1)
            
            With oZoomRect
                .Fill.Transparency = 1#
                .Line.DashStyle = msoLineDash
                .Line.style = msoLineSingle
                .Line.ForeColor.SchemeColor = 10
                .Line.Weight = 1
                .Placement = xlFreeFloating
                .Visible = True
                .OnAction = "Dummy"
                oZoomRect.ZOrder 0 'stay on top of the chart.
            End With
            
            'store the initial mouse and zoom rectangle coordinates
            tZoomRect = GetObjRect(oZoomRect)
            tInitPt.x = lParam.pt.x
            tInitPt.Y = lParam.pt.Y
            oZoomRect.Visible = msoCTrue
            
        End If 'end of mousedownd.
        
        If wParam = WM_LBUTTONUP Then
        
            'reset vars.
            bXValueFound = False
            bFirstMouseDown = False
            Erase tSeriePoints()
            Erase XVals()
            Erase Vals()
            
            'retrive the current chart XVals/Vals
            Call GetXYVals
            'retrive the series points location in pixels
            Call GetDPs
            'store the final zoom rect dimensions.
            tZoomRect = GetObjRect(oZoomRect)
            
            'loop thru each point in the target serie
            'if the point is within the boudaries of the
            'zoom rectangle then build the new XVals and Vals
            'for the new zoomed chart.
            For i = 1 To UBound(XVals)
                If CBool _
                (PtInRect(tZoomRect, tSeriePoints(i).x, tSeriePoints(i).Y)) Then
                    If Not XVals(i) Is Nothing And bXValueFound = False Then
                        bXValueFound = True
                        Set oPrevXRange = XVals(i): Set oPrevRange = Vals(i)
                    End If
                    Set oNewXVals = Union(oPrevXRange, XVals(i))
                    Set oNewVals = Union(oPrevRange, Vals(i))
                    Set oPrevXRange = oNewXVals
                    Set oPrevRange = oNewVals
                End If
            Next
            'now store the previous chart XVals and Vals
            'and change the current chart XVals and Vals.
            With oMySeries
                .Chart = oChartObj.Chart
                .ChartSeries = lSerieNumber
                If Not oNewXVals Is Nothing Then
                    oPrevChart.XVals = .XValues.Address
                    oPrevChart.Vals = .Values.Address
                    Col_PrevVals.Add oPrevChart
                    Set oPrevChart = Nothing
                End If
                .XValues = oNewXVals
                .Values = oNewVals
                Set oMySeries = Nothing
            End With
'            End If
            oChartObj.OnAction = "Dummy"
            oZoomRect.Delete
            oChartObj.TopLeftCell.Activate
            
        End If 'end of mouseup.

    'update the zoom rectangle as the user drags the mouse.
        If wParam = WM_MOUSEMOVE And bFirstMouseDown Then
            Select Case True
                Case tInitPt.Y <= lParam.pt.Y And tInitPt.x <= lParam.pt.x
                    With oZoomRect
                        .Left = PixToPnt(tInitPt.x, True)
                        .Top = PixToPnt(tInitPt.Y, False)
                        .Width = PixToPnt _
                        (lParam.pt.x - tInitPt.x + (tZoomRect.Right), True)
                        .Height = PixToPnt _
                        (lParam.pt.Y - tInitPt.Y + (tZoomRect.Bottom), False)
                    End With
                Case tInitPt.Y > lParam.pt.Y And tInitPt.x <= lParam.pt.x
                    With oZoomRect
                        .Left = PixToPnt(tInitPt.x, True)
                        .Top = PixToPnt(lParam.pt.Y, False)
                        .Width = PixToPnt _
                        (lParam.pt.x - tInitPt.x + (tZoomRect.Right), True)
                        .Height = PixToPnt _
                        (tInitPt.Y - lParam.pt.Y + (tZoomRect.Bottom), False)
                    End With
                Case tInitPt.x >= lParam.pt.x And tInitPt.Y < lParam.pt.Y
                    With oZoomRect
                        .Left = PixToPnt(lParam.pt.x, True)
                        .Top = PixToPnt(tInitPt.Y, False)
                        .Width = PixToPnt _
                        (tInitPt.x - lParam.pt.x + (tZoomRect.Right), True)
                        .Height = PixToPnt _
                        (lParam.pt.Y - tInitPt.Y + (tZoomRect.Bottom), False)
                End With
                    Case tInitPt.x >= lParam.pt.x And tInitPt.Y > lParam.pt.Y
                        With oZoomRect
                            .Left = PixToPnt(lParam.pt.x, True)
                            .Top = PixToPnt(lParam.pt.Y, False)
                            .Width = PixToPnt _
                            (tInitPt.x - lParam.pt.x + (tZoomRect.Right), True)
                            .Height = PixToPnt _
                            (tInitPt.Y - lParam.pt.Y + (tZoomRect.Bottom), False)
                    End With
            End Select
        End If 'end mousemove.
    
    End If

    End If

    'Call next hook if any
    LowLevelMouseProc = CallNextHookEx(0, nCode, wParam, ByVal lParam)
    
End Function

'dummy macro to make the chart un-selectable
'during the mouse dragging.
Private Sub Dummy()
End Sub

'get the series points coordinates
'location in screen pixels.
 Private Sub GetDPs()
 
    Dim PALeft As Double
    Dim PATOP As Double
    Dim PixLeft As Long
    Dim PixTop As Long
    Dim oCht As ChartObject
    Dim oSrs As Series
    Dim i As Long

 
    oChartObj.Activate
    Set oCht = oChartObj
    Set oSrs = oCht.Chart.SeriesCollection(lSerieNumber)
    
    For i = 1 To oSrs.Points.Count
        PALeft = oChartObj.Left + _
        ExecuteExcel4Macro("GET.CHART.ITEM(1,1,""S1P" & i & """)")
        PATOP = oChartObj.Top + oChartObj.Height _
        - ExecuteExcel4Macro("get.chart.item(2,1,""S1P" & i & """)")
        
        PixLeft = PTtoPX(PALeft, False) * (ActiveWindow.Zoom / 100) + _
        ActiveWindow.PointsToScreenPixelsX(0)
        PixTop = PTtoPX(PATOP, True) * (ActiveWindow.Zoom / 100) + _
        ActiveWindow.PointsToScreenPixelsY(0)
        
        ReDim Preserve tSeriePoints(1 To i) As POINTAPI
        tSeriePoints(i).x = PixLeft
        tSeriePoints(i).Y = PixTop
    Next i
    
End Sub

'get the XVals and Vals of the target serie.
'adopted from John Walkenbach.
Private Sub GetXYVals()
   
    Dim oMySeries As New ChartSeries
    Dim numrows As Long
    Dim i As Long
    
    With oMySeries
        .Chart = oChartObj.Chart
        .ChartSeries = lSerieNumber
        If .XValuesType = "Range" Then
            numrows = .XValues.Rows.Count
            ReDim XVals(numrows)
            For i = 1 To numrows
                Set XVals(i) = .XValues(i)
            Next
        End If
        If .ValuesType = "Range" Then
            numrows = .Values.Rows.Count
            ReDim Vals(numrows)
            For i = 1 To numrows
                Set Vals(i) = .Values(i)
            Next
        End If
    End With
    
    Set oMySeries = Nothing
End Sub

'get the screen boundaries in pixels
'of any object on the worksheet.
Private Function GetObjRect(ByVal Obj As Object) As Rect
    
    Dim OWnd  As Window
 
    On Error Resume Next
    
    Set OWnd = Obj.Parent.Parent.Windows(1)
 
    With Obj
        GetObjRect.Left = _
        PTtoPX((.Left) * OWnd.Zoom / 100, 0) _
        + OWnd.PointsToScreenPixelsX(0)
        GetObjRect.Top = _
        PTtoPX((.Top) * OWnd.Zoom / 100, 1) _
        + OWnd.PointsToScreenPixelsY(0)
        GetObjRect.Right = _
        PTtoPX((.Width) * OWnd.Zoom / 100, 0) _
        + GetObjRect.Left
        GetObjRect.Bottom = _
        PTtoPX((.Height) * OWnd.Zoom / 100, 1) _
        + GetObjRect.Top
    End With

End Function

'convert screen pixels to points so the
'zoom rectangle size follows the mouse pointer.
Private Function PixToPnt _
(Pixels As Long, Horz As Boolean) As Double

    Dim hdc As Long
    Dim PixPerInch As Long
    Dim PixPerPtX As Long
    Dim PixPerPtY As Long
    
    hdc = GetDC(0)
    
    If Horz Then
        PixPerInch = GetDeviceCaps(hdc, LOGPIXELSX)
        PixToPnt = (Pixels - ActiveWindow.PointsToScreenPixelsX(0)) _
        / PixPerInch * 72
    Else
        PixPerInch = GetDeviceCaps(hdc, LOGPIXELSY)
        PixToPnt = (Pixels - ActiveWindow.PointsToScreenPixelsY(0)) _
        / PixPerInch * 72
    End If
    
    ReleaseDC 0, hdc

End Function

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 Double, bVert As Boolean) As Long
 
    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
 
End Function

ChartSeries Class borrowed from Mr John Walkenbach :

'This Class module provides an easy way to access the items in a
'chart's SERIES formula. It can be exported and then imported into
'any project

'Developed by John Walkenbach, JWALK AND ASSOCIATES
'Copyright 1999. All rights reserved.
'May be used and distributed freely, but may not be sold.
'http://www.j-walk.com/ss/


Option Explicit
Dim CurrChart As Chart    'accessible to all procedures
Dim CurrSeries As Integer 'accessible to all procedures

Property Get Chart() As Chart
    Set Chart = CurrChart
End Property

Property Let Chart(cht)
    Set CurrChart = cht
End Property


Property Get ChartSeries()
    ChartSeries = CurrSeries
End Property

Property Let ChartSeries(SeriesNum)
    CurrSeries = SeriesNum
End Property


Property Get SeriesName() As Variant
    If SeriesNameType = "Range" Then
        Set SeriesName = Range(SERIESFormulaElement(CurrChart, CurrSeries, 1))
    Else
        SeriesName = SERIESFormulaElement(CurrChart, CurrSeries, 1)
    End If
End Property

Property Let SeriesName(SName)
    CurrChart.SeriesCollection(CurrSeries).Name = SName
End Property

Property Get SeriesNameType() As String
    SeriesNameType = SERIESFormulaElementType(CurrChart, CurrSeries, 1)
End Property


Property Get XValues() As Variant
    If XValuesType = "Range" Then
       Set XValues = Range(SERIESFormulaElement(CurrChart, CurrSeries, 2))
    Else
        XValues = SERIESFormulaElement(CurrChart, CurrSeries, 2)
    End If
End Property

Property Let XValues(XVals)
    CurrChart.SeriesCollection(CurrSeries).XValues = XVals
   
End Property

Property Get XValuesType() As String
    XValuesType = SERIESFormulaElementType(CurrChart, CurrSeries, 2)
End Property


Property Get Values() As Variant
    If ValuesType = "Range" Then

       Set Values = Range(SERIESFormulaElement(CurrChart, CurrSeries, 3))
    Else
        Values = SERIESFormulaElement(CurrChart, CurrSeries, 3)
    End If
End Property

Property Let Values(Vals)
     CurrChart.SeriesCollection(CurrSeries).Values = Vals
     
End Property

Property Get ValuesType() As String
    ValuesType = SERIESFormulaElementType(CurrChart, CurrSeries, 3)
End Property



Property Get PlotOrder()
        PlotOrder = SERIESFormulaElement(CurrChart, CurrSeries, 4)
End Property

Property Let PlotOrder(PltOrder)
    CurrChart.SeriesCollection(CurrSeries).PlotOrder = PltOrder
End Property

Property Get PlotOrderType() As String
    PlotOrderType = SERIESFormulaElementType(CurrChart, CurrSeries, 4)
End Property


Private Function SERIESFormulaElementType(ChartObj, SeriesNum, Element) As String
'   Returns a string that describes the element of a chart's SERIES formula
'   This function essentially parses and analyzes a SERIES formula

'   Element 1: Series Name. Returns "Range" , "Empty", or "String"
'   Element 2: XValues. Returns "Range", "Empty", or "Array"
'   Element 3: Values. Returns "Range" or "Array"
'   Element 4: PlotOrder. Always returns "Integer"

    Dim SeriesFormula As String
    Dim FirstComma As Integer, SecondComma As Integer, LastComma As Integer
    Dim FirstParen As Integer, SecondParen As Integer
    Dim FirstBracket As Integer, SecondBracket As Integer
    Dim StartY As Integer
    Dim SeriesName, XValues, Values, PlotOrder As Integer
    
'   Exit if Surface chart (surface chrarts do not have SERIES formulas)
    If ChartObj.ChartType >= 83 And ChartObj.ChartType <= 86 Then
        SERIESFormulaElementType = "ERROR - SURFACE CHART"
        Exit Function
    End If
    
'   Exit if nonexistent series is specified
    If SeriesNum > ChartObj.SeriesCollection.Count Or SeriesNum < 1 Then
        SERIESFormulaElementType = "ERROR - BAD SERIES NUMBER"
        Exit Function
    End If

'   Exit if element is > 4
    If Element > 4 Or Element < 1 Then
        SERIESFormulaElementType = "ERROR - BAD ELEMENT NUMBER"
        Exit Function
    End If

'   Get the SERIES formula
    SeriesFormula = ChartObj.SeriesCollection(SeriesNum).Formula

'   Get the First Element (Series Name)
    FirstParen = InStr(1, SeriesFormula, "(")
    FirstComma = InStr(1, SeriesFormula, ",")
    SeriesName = Mid(SeriesFormula, FirstParen + 1, FirstComma - FirstParen - 1)
    If Element = 1 Then
        If IsRange(SeriesName) Then
            SERIESFormulaElementType = "Range"
        Else
            If SeriesName = "" Then
                SERIESFormulaElementType = "Empty"
            Else
                If TypeName(SeriesName) = "String" Then
                    SERIESFormulaElementType = "String"
                End If
            End If
        End If
        Exit Function
    End If

'   Get the Second Element (X Range)
    If Mid(SeriesFormula, FirstComma + 1, 1) = "(" Then
'       Multiple ranges
        FirstParen = FirstComma + 2
        SecondParen = InStr(FirstParen, SeriesFormula, ")")
        XValues = Mid(SeriesFormula, FirstParen, SecondParen - FirstParen)
        StartY = SecondParen + 1
    Else
        If Mid(SeriesFormula, FirstComma + 1, 1) = "{" Then
'           Literal Array
            FirstBracket = FirstComma + 1
            SecondBracket = InStr(FirstBracket, SeriesFormula, "}")
            XValues = Mid(SeriesFormula, FirstBracket, SecondBracket - FirstBracket + 1)
            StartY = SecondBracket + 1
        Else
'          A single range
            SecondComma = InStr(FirstComma + 1, SeriesFormula, ",")
            XValues = Mid(SeriesFormula, FirstComma + 1, SecondComma - FirstComma - 1)
            StartY = SecondComma
        End If
    End If
    If Element = 2 Then
        If IsRange(XValues) Then
            SERIESFormulaElementType = "Range"
        Else
            If XValues = "" Then
                SERIESFormulaElementType = "Empty"
            Else
                SERIESFormulaElementType = "Array"
            End If
        End If
        Exit Function
    End If

'   Get the Third Element (Y Range)
    If Mid(SeriesFormula, StartY + 1, 1) = "(" Then
'       Multiple ranges
        FirstParen = StartY + 1
        SecondParen = InStr(FirstParen, SeriesFormula, ")")
        Values = Mid(SeriesFormula, FirstParen + 1, SecondParen - FirstParen - 1)
        LastComma = SecondParen + 1
    Else
        If Mid(SeriesFormula, StartY + 1, 1) = "{" Then
'           Literal Array
            FirstBracket = StartY + 1
            SecondBracket = InStr(FirstBracket, SeriesFormula, "}")
            Values = Mid(SeriesFormula, FirstBracket, SecondBracket - FirstBracket + 1)
            LastComma = SecondBracket + 1
        Else
'          A single range
            FirstComma = StartY
            SecondComma = InStr(FirstComma + 1, SeriesFormula, ",")
            Values = Mid(SeriesFormula, FirstComma + 1, SecondComma - FirstComma - 1)
            LastComma = SecondComma
        End If
    End If
    If Element = 3 Then
        If IsRange(Values) Then
            SERIESFormulaElementType = "Range"
        Else
            SERIESFormulaElementType = "Array"
        End If
        Exit Function
    End If
    
'   Get the Fourth Element (Plot Order)
    PlotOrder = Mid(SeriesFormula, LastComma + 1, Len(SeriesFormula) - LastComma - 1)
    If Element = 4 Then
        SERIESFormulaElementType = "Integer"
        Exit Function
    End If
End Function


Private Function SERIESFormulaElement(ChartObj, SeriesNum, Element) As String
'   Returns one of four elements in a chart's SERIES formula (as a string)
'   This function essentially parses and analyzes a SERIES formula

'   Element 1: Series Name. Can be a range reference, a literal value, or nothing
'   Element 2: XValues. Can be a range reference (including a non-contiguous range), a literal array, or nothing
'   Element 3: Values. Can be a range reference (including a non-contiguous range), or a literal array
'   Element 4: PlotOrder. Must be an integer

    Dim SeriesFormula As String
    Dim FirstComma As Integer, SecondComma As Integer, LastComma As Integer
    Dim FirstParen As Integer, SecondParen As Integer
    Dim FirstBracket As Integer, SecondBracket As Integer
    Dim StartY As Integer
    Dim SeriesName, XValues, Values, PlotOrder As Integer
    
'   Exit if Surface chart (surface chrarts do not have SERIES formulas)
    If ChartObj.ChartType >= 83 And ChartObj.ChartType <= 86 Then
        SERIESFormulaElement = "ERROR - SURFACE CHART"
        Exit Function
    End If
    
'   Exit if nonexistent series is specified
    If SeriesNum > ChartObj.SeriesCollection.Count Or SeriesNum < 1 Then
        SERIESFormulaElement = "ERROR - BAD SERIES NUMBER"
        Exit Function
    End If

'   Exit if element is > 4
    If Element > 4 Then
        SERIESFormulaElement = "ERROR - BAD ELEMENT NUMBER"
        Exit Function
    End If

'   Get the SERIES formula
    SeriesFormula = ChartObj.SeriesCollection(SeriesNum).Formula

'   Get the First Element (Series Name)
    FirstParen = InStr(1, SeriesFormula, "(")
    FirstComma = InStr(1, SeriesFormula, ",")
    SeriesName = Mid(SeriesFormula, FirstParen + 1, FirstComma - FirstParen - 1)
    If Element = 1 Then
        SERIESFormulaElement = SeriesName
        Exit Function
    End If

'   Get the Second Element (X Range)
    If Mid(SeriesFormula, FirstComma + 1, 1) = "(" Then
'       Multiple ranges
        FirstParen = FirstComma + 2
        SecondParen = InStr(FirstParen, SeriesFormula, ")")
        XValues = Mid(SeriesFormula, FirstParen, SecondParen - FirstParen)
        StartY = SecondParen + 1
    Else
        If Mid(SeriesFormula, FirstComma + 1, 1) = "{" Then
'           Literal Array
            FirstBracket = FirstComma + 1
            SecondBracket = InStr(FirstBracket, SeriesFormula, "}")
            XValues = Mid(SeriesFormula, FirstBracket, SecondBracket - FirstBracket + 1)
            StartY = SecondBracket + 1
        Else
'          A single range
            SecondComma = InStr(FirstComma + 1, SeriesFormula, ",")
            XValues = Mid(SeriesFormula, FirstComma + 1, SecondComma - FirstComma - 1)
            StartY = SecondComma
        End If
    End If
    If Element = 2 Then
        SERIESFormulaElement = XValues
        Exit Function
    End If

'   Get the Third Element (Y Range)
    If Mid(SeriesFormula, StartY + 1, 1) = "(" Then
'       Multiple ranges
        FirstParen = StartY + 1
        SecondParen = InStr(FirstParen, SeriesFormula, ")")
        Values = Mid(SeriesFormula, FirstParen + 1, SecondParen - FirstParen - 1)
        LastComma = SecondParen + 1
    Else
        If Mid(SeriesFormula, StartY + 1, 1) = "{" Then
'           Literal Array
            FirstBracket = StartY + 1
            SecondBracket = InStr(FirstBracket, SeriesFormula, "}")
            Values = Mid(SeriesFormula, FirstBracket, SecondBracket - FirstBracket + 1)
            LastComma = SecondBracket + 1
        Else
'          A single range
            FirstComma = StartY
            SecondComma = InStr(FirstComma + 1, SeriesFormula, ",")
            Values = Mid(SeriesFormula, FirstComma + 1, SecondComma - FirstComma - 1)
            LastComma = SecondComma
        End If
    End If
    If Element = 3 Then
        SERIESFormulaElement = Values
        Exit Function
    End If
    
'   Get the Fourth Element (Plot Order)
    PlotOrder = Mid(SeriesFormula, LastComma + 1, Len(SeriesFormula) - LastComma - 1)
    If Element = 4 Then
        SERIESFormulaElement = PlotOrder
        Exit Function
    End If
End Function

Private Function IsRange(ref) As Boolean
'   Returns True if ref is a Range
    Dim x As Range
    On Error Resume Next
    Set x = Range(ref)
    If Err = 0 Then IsRange = True Else IsRange = False
End Function

PrevCharts Class to remember the previous charts after zooming:

Option Explicit

Private vXVal As Variant
Private vVal As Variant

Public Property Get XVals() As Variant
    XVals = vXVal
End Property

Public Property Let XVals(ByVal NewVal As Variant)
    vXVal = NewVal
End Property

Public Property Get Vals() As Variant
    Vals = vVal
End Property

Public Property Let Vals(ByVal NewVal As Variant)
    vVal = NewVal
End Property

Code in the worksheet where the chart is embeeded:

Controls on the worksheet :
*chkEnableZooming => CheckBox to enable/disable the zooming feature.
*cmbPrev => Button to go back to previous zooms.
*cmbReset => Button to go back to initial zoom.

Option Explicit

Private WithEvents ThisWb As Workbook

Private Sub chkEnableZooming_Click()

    Set ThisWb = ThisWorkbook
    
    If chkEnableZooming Then
        Call EnableZooming(Me.ChartObjects(1), 1)
    Else
        Call cmbReset_Click
        Call DisableZooming(Me.ChartObjects(1))
        
    End If

End Sub

Private Sub cmbPrev_Click()

    Dim oMySeries As New ChartSeries
    
    If Col_PrevVals.Count = 0 Then Exit Sub
    
    With oMySeries
        .Chart = oChartObj.Chart
        .ChartSeries = lSerieNumber
        .XValues = Range(Col_PrevVals(Col_PrevVals.Count).XVals)
        .Values = Range(Col_PrevVals(Col_PrevVals.Count).Vals)
        Col_PrevVals.Remove (Col_PrevVals.Count)
    End With
    
    Set oMySeries = Nothing

End Sub

Private Sub cmbReset_Click()

    Dim oMySeries As New ChartSeries
    
    If Col_PrevVals.Count = 0 Then Exit Sub
    
    With oMySeries
        .Chart = oChartObj.Chart
        .ChartSeries = lSerieNumber
        .XValues = Range(Col_PrevVals(1).XVals)
        .Values = Range(Col_PrevVals(1).Vals)
        Col_PrevVals.Remove (Col_PrevVals.Count)
    End With
    
    Set oMySeries = Nothing

End Sub

Private Sub ThisWb_BeforeClose(Cancel As Boolean)

    Call cmbReset_Click
    Me.chkEnableZooming = False
    
End Sub

 

[Rasm]

Jaafar
I will def check this out - thanks a bunch - you sure done a lot of work. I will try it - initially I will use your workbook. Then I will venture into adapting it. Thanks again.

 

[Rasm]

Jaafar

I tried your code - perfect - exactly what I was looking for - thanks a million. I will adapt it so it works for my charts - I use multiple charts on the same sheet - and sometimes on a chart tab. But hopefully I dont have to much trouble with that - if i do - I know where to go to - JK. I also noticed you have pictures in your buttons - cool - I will have to check that out as well.
Again thanks - this will really help - much appreciated you took it all the way. I am in the middle of some other code for my project - so it may be a week or so before I get right back into the chart part. But 4 sure I will give you feedback.

 

[Rasm]

Well - could not resist to get going right away. So I added some code to Jaafar's code. Simply to create different chart types. So all my added code does is create chart(s) that I can use for testing purpose. It creates the charts from arrays - so you dont need to worry about having data in the sheet itself.

However - I canot get the Chart zoomer to work on my chart (works fine on Jaafar's chart) - I have an option to just create a single chart. So for now I have only created a single chart type. It is a Histogram - but charted as

.ChartType = xlXYScatterSmoothNoMarkers

There is another option to also chart the same data as a regular Histogram (.ChartType = xlColumnClustered) as well as an YXscatter (.ChartType = xlXYScatter) chart. But for now I am just trying to get the 1st one working.


I am hoping somebody else will jump in - Jaafar done a lot of work - this routine is really cool.

So Here is the code I have added - so all of Jaafar's code is intact and unchanged.


Sheet code it self - On the sheet add two CommandButtons of the ActiveX type

Private Sub CmdClearCharts_Click()
    Call CmdClearChartsX ' This will delete ALL charts on active sheet
End Sub

Private Sub CmdMakeChart_Click()
    Call AddHistochart ' This adds up to 3 charts
End Sub

Separate module (I called it ChartMaker)

Option Explicit
Option Compare Text
Dim i As Long, ii As Long
Dim NumCharts As Long
Dim IntResponse As Integer
Public Sub CmdClearChartsX()
    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
Public Sub AddHistochart()
    Dim YPlotValues() As Variant
    Dim XPlotValues() As Single
    Dim i As Long, ii As Long
    Dim frequency() As Long
    Dim binlabel() As Single
    Dim binsize As Single
    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 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 Chart)s)"
    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:=420, Height:=240
    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
    ActiveSheet.ChartObjects(NumCharts).Activate
    Dim Achart As ChartObject
    Set Achart = ActiveSheet.ChartObjects(NumCharts)
    
    With Achart.Chart
        Select Case NumCharts
            Case 2
                .ChartType = xlColumnClustered
            Case 1
                .ChartType = xlXYScatterSmoothNoMarkers
            Case 3
                .ChartType = xlXYScatter
            Case Else
                MsgBox "Not implemented"
                End
        End Select
        .SeriesCollection.NewSeries
        .HasLegend = False
        .Axes(xlCategory).MajorTickMark = xlTickMarkOutside
        .Axes(xlValue).MajorTickMark = xlTickMarkOutside
        If .ChartType = xlXYScatter 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 .ChartType = xlXYScatterSmoothNoMarkers Or .ChartType = xlColumnClustered 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"
            With ActiveChart.Axes(xlValue).TickLabels
                .Font.Bold = True
                .NumberFormat = "0.0"
            End With
        End If
        If .ChartType = xlXYScatterSmoothNoMarkers Then
            .SeriesCollection.NewSeries
            .SeriesCollection(NumParameters + 1).Values = Array(frequency)
            .SeriesCollection(NumParameters + 1).XValues = Array(binlabel)
            .SeriesCollection(NumParameters + 1).Smooth = True
            .Axes(xlCategory).MinimumScale = Format(minimumX, "#####.####0")
            .Axes(xlCategory).MaximumScale = Format(maximumX, "#####.####0")
        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)
        .HasTitle = True
        .ChartTitle.Text = WrkBookName & "--" & ActiveShtName & "--" & ActChartName
        With .Axes(xlValue).TickLabels
            .Font.Bold = True
            .NumberFormat = "#####0.0000"
        End With
        With .Axes(xlCategory).TickLabels
            .Font.Bold = True
            .NumberFormat = "#####0.0000"
        End With
    End With
    Set Achart = Nothing
    If NumCharts < 3 Then
        IntResponse = MsgBox("Just one chart" & vbCrLf & vbCrLf & "Say No add another chart", vbYesNo)
        If IntResponse <> 6 Then GoTo StartMakingCharts
    End If
    Application.StatusBar = "Completed ---- Making Charts - 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

 

[jeffreybrown]

Hi Rasm,

I couldn't begin to help you, this is way above my skills, but just curios if you saw this thread which you might find of interest.

 

[Rasm]

Thanks Jeffrey - I just posted replay for Krish.

 

[Rasm]

Earlier today - I posted code to make charts - then stated that the Chart zoomer did not work. However I found out why - the procedure below specifically looks for a range - since my data is in arrays it does not find it - so if I write my array to a range - then it works - however can anybody suggest how to change this code so that it gets the values - It is not obvious to me why it does not read the .Xvalues(i) & .values(i)

Private Sub GetXYVals()
    Dim oMySeries As New ChartSeries
    Dim numrows As Long
    Dim i As Long
    If Err.Number <> 0 Then Stop 'Ole added
    With oMySeries
        .Chart = oChartObj.Chart
        .ChartSeries = lSerieNumber
        If .XValuesType = "Range" Then
            numrows = .XValues.Rows.Count
            ReDim XVals(numrows)
            For i = 1 To numrows
                Set XVals(i) = .XValues(i)
            Next
        End If
        If .ValuesType = "Range" Then
            numrows = .Values.Rows.Count
            ReDim Vals(numrows)
            For i = 1 To numrows
                Set Vals(i) = .Values(i)
            Next
        End If
    End With
    Set oMySeries = Nothing
End Sub

 

[Jaafar Tribak]

Rasm.

That specific bit of code was an implementation of the ChartSeries Class written by John Walkenbach. I adapted it to work for range based charts only as I felt too lazy to go through its entire Class to account for array based charts as well

Another thing that could possibly benefit the code is to place it in a small dll which could be dynamically loaded to avoid any potential crashing due to the use of a system mouse hook.

If I do get the time, I'll edit the code .

 

[Rasm]

Jaafar - what you have done is Great - I am working on getting yours and Johns code to work with my charts. For now I will create ranges and use those in place of my arrays. Also there is a new site where Krisnakumar http://www.excelfox.com/forum/forum.php has posted a nice code to Zoom the charts by simply making them bigger. So between all these codes - I am hoping to have a very powerful chart tool. I obviously need to make sure I can have multiple embedded charts on the same sheet.