I have recently been demonstrating how to automatically drop data point shapes into the correct latitude \ longitude position over a map image in Visio, and in this instalment I show how to automatically filter the dropped data points by a rectangular area. This will only work after calibrating the map image as in my previous article http://blog.bvisual.net/2015/05/26/calibrating-a-map-in-visio/ and then using the Data Point shape (or similar) from http://blog.bvisual.net/2015/05/27/distributing-data-points-automatically-on-maps-in-visio/
The principles of reading the Shape Data value from a selected shape to automatically drop rows from the active External Data window using the selected master shape could be applied to many scenarios.
The Open Bing Maps hyperlink that I added will also create a rectangle in the Bing Maps window:
The Area Marker master is just a simple rectangle with four Shape Data rows, and some optional inserted text:
The important formula is in the User.LLPositionTrigger row that I added. This updates the four Shape Data rows from the page User-defined cells that I added in the previous article http://blog.bvisual.net/2015/05/26/calibrating-a-map-in-visio/ .
| User.LLPositionTrigger | =DEPENDSON(PinX,PinY,Width,Height)+ SETF(GetRef(Prop.LongitudeLeft),ThePage!User.LLPosition1Lon+ (((PinX-LocPinX-ThePage!User.LLPosition1X)/ (ThePage!User.LLPosition1X-ThePage!User.LLPosition2X))* (ThePage!User.LLPosition1Lon-ThePage!User.LLPosition2Lon)))+ SETF(GetRef(Prop.LatitudeTop), ThePage!User.LLPosition1Lat+ (((PinY+Height-LocPinY-ThePage!User.LLPosition1Y)/ (ThePage!User.LLPosition1Y-ThePage!User.LLPosition2Y))* (ThePage!User.LLPosition1Lat-ThePage!User.LLPosition2Lat)))+ SETF(GetRef(Prop.LongitudeRight), ThePage!User.LLPosition1Lon+ (((PinX+Width-LocPinX-ThePage!User.LLPosition1X)/ (ThePage!User.LLPosition1X-ThePage!User.LLPosition2X))* (ThePage!User.LLPosition1Lon-ThePage!User.LLPosition2Lon)))+ SETF(GetRef(Prop.LatitudeBottom), ThePage!User.LLPosition1Lat+ (((PinY-LocPinY-ThePage!User.LLPosition1Y)/ (ThePage!User.LLPosition1Y-ThePage!User.LLPosition2Y))* (ThePage!User.LLPosition1Lat- ThePage!User.LLPosition2Lat))) |
| Hyperlink.BingMaps.Address | =”http://www.bing.com/maps/” |
| Hyperlink.BingMaps.ExtraInfo | =”v=2&sty=r&sp=polyline.”&Prop.LatitudeBottom&”_”& Prop.LongitudeLeft&”_”& Prop.LatitudeTop&”_”&Prop.LongitudeLeft&”_”& Prop.LatitudeTop&”_”& Prop.LongitudeRight&”_”&Prop.LatitudeBottom&”_”& Prop.LongitudeRight&”_”&Prop.LatitudeBottom&”_”& Prop.LongitudeLeft&”_”&NAME() |
| Actions.AddMarker.Action | =CALLTHIS(“AddMarkers”,””) |
| Actions.HideText.Action | =SETF(GetRef(HideText),NOT(HideText)) |
| Actions.HideText.Checked | =HideText |
NB Some line-breaks were added in the formulas above but must be removed when pasting into ShapeSheet cells.
I inserted four lines of text in the shape:
For clarity, the formulas are:
| =Prop.LongitudeLeft.Label&” = “&FORMAT(Prop.LongitudeLeft,”#.0000”) |
| =Prop.LongitudeRight.Label&” = “&FORMAT(Prop.LongitudeRight,”#.0000”) |
| =Prop.LatitudeTop.Label&” = “&FORMAT(Prop.LatitudeTop,”#.0000”) |
| =Prop.LatitudeBottom.Label&” = “&FORMAT(Prop.LatitudeBottom,”#.0000”) |
This is the sub-function called by the right mouse action of the Area Marker shape:
Public Sub AddMarkers(ByVal shp As Visio.Shape)
'Called by right mouse action on Area Marker shape
Call AddFilteredLL
End Sub
This function does most of the work!
Public Sub AddFilteredLL()
On Error GoTo errHandler
Dim mst As Visio.Master
Dim shp As Visio.Shape
Dim iRow As Integer
Dim hasLatitude As Boolean
Dim hasLongitude As Boolean
'Get the select data point shape
Set mst = GetSelectedMaster()
If mst Is Nothing Then
MsgBox "You must select a master to drop first", vbExclamation
Exit Sub
Else
'Check that shape contains Latitude and Longitude shape data
Set shp = mst.Shapes(1)
For iRow = 0 To shp.RowCount(visSectionProp) - 1
If shp.CellsSRC(visSectionProp, iRow, _
visCustPropsLabel).ResultStr("") = "Latitude" Then
hasLatitude = True
ElseIf shp.CellsSRC(visSectionProp, iRow, _
visCustPropsLabel).ResultStr("") = "Longitude" Then
hasLongitude = True
End If
Next
End If
If hasLatitude = False Or hasLongitude = False Then
MsgBox "The selected master does not have Latitude and Longitude Shape Data", vbExclamation
Exit Sub
End If
If ActiveWindow.Selection.Count = 0 Then
MsgBox "You must select a Area Marker shape first", vbExclamation
Exit Sub
End If
'Get the selected shape in the page
Set shp = ActiveWindow.Selection.PrimaryItem
'Get the Lat \ Lon of each edge
Dim latBottom As Double
Dim latTop As Double
Dim lonLeft As Double
Dim lonRight As Double
If shp.CellExists("Prop.LatitudeBottom", Visio.visExistsAnywhere) <> 0 Then
latBottom = shp.Cells("Prop.LatitudeBottom").ResultIU
End If
If shp.CellExists("Prop.LatitudeTop", Visio.visExistsAnywhere) <> 0 Then
latTop = shp.Cells("Prop.LatitudeTop").ResultIU
End If
If shp.CellExists("Prop.LongitudeLeft", Visio.visExistsAnywhere) <> 0 Then
lonLeft = shp.Cells("Prop.LongitudeLeft").ResultIU
End If
If shp.CellExists("Prop.LongitudeRight", Visio.visExistsAnywhere) <> 0 Then
lonRight = shp.Cells("Prop.LongitudeRight").ResultIU
End If
If latBottom = 0 Or latTop = 0 Or lonLeft = 0 Or lonRight = 0 Then
MsgBox "You must select a Area Marker shape first", vbExclamation
Exit Sub
End If
'Get the datarecordset
Dim drs As DataRecordset
Dim drsExists As Boolean
If Visio.ActiveDocument.DataRecordsets.Count = 0 Then
Exit Sub
End If
Set drs = Visio.ActiveWindow.Windows.ItemFromID( _
Visio.visWinIDExternalData).SelectedDataRecordset
If drs Is Nothing Then
'Abort if not present
MsgBox "There is no active external data!", vbInformation
Exit Sub
End If
'Get the Latitude column number
Dim latColumn As Long
latColumn = getColumnIndexByName(drs, "Latitude")
If latColumn = -1 Then
'Abort if not present
MsgBox "There is no Latitude in this recordset!", vbInformation
Exit Sub
End If
'Get the Longitude column number
Dim lonColumn As Long
lonColumn = getColumnIndexByName(drs, "Longitude")
If lonColumn = -1 Then
'Abort if not present
MsgBox "There is no Longitude in this recordset!", vbInformation
Exit Sub
End If
Dim sel As Visio.Selection
Dim pag As Visio.Page
Set pag = ActivePage
Set sel = pag.CreateSelection(visSelTypeByMaster, 0, mst)
sel.Delete
Dim aryRowIDs() As Long
Dim criteria As String
criteria = "[Longitude] >= " & lonLeft & " AND [Longitude] <= " & lonRight & _
" AND [Latitude] >= " & latBottom & " AND [Latitude] <= " & latTop
aryRowIDs = drs.GetDataRowIDs(criteria)
'Iterate thru the datarecordset rows
For iRow = 0 To UBound(aryRowIDs)
Set shp = pag.DropLinked(mst, 0, 0, drs.id, aryRowIDs(iRow), False)
Next iRow
exitHere:
Exit Sub
errHandler:
MsgBox Err.Description
Resume exitHere
End Sub
The following code returns the selected master shape in the active stencil, or nothing if there is not one selected.
Private Function GetSelectedMaster() As Visio.Master
'Called by AddFilteredLL
Dim vsoWindow As Visio.Window
Dim aobjSelectedMasters() As Object
Dim intNumberMasters As Integer
Dim vsoMaster As Visio.Master
Dim intCounter As Integer
intNumberMasters = 0
Set vsoMaster = Nothing
For Each vsoWindow In ActiveWindow.Windows
If (vsoWindow.Type = VisWinTypes.visStencil Or _
vsoWindow.Type = visDockedStencilBuiltIn) Then
aobjSelectedMasters = vsoWindow.SelectedMasters
For intCounter = LBound(aobjSelectedMasters) To UBound(aobjSelectedMasters)
On Error Resume Next
Set vsoMaster = Nothing
Set vsoMaster = aobjSelectedMasters(intCounter)
If Not vsoMaster Is Nothing Then
intNumberMasters = intNumberMasters + 1
Exit For
End If
Next
If (intNumberMasters > 0) Then
Exit For
End If
End If
Next
Set GetSelectedMaster = vsoMaster
End Function
This function gets the index of a data recordset column by name
Private Function getColumnIndexByName(ByVal drs As DataRecordset, _
ByVal columnName As String) As Integer
'Purpose: Return the named column index (or -1 if not present)
'Author : David J Parker, bVisual, 2015, no rights reserved
Dim column As Integer
getColumnIndexByName = -1
For column = 1 To drs.DataColumns.Count
If drs.DataColumns.Item(column).Name = columnName Then
getColumnIndexByName = column
Exit For
End If
Next column
End Function
Visio 2013 : http://1drv.ms/1LNMaqm