The first thing we need to do is create a new module and set up some global variables. A dictionary object to hold a reference to the map object and ensure that the memory used by it doesn't get collected. A variable to hold the count of maps and a MapEvent object that will switch on and off events when switching sheets and books etc.
Public mcd As New Dictionary Public mcCount As Integer Dim clsMapEvent As New MapEvent
The next step is to create the subroutines that will enable and disable the map events. These subroutines are called from the MapEvent class.
Sub Set_All_Maps()
Dim mc1 As New MapChart
Dim cs As New VBA.Collection
Dim chtNumber As Integer
' Will not work or enable events for active sheet if sheet is a chart sheet'
' Enable events for all charts embedded on a sheet'
' Works for embedded charts on a worksheet or chart sheet'
If ActiveSheet.ChartObjects.Count > 0 Then
Dim chtObj As ChartObject
Dim chtnum As Integer
Dim sp As Shape
chtnum = 1
For Each chtObj In ActiveSheet.ChartObjects
If Left(chtObj.name, 3) = "Map" Then
Set mc1.MapChart = chtObj.Chart
Set mc1.srcDataRange = range(Cells(2, 1), Cells(2, 2)).CurrentRegion
For Each sp In chtObj.Chart.Shapes
cs.Add sp
Next
Set mc1.reg_shapes = cs
If Len(chtObj.name) > 3 Then
chtNumber = CInt(Mid(chtObj.name, 5, Len(chtObj.name) - 4))
mc1.SetScaleLow Workbooks("surveyScience.xlam").Worksheets("MapSheet").Cells(chtNumber, 4).Value, Workbooks("surveyScience.xlam").Worksheets("MapSheet").Cells(chtNumber, 5).Value, Workbooks("surveyScience.xlam").Worksheets("MapSheet").Cells(chtNumber, 6).Value
mc1.SetScaleHigh Workbooks("surveyScience.xlam").Worksheets("MapSheet").Cells(chtNumber, 7).Value, Workbooks("surveyScience.xlam").Worksheets("MapSheet").Cells(chtNumber, 8).Value, Workbooks("surveyScience.xlam").Worksheets("MapSheet").Cells(chtNumber, 9).Value
End If
mcd.Add mcd.Count + 1, mc1
End If
Next
End If
End Sub
Sub Reset_All_Maps()
' Disable events for all charts previously enabled'
Dim chtnum As Integer
On Error Resume Next
For chtnum = 1 To mcd.Count
Set mcd.Item(chtnum).MapChart = Nothing
Next
mcd.RemoveAll
End Sub
Some things need explaining in the above code. Firstly this is all run from an add-in I've called surveyscience.xlam (available here, if you're interested). It contains a sheet called MapSheet that holds details of the maps that I've defined. This is used to update the properties of the map chart. Also, this will only work for embedded charts. Adding code for this should be fairly simple though. I didn't bother as I was using the maps for a dashboard.
The Map Routine
Finally, we need to define the subroutine to create the actual map. This happens in two stages. The first stage loads the map definition to memory, creating the region and region_bit objects along the way. The map created by this macro is based on the details held in the MapSheet worksheet. The variable mapRow passed to the subroutine is used to look up the details from MapSheet.The second part creates the chart object and draws the map over the chart. The macro is fairly long unfortunately.
Private Sub CreateMap(mapRow As Integer)
'Maps'
Dim sdr As range 'Source data range'
Dim mc1 As New MapChart 'New map chart'
Dim co As Shape 'Base for map'
'Maxs and mins of map data'
Dim minX As Double
Dim minY As Double
Dim maxX As Double
Dim maxY As Double
minX = 1E+200
minY = 1E+200
maxX = -1E+200
maxY = -1E+200
'Load file'
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim fileNum As Integer
Dim mapFSO As FileSystemObject
Dim mapFile
Dim LineText As String
Dim arr
Dim header
Dim regName As String
Dim typ As String
Dim mapRegs As New VBA.Collection
Dim temp_reg As Region
Dim temp_bit As Region_Bit
Dim temp_point As MapPoint2D
Dim temp_coord
Dim defStr1 As String
Dim wk As Worksheet
Dim mapRange As range
'Add workbook if none exists'
If Workbooks.Count = 0 Then
Workbooks.Add
End If
'Add worksheet'
Set wk = Worksheets.Add
'Get path of map'
Set mapRange = Workbooks("surveyScience.xlam").Worksheets("MapSheet").Cells(1, 1).CurrentRegion
Set mapRange = range(mapRange(mapRow, 1), mapRange(mapRow, 9))
defStr1 = Workbooks("surveyScience.xlam").Worksheets("MapSheet").Cells(mapRow, 2).Text
Set mapFSO = CreateObject("Scripting.FileSystemObject")
Set mapFile = mapFSO.OpenTextFile(defStr1, 1, False, -1)
'Extract data from file'
Do While mapFile.AtEndOfStream <> True
LineText = mapFile.ReadLine
arr = Split(LineText, ";")
header = Split(arr(0), ",")
regName = header(5)
wk.Cells(mapRegs.Count + 2, 1) = regName
Set temp_reg = New Region
temp_reg.setName (regName)
temp_reg.setColour CInt(header(1)), CInt(header(2)), CInt(header(3))
If header(0) = "f" Then
temp_reg.setFill (True)
Else
temp_reg.setFill (False)
End If
arr = Split(arr(1), " ")
For i = 0 To UBound(arr)
If arr(i) = "M" Then
Set temp_bit = New Region_Bit
typ = "M"
ElseIf arr(i) = "L" Then
typ = "L"
ElseIf arr(i) = "z" Then
typ = "z"
temp_reg.addBit temp_bit
Set temp_bit = Nothing
Else
'Split point into x,y'
temp_coord = Split(arr(i), ",")
Set temp_point = New MapPoint2D
temp_point.SetX (temp_coord(0))
temp_point.SetY (temp_coord(1))
If typ = "M" Then
temp_bit.setStartPoint temp_point
ElseIf typ = "L" Then
temp_bit.addPoint temp_point
End If
'Set mins and maxs'
If temp_coord(0) > maxX Then maxX = temp_coord(0)
If temp_coord(1) > maxY Then maxY = temp_coord(1)
If temp_coord(0) < minX Then minX = temp_coord(0)
If temp_coord(1) < minY Then minY = temp_coord(1)
Set temp_point = Nothing
End If
Next
mapRegs.Add temp_reg
Set temp_reg = Nothing
Loop
mapFile.Close
'Create chart'
Set co = wk.Shapes.AddChart
co.Select
'Increase size of chart by 20%'
co.width = co.width * 1.2
co.Height = co.Height * 1.2
'Change name so that we can identify chart as a map'
ActiveChart.Parent.name = "Map_" & mapRow
'Assign active charts as map chart'
Set mc1.MapChart = ActiveChart
Set sdr = wk.range(Cells(2, 1), Cells(mapRegs.Count + 1, 2))
Set mc1.srcDataRange = sdr
Call mc1.SetScaleLow(mapRange.Cells(1, 4).Value, mapRange.Cells(1, 5).Value, mapRange.Cells(1, 6).Value)
Call mc1.SetScaleHigh(mapRange.Cells(1, 7).Value, mapRange.Cells(1, 8).Value, mapRange.Cells(1, 9).Value)
'Set properties of chart'
ActiveChart.SetSourceData Source:=sdr
ActiveChart.ChartType = xlColumnClustered
ActiveChart.PlotBy = xlColumns
ActiveChart.Legend.Delete
ActiveChart.HasTitle = False
ActiveChart.Axes(xlValue).Delete
ActiveChart.Axes(xlCategory).Delete
ActiveChart.Axes(xlValue).MajorGridlines.Delete
'Maxs and mins of plot area'
Dim x1 As Double
Dim y1 As Double
Dim x2 As Double
Dim y2 As Double
x1 = ActiveChart.PlotArea.Left
y1 = ActiveChart.PlotArea.Top
x2 = ActiveChart.PlotArea.Left + ActiveChart.PlotArea.width
y2 = ActiveChart.PlotArea.Top + ActiveChart.PlotArea.Height
'Background'
'Chart Area background'
With ActiveChart.Shapes.BuildFreeform(msoEditingAuto, -6, -6)
.AddNodes msoSegmentLine, msoEditingAuto, -6, ActiveChart.ChartArea.Height
.AddNodes msoSegmentLine, msoEditingAuto, ActiveChart.ChartArea.width, ActiveChart.ChartArea.Height
.AddNodes msoSegmentLine, msoEditingAuto, ActiveChart.ChartArea.width, -6
.AddNodes msoSegmentLine, msoEditingAuto, -6, -6
.ConvertToShape.name = "Background"
End With
'Calculate scaling factors'
Dim mx As Double
Dim cx As Double
Dim my As Double
Dim cy As Double
Dim dA As Double
Dim rA As Double
Dim ex As Double
mx = (x2 - x1) / (maxX - minX)
my = (y2 - y1) / (maxY - minY)
cx = x1 - mx * minX
cy = y1 - my * minY
'Keep aspect the same'
dA = Abs((y2 - y1) / (x2 - x1))
rA = Abs((maxY - minY) / (maxX - minX))
If (dA > rA) Then
ex = (maxY - minY) * (dA / rA - 1)
mx = (x2 - x1) / (maxX - minX)
my = (y2 - y1) / ((maxY + ex / 2) - (minY - ex / 2))
cx = x1 - mx * minX
cy = y1 - my * (minY - ex / 2)
ElseIf (dA < rA) Then
ex = (maxX - minX) * (rA / dA - 1)
mx = (x2 - x1) / ((maxX + ex / 2) - (minX - ex / 2))
my = (y2 - y1) / (maxY - minY)
cx = x1 - mx * (minX - ex / 2)
cy = y1 - my * minY
Else
mx = 1
my = 1
cx = 0
cy = 0
End If
'Draw parts of map'
Dim reg_shape
Dim t As Shape
Dim rs As New VBA.Collection
'Cycle through regions'
For i = 1 To mapRegs.Count
'Cycle through bits'
For j = 1 To mapRegs.Item(i).getNumBits
Set temp_bit = mapRegs.Item(i).getBit(j)
'Create new shape'
Set reg_shape = ActiveChart.Shapes.BuildFreeform(msoEditingAuto, temp_bit.getStartPoint().GetX() * mx + cx, temp_bit.getStartPoint().GetY() * my + cy)
'Cycle through points'
For k = 1 To mapRegs.Item(i).getBit(j).getNumPoints
'Add point to shape'
reg_shape.AddNodes msoSegmentLine, msoEditingAuto, temp_bit.getPoint(k).GetX() * mx + cx, temp_bit.getPoint(k).GetY() * my + cy
Next
'Convert to shape'
If mapRegs.Item(i).getFill() = True Then
Set t = reg_shape.ConvertToShape
With t
.name = mapRegs.Item(i).getName
.fill.ForeColor.RGB = mapRegs.Item(i).getColour2()
.Line.ForeColor.RGB = RGB(0, 0, 0)
.Line.Weight = 0.25
End With
rs.Add t
End If
Set reg_shape = Nothing
Next
Next
Set mc1.reg_shapes = rs
mcCount = mcCount + 1
mcd.Add mcCount, mc1
End Sub
Conclusion
And there it is, a way to create reasonable and extensible maps in Excel.
Presumably you could combine the two parts of the macro and create the shapes directly from the file. It might be easier. However, splitting the code makes it easier to change the subroutine to load in different map formats.
One limitation that I've found in Excel 2013 is that the shapes seem to default to a mitre join. This makes the maps look horrendous. There is no way to programmatically change the joins to round. You have to manually create a shape, change the join type, set the shape as the default type and then run the macro. Odd.
As usual, comments are welcome.
No comments:
Post a Comment