Using the Bubble Chart and MapPoint

Recent posts in the Visio newsgroups made me re-visit the Bubble Chart article in the Visio Insight blog (http://blogs.msdn.com/visio/archive/2007/02/06/introducing-the-bubble-chart.aspx ).

This is really great, but it made me think of a demonstration I did recently at the Office User Group in the UK. I copied a map out of MapPoint into Visio, and then I created data points of voting allegiances for each street. The demo worked well, except I had to place the shapes at each street manually. The Bubble Chart shows how shapes can be placed automatically in an X and Y position using the Visio 2007 Professional Link Data to Shapes feature, so I thought it would be cool to enhance the Bubble Chart to use Latitude and Longitude.

MapPoint is great, but it is nowhere near as programmable and adaptable as Visio … and Visio is my tool of choice.

The main part of the solution is to import the current area being viewed in MapPoint as a sub-shape of the Bubble Chart, and then set the Min/Max X & Y to the longitude and latitude of the map. The macro ImportMap reads the extent of the map and puts the latitude and longitude values into the relevant shape data in the Bubble Chart shape, if you have it selected. If you don’t have a Bubble Chart selected, then it just creates a new shape in the Visio page.

And as an extra, I have added a hyperlink to the Bubble Chart that opens Windows Live Local to the selected location.

(I haven’t gone overboard with the Bubble Data appearance – that can be done easily with multiple datasets and Data Graphics in Visio).

 

I decided to create a rectangle in MapPoint at the extents of the map area, with a suitable label, and then it can be used for exporting any enclosed pushpins to Excel (using the ExportPinsToXL macro). This Excel spreadsheet, or any other which has latitude and longitude value (as columns Y and X), can then be used to link in Visio.

Public Sub ImportMap()
Dim oApp As MapPoint.Application
Dim oMap As MapPoint.Map
Dim shpMap As Visio.Shape
Dim left As Long
Dim top As Long
Dim width As Long
Dim height As Long
Dim altitude As Long
Dim latitide As Double
Dim longitide As Double
Dim oLocs(1 To 5) As MapPoint.Location
Dim i As Integer
Dim x As Long
Dim y As Long
Dim pin As MapPoint.Pushpin
Dim rct As MapPoint.Shape
Dim distX As Double
Dim distY As Double
 
Set oApp = getMapApp
If oApp Is Nothing Then
  Exit Sub
End If
 
Set oMap = oApp.ActiveMap
 
left = oMap.left
width = oMap.width
top = oMap.top
height = oMap.height
altitude = oMap.altitude
 
Set oLocs(1) = oMap.Location 'Centre
x = oMap.LocationToX(oLocs(1))
y = oMap.LocationToY(oLocs(1))
 
Set oLocs(2) = oMap.XYToLocation(CLng(x - (0.5 * width)), CLng(y + (0.5 * height))) 'Bottom Left
Set oLocs(3) = oMap.XYToLocation(CLng(x + (0.5 * width)), CLng(y + (0.5 * height))) 'Bottom Right
Set oLocs(4) = oMap.XYToLocation(CLng(x + (0.5 * width)), CLng(y - (0.5 * height))) 'Top Right
Set oLocs(5) = oMap.XYToLocation(CLng(x - (0.5 * width)), CLng(y - (0.5 * height))) 'Top Left
 
distX = oMap.Distance(oLocs(2), oLocs(3))
distY = oMap.Distance(oLocs(2), oLocs(5))
 
Set rct = oMap.Shapes.AddShape(geoShapeRectangle, oLocs(1), distX, distY)
rct.Text = "Exported to Visio " & Format(Now, "ddddd")
rct.ZOrder geoSendBehindRoads
 
oMap.SelectedArea.SelectArea 0, 0, 0, 0 'width - left, height - top
 
oMap.CopyMap
 
If Visio.ActiveWindow.Selection.Count = 1 Then
  If Visio.ActiveWindow.Selection.PrimaryItem.Name = "Bubble Chart" Then
 
    Dim shpBubble As Visio.Shape
    Dim dWidth As Double
    Dim dHeight As Double
    Dim dPinX As Double
    Dim dPinY As Double
    Dim shp As Visio.Shape
 
    Set shpBubble = Visio.ActiveWindow.Selection.PrimaryItem
 
    dWidth = shpBubble.Cells("Width").ResultIU
    dHeight = shpBubble.Cells("Height").ResultIU
    dPinX = shpBubble.Cells("PinX").ResultIU
    dPinY = shpBubble.Cells("PinY").ResultIU
 
    If (distX / distY) > (dWidth / dHeight) Then 'Ratio of map width > chart width
      'Make chart shallower
      shpBubble.Cells("Height").Formula = dWidth * distY / distX
    Else
      shpBubble.Cells("Width").Formula = dHeight * distX / distY
     End If
 
    For Each shp In shpBubble.Shapes
      If shp.NameU = "Map" Then
       shp.Delete
       Exit For
      End If
    Next
 
    shpBubble.Paste
    shpBubble.Cells("Geometry1.NoFill").Formula = 1
    Set shpMap = shpBubble.Shapes(shpBubble.Shapes.Count)
    shpMap.Cells("PinX").Formula = "=" & shpBubble.NameID & "!Width*0.5"
    shpMap.Cells("PinY").Formula = "=" & shpBubble.NameID & "!Height*0.5"
    shpMap.Cells("Width").Formula = "=" & shpBubble.NameID & "!Width"
    shpMap.Cells("Height").Formula = "=" & shpBubble.NameID & "!Height"
    shpMap.Name = "Map"
 
    'Re-assign shpMap object
    Set shpMap = shpBubble
    shpMap.Cells("Prop.ChartMinX").Formula = oLocs(2).Longitude
    shpMap.Cells("Prop.ChartMinY").Formula = oLocs(2).Latitude
    shpMap.Cells("Prop.ChartMaxX").Formula = oLocs(4).Longitude
    shpMap.Cells("Prop.ChartMaxY").Formula = oLocs(4).Latitude
    shpMap.Cells("Prop.ChartXAxisLabel").Formula = "=""Longitude"""
    shpMap.Cells("Prop.ChartYAxisLabel").Formula = "=""Latitude"""
    shpMap.Text = oMap.Name
 
  End If
 
End If
 
 
If shpMap Is Nothing Then
  Visio.ActivePage.Paste
  Set shpMap = Visio.ActivePage.Shapes(Visio.ActivePage.Shapes.Count)
  shpMap.Name = "Map"
End If
 
shpMap.Cells("LockAspect").Formula = 1
 
Dim iRow As Integer
If shpMap.SectionExists(Visio.visSectionProp, Visio.visExistsAnywhere) = 0 Then
  shpMap.AddSection Visio.visSectionProp
End If
 
If shpBubble Is Nothing Then
 
  If shpMap.CellExistsU("Prop.MinLat", Visio.visExistsAnywhere) = 0 Then
   iRow = shpMap.AddNamedRow(Visio.visSectionProp, "MinLat", 0)
   shpMap.CellsSRC(Visio.visSectionProp, iRow, Visio.visCustPropsLabel).Formula = "=""Min Latitude"""
   shpMap.CellsSRC(Visio.visSectionProp, iRow, Visio.visCustPropsType).Formula = "=2"
  Else
   iRow = shpMap.Cells("Prop.MinLat").Row
  End If
 
  shpMap.CellsSRC(Visio.visSectionProp, iRow, Visio.visCustPropsValue).Formula = "=" & oLocs(2).Latitude
 
  If shpMap.CellExistsU("Prop.MinLon", Visio.visExistsAnywhere) = 0 Then
   iRow = shpMap.AddNamedRow(Visio.visSectionProp, "MinLon", 0)
   shpMap.CellsSRC(Visio.visSectionProp, iRow, Visio.visCustPropsLabel).Formula = "=""Min Longitude"""
   shpMap.CellsSRC(Visio.visSectionProp, iRow, Visio.visCustPropsType).Formula = "=2"
  Else
   iRow = shpMap.Cells("Prop.MinLon").Row
  End If
 
  shpMap.CellsSRC(Visio.visSectionProp, iRow, Visio.visCustPropsValue).Formula = "=" & oLocs(2).Longitude
 
  If shpMap.CellExistsU("Prop.MaxLat", Visio.visExistsAnywhere) = 0 Then
   iRow = shpMap.AddNamedRow(Visio.visSectionProp, "MaxLat", 0)
   shpMap.CellsSRC(Visio.visSectionProp, iRow, Visio.visCustPropsLabel).Formula = "=""Max Latitude"""
   shpMap.CellsSRC(Visio.visSectionProp, iRow, Visio.visCustPropsType).Formula = "=2"
  Else
   iRow = shpMap.Cells("Prop.MaxLat").Row
  End If
 
  shpMap.CellsSRC(Visio.visSectionProp, iRow, Visio.visCustPropsValue).Formula = "=" & oLocs(4).Latitude
 
  If shpMap.CellExistsU("Prop.MaxLon", Visio.visExistsAnywhere) = 0 Then
   iRow = shpMap.AddNamedRow(Visio.visSectionProp, "MaxLon", 0)
   shpMap.CellsSRC(Visio.visSectionProp, iRow, Visio.visCustPropsLabel).Formula = "=""Max Longitude"""
   shpMap.CellsSRC(Visio.visSectionProp, iRow, Visio.visCustPropsType).Formula = "=2"
  Else
   iRow = shpMap.Cells("Prop.MaxLon").Row
  End If
  shpMap.CellsSRC(Visio.visSectionProp, iRow, Visio.visCustPropsValue).Formula = "=" & oLocs(4).Longitude
End If
 
  If shpMap.CellExistsU("Prop.DistanceX", Visio.visExistsAnywhere) = 0 Then
   iRow = shpMap.AddNamedRow(Visio.visSectionProp, "DistanceX", 0)
   shpMap.CellsSRC(Visio.visSectionProp, iRow, Visio.visCustPropsLabel).Formula = "=""Distance X"""
   shpMap.CellsSRC(Visio.visSectionProp, iRow, Visio.visCustPropsType).Formula = "=2"
  Else
   iRow = shpMap.Cells("Prop.DistanceX").Row
  End If
 
  shpMap.CellsSRC(Visio.visSectionProp, iRow, Visio.visCustPropsValue).Formula = "=" & distX
 
  If shpMap.CellExistsU("Prop.DistanceY", Visio.visExistsAnywhere) = 0 Then
   iRow = shpMap.AddNamedRow(Visio.visSectionProp, "DistanceY", 0)
   shpMap.CellsSRC(Visio.visSectionProp, iRow, Visio.visCustPropsLabel).Formula = "=""Distance Y"""
   shpMap.CellsSRC(Visio.visSectionProp, iRow, Visio.visCustPropsType).Formula = "=2"
  Else
   iRow = shpMap.Cells("Prop.DistanceY").Row
  End If
 
  shpMap.CellsSRC(Visio.visSectionProp, iRow, Visio.visCustPropsValue).Formula = "=" & distY
 
  If shpMap.SectionExists(Visio.visSectionHyperlink, Visio.visExistsAnywhere) = 0 Then
   shpMap.AddSection Visio.visSectionHyperlink
  End If
 
  If shpMap.CellExistsU("Hyperlink.Map", Visio.VisExistsFlags.visExistsAnywhere) = 0 Then
   iRow = shpMap.AddNamedRow(Visio.visSectionHyperlink, "Map", 0)
   shpMap.CellsSRC(Visio.visSectionHyperlink, iRow, Visio.visHLinkDefault).Formula = "=1"
   shpMap.CellsSRC(Visio.visSectionHyperlink, iRow, Visio.visHLinkDescription).Formula = "=""Show in Windows Live Local"""
   shpMap.CellsSRC(Visio.visSectionHyperlink, iRow, Visio.visHLinkNewWin).Formula = "=1"
  Else
   iRow = shpMap.Cells("Hyperlink.Map").Row
  End If
 
Dim hLink As String
Dim elv As Integer
  If oApp.Units = geoMiles Then
   elv = 18 - CInt((18 * (oMap.altitude / 24854)))
  Else
   elv = 18 - CInt((18 * (oMap.altitude / 39999)))
  End If
 
  hLink = "http://local.live.com/default.aspx?cp=" & Format(oLocs(1).Latitude, "0.000000") & "%7c" & Format(oLocs(1).Longitude, "0.000000") & "&style=h&lvl=" & elv & "&v=1"
 
  shpMap.CellsSRC(Visio.visSectionHyperlink, iRow, Visio.visHLinkAddress).Formula = "=""" & hLink & """"
 
End Sub

Private Function getMapApp() As MapPoint.Application
  Set getMapApp = GetObject(, "MapPoint.Application")
End Function

Private Function getXlApp() As Excel.Application
  Set getXlApp = GetObject(, "Excel.Application")
End Function

Public Sub ExportPinsToXL()
 
Dim oMapApp As MapPoint.Application
Dim shp As MapPoint.Shape
Dim ds As MapPoint.DataSet
Dim rs As MapPoint.Recordset
Dim pin As MapPoint.Pushpin
Dim oXLApp As Excel.Application
Dim oWkb As Excel.Workbook
Dim oWks As Excel.Worksheet
Dim iRow As Integer
Dim iCol As Integer
 
Set oMapApp = getMapApp
If oMapApp Is Nothing Then
  Exit Sub
End If
 
If oMapApp.ActiveMap.Selection Is Nothing Then
  Exit Sub
ElseIf Not TypeOf oMapApp.ActiveMap.Selection Is MapPoint.Shape Then
  Exit Sub
End If
 
Set oXLApp = getXlApp
If oXLApp Is Nothing Then
  Exit Sub
End If
 
Set shp = oMapApp.ActiveMap.Selection
Set oWkb = oXLApp.Workbooks.Add
Set oWks = oWkb.Worksheets(1)
 
iRow = 1
oWks.Cells(iRow, 1) = "Label"
oWks.Cells(iRow, 2) = "Size"
oWks.Cells(iRow, 3) = "Note"
oWks.Cells(iRow, 4) = "X"
oWks.Cells(iRow, 5) = "Y"
oWks.Cells(iRow, 6) = "Dataset"
 
For Each ds In oMapApp.ActiveMap.DataSets
  Set rs = ds.QueryShape(shp)
  Do Until rs.EOF
   iRow = iRow + 1
   Set pin = rs.Pushpin
   oWks.Cells(iRow, 1) = pin.Name
   oWks.Cells(iRow, 2) = pin.Symbol + 1
   oWks.Cells(iRow, 3) = pin.Note
   oWks.Cells(iRow, 4) = pin.Location.Longitude
   oWks.Cells(iRow, 5) = pin.Location.Latitude
   oWks.Cells(iRow, 6) = ds.Name
   rs.MoveNext
  Loop
Next
 
End Sub 

 

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s

davecra.wordpress.com/

Microsoft Office Development, and more...

PowerShell.Amsterdam

Automate, Accelerate, Accurate

johnvisiomvp

Life with Visio and other Microsoft Toys!

Title (Required)

Windows Server Essentials Tips & Tricks

Nilsandrey's Weblog

Just another WordPress.com weblog

Things that Should be Easy

Every so often (too often in the IT industry) I encounter things that should have been very easy to do but turned out to be far too complicated. My favorite topics include SharePoint, .Net development, and software architecture, especially distributed systems.

Visio Guy

Shapes, Stencils, Drawings Templates, Tutorials, Tips & Developer Info for Microsoft Visio

Hannes's Virtual Earth

Tips & Tricks around Mapping and Cloud Computing

Pluralsight blog

be smart, be clear, be visual ...

%d bloggers like this: