I have become increasingly concerned about using data with maps of one sort or another. The new release of SQL Server 2008 includes Spatial Data (http://www.microsoft.com/sqlserver/2008/en/us/spatial-data.aspx ) which provides the ability to map data as boundaries (polylines), multi-segment lines (linestrings) and points. Virtual Earth has also just been revamped with the 6.2 release ( http://www.microsoft.com/virtualearth/ ). There are some great articles on integrating the two together … but, as usual, I want to bring Visio into the mix too! That will enable me to use Link Data to Shapes ( see https://bvisual.net/?s=+Link+Data+to+Shapes) or even create bubble-charts.
Well, actually, we could use an existing XML format for spatial data to enable Visio to read from a variety of mapping tools. Indeed, Microsoft have also started supporting KML (http://en.wikipedia.org/wiki/Kml), a format popularised by Google! Maps Live , which is powered by Virtual Earth, (http://maps.live.com/ ) allows you to export and import KML files via the collections toolset.
Getting the Shapes Collection
You can use the tools in the collections editor to draw areas (polylines) , path (linestrings) and pushpins (points).
You can then use Actions / Export / KML to produce an XML file in KML format. I have XMLNotepad 2007 (free from Microsoft http://msdn.microsoft.com/en-gb/xml/default.aspx) to view the KML file below:
Getting the Map Image
This is fine for the data, but what about the map image? Well, rather than use a screen capture tool, I decided to use the Print link in Live Search Maps that opens up a new web browser window.
The map image is actually made up of image tiles, so you can then select each one then use the right mouse menu item Copy to paste them onto a Visio page.
Similarly, you could do the same for the Road view.
I have placed the tiles in their groups roughly on a Visio page …
Then I used a bit of VBA code (called AbutTiles) to ensure that the image tiles are properly abutted.
Whilst we have control of the map image(s), we could group them together, then lock the group and aspect, and change the selection mode to group only.
Public Sub AbutTiles()
If Visio.ActiveWindow.Selection.Count = 0 Then
Exit Sub
End If
Dim shp As Visio.Shape
Dim cols As Integer
Dim rows As Integer
Dim col As Integer
Dim row As Integer
Dim wdth As Double
Dim hght As Double
Dim top As Double
Dim left As Double
Dim tolerance As Double
Dim anchorShape As String
‘Assume that all shapes are same height and width
wdth = Visio.ActiveWindow.Selection.Item(1).Cells(“Width”).ResultIU
hght = Visio.ActiveWindow.Selection.Item(1).Cells(“Height”).ResultIU
tolerance = wdth * 0.3
‘Assume that the shapes were selected from top left to bottom right
For Each shp In Visio.ActiveWindow.Selection
If cols = 0 Then
cols = 1
rows = 1
col = 1
row = 1
left = shp.Cells(“PinX”).ResultIU
top = shp.Cells(“PinY”).ResultIU
anchorShape = shp.NameID
Else
If shp.Cells(“PinX”).ResultIU > (left + tolerance) Then
col = col + 1
Else
col = 1
End If
If shp.Cells(“PinY”).ResultIU < (top – tolerance) And col = 1 Then
row = row + 1
End If
If cols < col Then
cols = col
End If
If rows < row Then
rows = row
End If
shp.Cells(“PinX”).FormulaU = “=” & left + ((col – 1) * wdth)
shp.Cells(“PinY”).FormulaU = “=” & top – ((row – 1) * hght)
End If
Next
‘Finally, group them together, and protect the shape
Dim shpMap As Visio.Shape
Set shpMap = Visio.ActiveWindow.Selection.Group
shpMap.Cells(“LockGroup”).FormulaU = “=1”
shpMap.Cells(“LockAspect”).FormulaU = “=1”
shpMap.Cells(“SelectMode”).FormulaU = “=0”
End Sub
Calibrating the Map Image(s)
We need to ensure that we know the extent of the map image in terms of longitude and latitude in order that we can import any KML file onto it. Fortunately, my good friend Chris Roth has already pointed the way with his article Map Distance Dimension Line ( http://www.visguy.com/2007/07/13/map-distance-dimension-line/ ). Simply use Chris’s shape between two easily identifiable points on your image…
Now, repeat this action in Live Search Maps by drawing a single line between the same geographical points, then name the Map Distance Dimension Line.
The line is then added to your collection, and so it will be there when you export the collection to KML.
You can already enter the actual length of the line in Visio to use he Map Distance Dimension Line as described by Chris, but we are going to use it get the longitude and latitude of each end.
Importing the KML File (part 1)
In order to parse the KML file, you will need to add a reference to Microsoft XML, and I always add Microsoft Scripting Runtime too.
Okay, now some VBA code….
Firstly, you need to select the map group shape, followed by the Map Distance Dimension Line shape before calling ReadKMLFile.
The main public Sub ReadKMLFile starts to parse the XML to get hold of the definition of the Map Distance Dimension Line so that it can be compared with the equivalent shape. It uses these two bits of information to calculate the longitude and latitude extents of the background map. These details are added the map shape, and the Map Distance Dimension Line is updated with the accurate length.
Public Sub ReadKMLFile()
‘Normally, I would use a FileOpen dialog here….
Dim kmlfile As String
kmlfile = InputBox(“Enter the path of a KML file”, “Import KML”)
If Len(kmlfile) = 0 Then
Exit Sub
ElseIf Len(Dir(kmlfile)) = 0 Then
Exit Sub
End If
Dim xdoc As MSXML2.DOMDocument
Set xdoc = New MSXML2.DOMDocument
If xdoc.Load(kmlfile) = False Then
Exit Sub
End If
Dim shpMap As Visio.Shape ‘Map Shape
If Visio.ActiveWindow.Selection.Count = 0 Then
MsgBox “Please select the map shape”
Exit Sub
Else
‘Assume that the map shape has been selected in Visio
Set shpMap = Visio.ActiveWindow.Selection.PrimaryItem
End If
‘see http://www.visguy.com/2007/07/13/map-distance-dimension-line/
Dim shpMDDL As Visio.Shape ‘Map Distance Dimension Line
Dim elmMDDL As MSXML2.IXMLDOMNode ‘Corresponding KML element
Const MDDLName As String = “Map Distance Dimension Line”
Set elmMDDL = xdoc.SelectSingleNode(“//kml/Document/Placemark[name='” & MDDLName & “‘]”)
If Not elmMDDL Is Nothing Then
‘There is a calibration node,
‘so there should be two shapes selected Map + MDDL
If Visio.ActiveWindow.Selection.Count <> 2 Then
MsgBox “Please select the map then the MDL shape”
Exit Sub
Else
Set shpMDDL = Visio.ActiveWindow.Selection.Item(2)
calibrateMap shpMap, shpMDDL, elmMDDL
End If
End If
End Sub
Private Sub calibrateMap(ByVal shpMap As Visio.Shape, _
ByVal shpMMDL As Visio.Shape, ByVal elmMDDL As MSXML2.IXMLDOMNode)
‘shpMap vars
Dim dWidth As Double
Dim dHeight As Double
Dim dX As Double
Dim dY As Double
Dim dXLeft As Double
Dim dYTop As Double
Dim dXRight As Double
Dim dYBottom As Double
Dim dLonLeft As Double
Dim dLatTop As Double
Dim dLonRight As Double
Dim dLatBottom As Double
‘shpMMDL vars
Dim dPinXBegin As Double
Dim dPinYBegin As Double
Dim dPinXEnd As Double
Dim dPinYEnd As Double
Dim dLength As Double
‘elemMMDL vars
Dim vertexes As Variant
Dim dLonBegin As Double
Dim dLatBegin As Double
Dim dLonEnd As Double
Dim dLatEnd As Double
Dim dDistance As Double ‘KM
‘Scale factor
Dim dRatio As Double
Dim dXRatio As Double
Dim dYRatio As Double
Dim i As Integer
‘Get map shape values
dWidth = shpMap.Cells(“Width”).ResultIU
dHeight = shpMap.Cells(“Height”).ResultIU
dXLeft = shpMap.Cells(“PinX”).ResultIU – shpMap.Cells(“LocPinX”).ResultIU
dYBottom = shpMap.Cells(“PinY”).ResultIU – shpMap.Cells(“LocPinY”).ResultIU
dYTop = dYBottom + dHeight
dXRight = dXLeft + dWidth
‘Get MMDL shape
dPinXBegin = shpMMDL.Cells(“BeginX”).ResultIU
dPinYBegin = shpMMDL.Cells(“BeginY”).ResultIU
dPinXEnd = shpMMDL.Cells(“EndX”).ResultIU
dPinYEnd = shpMMDL.Cells(“EndY”).ResultIU
dLength = shpMMDL.LengthIU
setCoords elmMDDL, vertexes
dLonBegin = vertexes(0, 0)
dLonEnd = vertexes(0, 1)
dLatBegin = vertexes(UBound(vertexes), 0)
dLatEnd = vertexes(UBound(vertexes), 1)
If shpMMDL.CellExists(“Prop.CurrentSize”, Visio.visExistsAnywhere) Then
shpMMDL.Cells(“Prop.CurrentSize”).FormulaU = “=” & getKMFromDegreesDisp(dLatBegin, dLonBegin, dLatEnd, dLonEnd) & ” km”
End If
dDistance = Sqr((dLonEnd – dLonBegin) ^ 2 + (dLatEnd – dLatBegin) ^ 2)
dRatio = dDistance / dLength
dXRatio = (dLonEnd – dLonBegin) / (dPinXEnd – dPinXBegin)
dYRatio = (dLatEnd – dLatBegin) / (dPinYEnd – dPinYBegin)
dLonLeft = dLonBegin – ((dPinXBegin – dXLeft) * dXRatio)
dLonRight = dLonLeft + (dWidth * dXRatio)
dLatBottom = dLatBegin – ((dPinYBegin – dYBottom) * dYRatio)
dLatTop = dLatBottom + (dHeight * dYRatio)
setProp shpMap, “MinLon”, “Min Longitude”, “2”, CStr(dLonLeft)
setProp shpMap, “MinLat”, “Min Latitude”, “2”, CStr(dLatBottom)
setProp shpMap, “MaxLon”, “Max Longitude”, “2”, CStr(dLonRight)
setProp shpMap, “MaxLat”, “Max Latitude”, “2”, CStr(dLatTop)
setProp shpMap, “DistanceX”, “Distance X”, “2”, CStr(getKMFromDegreesDisp(dLatBottom, dLonLeft, dLatBottom, dLonRight)) & ” km”
setProp shpMap, “DistanceY”, “Distance Y”, “2”, CStr(getKMFromDegreesDisp(dLatBottom, dLonLeft, dLatTop, dLonLeft)) & ” km”
Dim hLink As String
Dim elv As Integer
elv = 14
Dim dLonCntr As Double
dLonCntr = (dLonLeft + dLonRight) * 0.5
Dim dLatCntr As Double
dLatCntr = (dLatTop + dLatBottom) * 0.5
hLink = “http://maps.live.com/default.aspx?cp=” & Format(dLatCntr, “0.000000”) & “%7c” & Format(dLonCntr, “0.000000”) & “&style=h&lvl=” & elv & “&v=1”
setHLink shpMap, “Map”, “1”, “Show in Windows Live Local”, “1”, hLink
End Sub
Private Function pi() As Double
pi = 22 / 7
End Function
Private Function atan2(ys, xs)
‘ Given y and x coords returns atan2
‘ by Jim Deutch, Syracuse, New York
‘http://www.accessmonster.com/Uwe/Forum.aspx/access/102224/SQRT-and-ATAN2-functions-to-MS-Access-2007
Dim theta
If xs <> 0 Then
theta = Atn(ys / xs)
If xs < 0 Then
theta = theta + pi()
End If
Else
If ys < 0 Then
theta = 3 * pi() / 2 ’90
Else
theta = pi() / 2 ‘270
End If
End If
atan2 = theta
End Function
Public Function getKMFromDegreesDisp(ByVal Lat1 As Double, ByVal Long1 As Double, _
ByVal Lat2 As Double, ByVal Long2 As Double) As Double
Dim dDistance As Double
dDistance = 0
Dim dLat1InRad As Double
dLat1InRad = Lat1 * (pi() / 180)
Dim dLong1InRad As Double
dLong1InRad = Long1 * (pi() / 180)
Dim dLat2InRad As Double
dLat2InRad = Lat2 * (pi() / 180)
Dim dLong2InRad As Double
dLong2InRad = Long2 * (pi() / 180)
Dim dLongitude As Double
dLongitude = dLong2InRad – dLong1InRad
Dim dLatitude As Double
dLatitude = dLat2InRad – dLat1InRad
Dim a As Double
a = (Sin(dLatitude / 2) ^ 2) + Cos(dLat1InRad) * Cos(dLat2InRad) * (Sin(dLongitude / 2) ^ 2)
Dim c As Double
c = 2 * atan2(Sqr(a), Sqr(1 – a))
Const kEarthRadiusKms As Double = 6376.5
dDistance = kEarthRadiusKms * c
getKMFromDegreesDisp = dDistance
End Function
Private Function HexToDecimal(ByVal HexString As String) As Long
Dim x As Long
Dim vDec As Variant
vDec = CDec(0) ‘ decimal type supports up to 27 or 28 positions
For x = 1 To Len(HexString)
vDec = vDec * 16 + CDec(“&H” & Mid$(HexString, x, 1))
Next x
HexToDecimal = vDec
End Function
Private Sub setProp(ByVal shp As Visio.Shape, _
ByVal name As String, ByVal label As String, _
ByVal ptype As String, ByVal value As String)
Dim iRow As Integer
If shp.SectionExists(Visio.visSectionProp, Visio.visExistsAnywhere) = 0 Then
shp.AddSection Visio.visSectionProp
End If
If shp.CellExistsU(“Prop.” & name, Visio.visExistsAnywhere) = 0 Then
iRow = shp.AddNamedRow(Visio.visSectionProp, name, 0)
shp.CellsSRC(Visio.visSectionProp, iRow, Visio.visCustPropsLabel).Formula = “=””” & label & “”””
shp.CellsSRC(Visio.visSectionProp, iRow, Visio.visCustPropsType).Formula = “=” & ptype
Else
iRow = shp.Cells(“Prop.” & name).row
End If
shp.CellsSRC(Visio.visSectionProp, iRow, Visio.visCustPropsValue).Formula = “=” & value
End Sub
Private Sub setHLink(ByVal shp As Visio.Shape, _
ByVal name As String, ByVal default As String, _
ByVal description As String, ByVal newwin As String, _
ByVal address As String)
Dim iRow As Integer
If shp.SectionExists(Visio.visSectionHyperlink, Visio.visExistsAnywhere) = 0 Then
shp.AddSection Visio.visSectionHyperlink
End If
If shp.CellExistsU(“Hyperlink.” & name, Visio.visExistsAnywhere) = 0 Then
iRow = shp.AddNamedRow(Visio.visSectionHyperlink, name, 0)
shp.CellsSRC(Visio.visSectionHyperlink, iRow, Visio.visHLinkDefault).Formula = “=” & default
shp.CellsSRC(Visio.visSectionHyperlink, iRow, Visio.visHLinkDescription).Formula = “=””” & description & “”””
shp.CellsSRC(Visio.visSectionHyperlink, iRow, Visio.visHLinkNewWin).Formula = “=” & newwin
Else
iRow = shp.Cells(“Hyperlink.” & name).row
End If
shp.CellsSRC(Visio.visSectionHyperlink, iRow, Visio.visHLinkAddress).Formula = “=””” & address & “”””
End Sub
Private Sub setStyle(ByVal elem As MSXML2.IXMLDOMElement, _
ByRef dicStyles As Dictionary)
Dim id As String
Dim lineStyleColor As String
Dim lineStyleWidth As String
Dim polyStyleColor As String
Dim aStyle(2) As String
Dim i As Integer
Dim elemsub As MSXML2.IXMLDOMElement
Dim attr As String
id = elem.Attributes(0).Text
Set elemsub = elem.SelectSingleNode(“LineStyle”)
For i = 1 To elemsub.ChildNodes.Length
attr = elemsub.ChildNodes.Item(i – 1).nodeName
Select Case attr
Case “color”
aStyle(0) = elemsub.ChildNodes.Item(i – 1).Text
Case “width”
aStyle(1) = elemsub.ChildNodes.Item(i – 1).Text
End Select
Next i
Set elemsub = elem.SelectSingleNode(“PolyStyle”)
For i = 1 To elemsub.ChildNodes.Length
attr = elemsub.ChildNodes.Item(i – 1).nodeName
Select Case attr
Case “color”
aStyle(2) = elemsub.ChildNodes.Item(i – 1).Text
End Select
Next i
dicStyles.Add id, aStyle
End Sub
Private Sub setCoords(ByVal elem As MSXML2.IXMLDOMElement, _
ByRef vertices As Variant)
Dim coordinates As String
Dim coords As MSXML2.IXMLDOMNodeList
Dim vertexes() As String
Dim vertex() As String
Dim vtcs() As Double
Dim i As Integer
Set coords = elem.getElementsByTagName(“coordinates”)
If coords.Length > 0 Then
coordinates = coords(0).Text
vertexes = Split(coordinates, ” “)
For i = 0 To UBound(vertexes)
vertex = Split(vertexes(i), “,”)
ReDim Preserve vtcs(1, i)
vtcs(0, i) = vertex(0)
vtcs(1, i) = vertex(1)
Next i
vertices = vtcs
End If
End Sub
Private Sub setAttribs(ByVal placemark As MSXML2.IXMLDOMElement, _
ByRef name As String, ByRef description As String, _
ByRef styleUrl As String)
Dim attr As String
Dim i As Integer
name = “”
description = “”
styleUrl = “”
For i = 1 To placemark.ChildNodes.Length
attr = placemark.ChildNodes.Item(i – 1).nodeName
Select Case attr
Case “name”
name = placemark.ChildNodes.Item(i – 1).Text
Case “description”
description = placemark.ChildNodes.Item(i – 1).Text
Case “styleUrl”
styleUrl = placemark.ChildNodes.Item(i – 1).Text
End Select
Next i
End Sub
So, the result of the first bit of code is a new group shape that contains all of the map tile images, and it has shape data/custom properties for the extents of the world that it covers, and it has a hyperlink to open Maps Live to the centre of it!
Next, we’ll import the rest of the shapes….