Filter Visio External Data to Drop Shapes

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

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:

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