none
Add and resize a shape (rectangle) over an embedded chart by Chart_MouseMove event RRS feed

  • Question

  • Hi All,

    I'm trying to draw a rectangle over a chart by the Chart_MouseMove event. The goal of this task is to select a specific chart area and then resize Axis scales accordingly.

    Unfortunately, I've two blocking problems!!!

    1. The below mentioned code currently works for zooming factor = 100% only
    2. When I click down the left mouse button and then move it on the Chart, the Chart Area object starts to move and no shape is drawn according the code written for the MouseMove event

    EDIT: I changed keyboard combination (from Shift+Left button to Control+Shift+Left button) and  the Chart Area object stops to move, the dynamic shape (rectangle) now is displayed flawlessly but at the end, after mouse-down and mouse-move events have answered as espected and after Left button release, the mouse-up event is not fired accordingly

    Does anybody know how to address these 2 issues?

    Any suggestion will be really appreciated

    Below the code I'm using:

    Private Const LOGPIXELSX = 88               'Pixels/inch in X'
    Private Const LOGPIXELSY = 90               'Pixels/inch in Y'
    Private Const POINTS_PER_INCH As Long = 72  'A point is defined as 1/72 inches'
    
    Private Const CHART_AREA_OFFSETX = 4
    Private Const CHART_AREA_OFFSETY = 4
    
    Private Type POINTAPI
         X As Double
         Y As Double
    End Type
    
    Private CoPT As POINTAPI, CdPT As POINTAPI, CoPT_A As POINTAPI, CoPT_B As POINTAPI
    
    Private Sub m_oChart_MouseDown(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)
        Dim Ch As Chart
        Dim wZoom As Double
    
        On Error GoTo Err_handler
    
        Select Case Button
            Case xlPrimaryButton
                If Shift = 3 Then       ' Primary button is pressed, Control+Shift keyboard keys are pressed too'
                    Set Ch = m_oChart
                    wZoom = ActiveWindow.zoom / 100
    
                    With Ch
                        CoPT_A.X = X * PointsPerPixelX / wZoom - CHART_AREA_OFFSETX
                        CoPT_A.Y = Y * PointsPerPixelY / wZoom - CHART_AREA_OFFSETY
                    End With
                End If
        End Select
    
    Exit_label:
        Exit Sub
    
    Err_handler:
        Select Case err.Number
            Case Is <> 0
                Resume Exit_label
            Case Else
                GoTo Exit_label
        End Select
    End Sub
    
    Private Sub m_oChart_MouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)
    'X, Y are the mouse pointer coordinates from the MouseMove event (measured in pixels).
    These coordinates are affected by the worksheet wZoom factor'
        Dim Ch As Chart
        Dim wZoom As Double
        
        On Error GoTo Err_handler
        
        Set Ch = m_oChart
        
        Select Case Button
            Case xlPrimaryButton
                If Shift = 3 Then       ' Primary button is pressed, Control+Shift keyboard keys are pressed too'
                    wZoom = ActiveWindow.zoom / 100
                    
                    With Ch
                        CoPT.X = X * PointsPerPixelX / wZoom - CHART_AREA_OFFSETX
                        CoPT.Y = Y * PointsPerPixelY / wZoom - CHART_AREA_OFFSETY
                    End With
                    
                    Call DisplayZoomAreaXY(Ch, CoPT_A, CoPT)
                End If
        End Select
        
    Exit_label:
        Exit Sub
    
    Err_handler:
        Select Case err.Number
            Case Is <> 0
                Resume Exit_label
            Case Else
                GoTo Exit_label
        End Select
    End Sub
    
    Private Sub m_oChart_MouseUp(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)
        Dim Ch As Chart
        Dim Sh As Shape
        
        Dim wZoom As Double
    
        On Error GoTo Err_handler
        
        Select Case Button
            Case xlPrimaryButton
                If Shift = 3 Then       ' Primary button is pressed, Control+Shift keyboard keys are pressed too'
                    Set Ch = m_oChart
                    wZoom = ActiveWindow.zoom / 100
                    
                    With Ch
                        CoPT_B.X = X * PointsPerPixelX / wZoom - CHART_AREA_OFFSETX
                        CoPT_B.Y = Y * PointsPerPixelY / wZoom - CHART_AREA_OFFSETY
                    End With
                    
                    On Error Resume Next
                        Set Sh = Ch.Shapes("ZoomAreaXY"): If Not Sh Is Nothing Then Sh.Delete
                    On Error GoTo 0
    
                    '... code for Axis reScaling ...'
    
                End If
        End Select
    
    Exit_label:
        Exit Sub
    
    Err_handler:
        Select Case err.Number
            Case Is <> 0
                Resume Exit_label
            Case Else
                GoTo Exit_label
        End Select
    End Sub
    
    Private Sub DisplayZoomAreaXY(Ch As Chart, CoPT_A As POINTAPI, CoPT_B As POINTAPI)
        Dim CoPT_UL As POINTAPI, CoPT_BR As POINTAPI
        
        Dim Sh As Shape
        
        If CoPT_A.X < CoPT_B.X Then
            CoPT_UL.X = CoPT_A.X
            CoPT_BR.X = CoPT_B.X
        Else
            CoPT_UL.X = CoPT_B.X
            CoPT_BR.X = CoPT_A.X
        End If
        
        If CoPT_A.Y < CoPT_B.Y Then
            CoPT_UL.Y = CoPT_A.Y
            CoPT_BR.Y = CoPT_B.Y
        Else
            CoPT_UL.Y = CoPT_B.Y
            CoPT_BR.Y = CoPT_A.Y
        End If
        
    On Error Resume Next
        Set Sh = Ch.Shapes("ZoomAreaXY")
    On Error GoTo 0
            If Sh Is Nothing Then
                Set Sh = Ch.Shapes.AddShape(msoShapeRectangle, Left:=0, Top:=0, Width:=0, Height:=0)
                    With Sh
                        .Name = "ZoomAreaXY"
    
                        .Left = CoPT_UL.X
                        .Top = CoPT_UL.Y
                        .Height = CoPT_BR.Y - CoPT_UL.Y
                        .Width = CoPT_BR.X - CoPT_UL.X
                        
                        .Fill.Visible = msoFalse
                    End With
                    
                    With Sh.Line
                        .Weight = 0.5
                        .ForeColor.RGB = RGB(91, 155, 213) ' light blue'
                        .DashStyle = msoLineDash
                        .Transparency = 0
    
                        .Visible = msoTrue
                    End With
                Sh.Visible = msoTrue
            Else
                With Sh
                    .Left = CoPT_UL.X
                    .Top = CoPT_UL.Y
                    .Height = CoPT_BR.Y - CoPT_UL.Y
                    .Width = CoPT_BR.X - CoPT_UL.X
                End With
            End If
        Set Sh = Nothing
    End Sub
    
    Private Function PointsPerPixelX() as Double
    'the size of a pixel, in points'
        Dim hDC As Long
        Dim lDotsPerInch As Long
        
        hDC = GetDC(0)
        lDotsPerInch = GetDeviceCaps(hDC, LOGPIXELSX)
            PointsPerPixelX = POINTS_PER_INCH / lDotsPerInch
        ReleaseDC 0, hDC
    End Function
    
    Private Function PointsPerPixelY() as Double
    'the size of a pixel, in points'
        Dim hDC As Long
        Dim lDotsPerInch As Long
        
        hDC = GetDC(0)
        lDotsPerInch = GetDeviceCaps(hDC, LOGPIXELSY)
            PointsPerPixelY = POINTS_PER_INCH / lDotsPerInch
        ReleaseDC 0, hDC
    End Function

                                     
    • Edited by Jumpy73 Tuesday, September 24, 2019 6:42 AM added details for a better understanding
    Monday, September 23, 2019 9:55 AM