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

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.:

## 0 things about

## Post a Comment