Formatting Excel Charts Automatically

The final product of my most recent work has been taking a chart like this

Photobucket

of any size or values (Since they're measuring distance, it can be in meters or lat/long) and turning it into this

Photobucket

There's a fair amount of work that gets done, but here's the main routine:

With myChart
        .Axes(xlCategory).HasTitle = True
        .Axes(xlValue).HasTitle = True
        If meters Then
            .Axes(xlCategory).AxisTitle.Text = "Easting (meters)"
            .Axes(xlValue).AxisTitle.Text = "Northing (meters)"
        Else 'latitude and longitude
            .Axes(xlCategory).AxisTitle.Text = "Longitude (degrees)"
            .Axes(xlValue).AxisTitle.Text = "Latitude (degrees)"
        End If
    End With
        Call FormatPlot.makePlotSquare(myChart, meters, xMin, yMin, optQuadrant1.value)
        If Not meters Then
            Call FormatPlot.DDLabelsToDMS(myChart, xlValue)
            Call FormatPlot.DDLabelsToDMS(myChart, xlCategory)
        End If

    '---Color the plot:
    Call FormatPlot.ColorPlot(myChart, _
        gridColor:=myGridColor, plotColor:=myPlotColor)

    '---lock the chart so users can't change or move it
    myChart.ProtectSelection = True

The sub makePlotSquare is the one I discussed before. Including the portion that takes care of a latitude/longitude chart it looks like this (with most explanatory comments removed):

Public Sub makePlotSquare(ByRef chartObject As Chart, ByVal meters As Boolean, ByVal minXdata As Double, _
        ByVal minYdata As Double, Optional ByVal Q1 As Boolean = False)
    
    Const magicRatio = 0.91316 

    '---Rescaling variables
    Dim xPoints As Double
    Dim yPoints As Double
    Dim xMin As Double
    Dim xMax As Double
    Dim yMin As Double
    Dim yMax As Double
    Dim xMajor As Double
    Dim yMajor As Double
    Dim xDiff As Double
    Dim yDiff As Double
    Dim latRatio As Double
    Dim averageLong As Double
    Dim averageLat As Double
    

    With chartObject
        
    '---The following simply grabs the graph's axis stats
        
        If .Axes(xlValue).majorUnit > .Axes(xlCategory).majorUnit Then
            .Axes(xlValue).majorUnit = .Axes(xlCategory).majorUnit
        Else
            .Axes(xlCategory).majorUnit = .Axes(xlValue).majorUnit
        End If
        yMajor = .Axes(xlValue).majorUnit
        xMajor = .Axes(xlCategory).majorUnit
                
        With .Axes(xlCategory)
            '---Keep Excel from helping
            .MaximumScaleIsAuto = False
            .MinimumScaleIsAuto = False
            .MajorUnitIsAuto = False
            '---Since Long/lat tends to have a lot of funky decimals, fix it so it doesn't
            '---Mess up the size of the plot after changing the maximum
            If Not meters Then .TickLabels.NumberFormat = "###.000000"
            .TickLabels.Orientation = xlUpward
            
            'Excel seems to start labeling the tickmarks starting form the minimum scale going up, instead of starting at 0
            'this way we correct for it by finding the number after the current minimum that will evenly divide by the majorUnit
            If Not minXdata = 0 And meters Then
                .MinimumScale = Round(minXdata, 0) - (xMajor - (Abs(minXdata) Mod xMajor))
            ElseIf meters Then
                .MinimumScale = 0
            End If
            xMin = .MinimumScale
            xMax = .MaximumScale
        End With
        
        With .Axes(xlValue)
            '---Keep Excel from "helping"
            .MaximumScaleIsAuto = False
            .MinimumScaleIsAuto = False
            .MajorUnitIsAuto = False

            If Not minYdata = 0 And meters Then
                .MinimumScale = Round(minYdata, 0) - (yMajor - (Abs(minYdata) Mod yMajor))
            ElseIf meters Then
                .MinimumScale = 0
            End If
            yMin = .MinimumScale
            yMax = .MaximumScale
        End With

        xDiff = xMax - xMin
        yDiff = yMax - yMin
            
    '---This is where we actually fix the display
        If meters Then
            xPoints = .PlotArea.InsideWidth * (xMajor / xDiff)
            yPoints = .PlotArea.InsideHeight * (yMajor / yDiff)
            
            If xPoints > yPoints Then
                .Axes(xlCategory).MaximumScale = Round((yDiff * (.PlotArea.InsideWidth / .PlotArea.InsideHeight) * magicRatio) + xMin, 0)
                .Axes(xlCategory).majorUnit = .Axes(xlValue).majorUnit
            Else
                .Axes(xlValue).MaximumScale = Round((xDiff * (.PlotArea.InsideHeight / .PlotArea.InsideWidth) / magicRatio) + yMin, 0)
                .Axes(xlValue).majorUnit = .Axes(xlCategory).majorUnit
            End If
        Else 'longitude/latitudal

            '---scaleValue represents the relationship between long and lat.
            '---Longlatscalevalue is how many degrees of longitude fit into one degree of latitude at the
            '---latitue of our location.
            averageLat = (yDiff / 2 + yMin)
            averageLong = (xDiff / 2 + xMin)
            latRatio = LongLat.lengthOfLat(averageLat) / LongLat.lengthOfLong(averageLat)

            xPoints = .PlotArea.InsideWidth * (xMajor / xDiff) * latRatio
            yPoints = .PlotArea.InsideHeight * (yMajor / yDiff)

            If xPoints > yPoints Then
                '---Adjust the values that are in latitude degrees to be in logitide degrees.
                yDiff = yDiff * latRatio
                
                '---calculate our new X maximum
                xMax = (yDiff * (.PlotArea.InsideWidth / .PlotArea.InsideHeight) * (xMajor / yMajor)) + xMin
                .Axes(xlCategory).MaximumScale = xMax
            Else
                '---Adjust the values that are in longitude degrees to be in latitude degrees.
                xDiff = xDiff / latRatio
                
                '---calculate our new Y maximum
                yMax = (xDiff * (yMajor / xMajor) * (.PlotArea.InsideHeight / .PlotArea.InsideWidth)) + yMin
                .Axes(xlValue).MaximumScale = yMax
            End If 'end if xPoints > yPoints
        End If 'end IF meters else lats
    End With
End Sub

lengthOfLat and LengthOfLong are pretty simple:

'-----returns the length of one degree of latitude in meters at the given latitude.
'-----http://mathforum.org/library/drmath/view/61561.html
Public Function lengthOfLat(latitude As Double) As Double

    lengthOfLat = 60 * (1852.15742471835 - (9.25282778835 * ([pi()] / 180) * Cos(2 * latitude * ([pi()] / 180))))
End Function

'-----Returns the length of one degree of longitude in meters at the given latitude.
'-----http://www.csgnetwork.com/degreelenllavcalc.html
Public Function lengthOfLong(latitude As Double) As Double
    lengthOfLong = (111412.84 * Cos(latitude * ([pi()] / 180))) + (-93.5 * Cos(3 * latitude * ([pi()] / 180))) + (0.118 * Cos(5 * latitude * ([pi()] / 180)))

End Function

Not quite there. Let's move on to DDLabelsToDMS.
Currently the lat/lons are presented in decimal degree format, which isn't informative to most people. A more common lat/long notation is "Degree°Minute'Decimal-Second"... but this is a string, not a number. Excel will not let you put strings on the axes of a scatterplot... so we have to fake it. A common technique is to make a new dummy/helper series whose points are on the tickmarks and then set their labels to be the values we want and hide the original axis labels. The site linked does it manually; of course I want to add custom labels to the axis in VBA automatically. We can easily get the values for the new dummy series by using a 2D array and a simple loop. We start at the minimum value of the axis and increment that value by the MajorUnit of the axis and store each result in the array, with the non-axis value of the coordinate being "0". We then add the array to the chart as a new series and hide the original axis. That gives us "tickmarks" on the correct parts of the axis. We then label each individual tickmark with the DMS string.

We have one problem: hiding the original axis labels resizes the plot! We just spent all that time making it square and now we've just undone it. We can't do the squaring after because then our dummy series' points won't be in the right places since the squaring changes the MajorUnit and maximum on the axis. So we will have to reposition the PlotArea again to get it back to its proper size.

We can fix the axes by calculating the amount we have to change the Height and Width value of the PlotArea (remember, because PlotArea.InsideHeight and PlotArea.InsideLeft are read-only we have to alter them indirectly)

Here are the values we track for the Y axis:


To get the new InsideWidth we subtract oldLabelWidth from oldPlotWidth. We then have to add the padding between InsideLeft and Left otherwise the plot will be squished.
NewWidth = oldPlotAreaWidth - oldLabelWidth + (NewInsideLeft - NewPlotAreaLeft)

For the XAxis we need to adjust the PlotArea.Height to make it shorter. We simply make it equal to the old .Insideheight value, plus the height of the "padding" between PlotArea and (as I call it) InsidePlotArea:



newHeight = oldInsideheight + bottomPadding + topPadding



To convert degrees to DMS format I use a modified version of a method found here.

The whole DDLabelsToDMS looks like:
Public Sub DDLabelsToDMS(mychart As Chart, myAxis As Long)
    Dim DMSVals() As String
    Dim XVals() As Double
    Dim YVals() As Double
    Dim numTicks As Integer
    Dim myMajor As Double
    Dim mySeries As Series
    Dim min As Double

    Dim oldLabelWidth As Integer
    Dim oldInsideBoundry As Integer
    Dim oldPlotWidth As Integer
    
    Dim oldInsideheight As Integer
    Dim oldBoundryWidth As Integer
    Dim newBotBoundryWidth As Integer
    
    Dim i As Integer
    Dim j As Double
    
    '---Make sure the chart is a scatterplot
    Select Case mychart.ChartType
        Case Not xlXYScatter, Not xlXYScatterLines, Not xlXYScatterLinesNoMarkers, _
            Not xlXYScatterSmooth, Not xlXYScatterSmoothNoMarkers
            Exit Sub
    End Select
        
    '---Checks for if the given axis is valid and grabs some information
    '---that we use later to resize the plot area
    Select Case myAxis
        Case xlValue
            oldInsideBoundry = mychart.PlotArea.InsideLeft
            oldLabelWidth = oldInsideBoundry - mychart.PlotArea.Left
            oldPlotWidth = mychart.PlotArea.Width
        Case xlCategory
            oldInsideheight = mychart.PlotArea.InsideHeight
            oldBoundryWidth = mychart.PlotArea.InsideTop - mychart.PlotArea.Top
        Case Else
            Exit Sub
    End Select
    
    '---Grab some relevant info
    With mychart.Axes(myAxis)
        myMajor = .majorUnit
        numTicks = (.MaximumScale - .MinimumScale) / myMajor
        .TickLabelPosition = xlNone 'remove original tickmark labels
        j = .MinimumScale
        '---Adjust for if our axis isn't on the bottom or top so the labels float in the right place
        If myAxis = xlValue Then
            min = mychart.Axes(xlCategory).MinimumScale
            If min < 0 And mychart.Axes(xlCategory).MaximumScale > 0 Then
                min = 0
            End If
        Else
            min = mychart.Axes(xlValue).MinimumScale
            If min < 0 And mychart.Axes(xlValue).MaximumScale > 0 Then
                min = 0
            End If
        End If
    End With
        
    '---Make our holder arrays the right size
    ReDim DMSVals(0 To numTicks)
    ReDim XVals(0 To numTicks)
    ReDim YVals(0 To numTicks)

    '---Generate the X, Y and DMS values for our new dummy series
    For i = 0 To numTicks
        If myAxis = xlValue Then
            YVals(i) = j
            XVals(i) = min
        Else
            YVals(i) = min
            XVals(i) = j
        End If
        DMSVals(i) = LongLat.ConvertDegree(j)
        j = j + myMajor
    Next i

    '---Create the new dummy series and format it to look like an axis
    Set mySeries = mychart.SeriesCollection.NewSeries
    With mySeries
        .XValues = XVals
        .Values = YVals
        .HasDataLabels = True
        .Border.Weight = xlThin
        .Border.Color = 0

        '---Label the points and orient the labels the correct way
        For i = 1 To numTicks + 1
            .Points(i).datalabel.Text = DMSVals(i - 1)
            If myAxis = xlValue Then
                .Points(i).datalabel.Position = xlLabelPositionLeft
            Else
                .Points(i).datalabel.Position = xlLabelPositionBelow
                .Points(i).datalabel.Orientation = 90
            End If
        Next i
    End With
    
    '---Fix the plotarea which got messed up when we removed the original datalabels
    With mychart.PlotArea
        If myAxis = xlValue Then
            .Width = oldPlotWidth - oldLabelWidth + (.InsideLeft - .Left)
            .Left = oldInsideBoundry - (.InsideLeft - .Left)
            If mychart.Axes(xlValue).HasTitle Then mychart.Axes(xlValue).AxisTitle.Left = 3
        Else
            newBotBoundryWidth = .Height - (.InsideHeight + oldBoundryWidth)
            .Height = oldInsideheight + newBotBoundryWidth + oldBoundryWidth
            If mychart.Axes(xlCategory).HasTitle Then mychart.Axes(xlCategory).AxisTitle.Top = mychart.ChartArea.Height - 5
        End If
    End With
    
End Sub

And after that is done we can color the plot (simple routine I've posted before).
Voila; pretty pretty chart.:

Photobucket

0 things about

Formatting Excel Charts Automatically

Post a Comment

Copyright 2012 Phile not Found. See About
Powered by Blogger

"Whenever you find that you are on the side of the majority, it is time to pause and reflect."