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 https://blog.bvisual.net/2015/05/26/calibrating-a-map-in-visio/ and then using the Data Point shape (or similar) from https://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.

image

The Open Bing Maps hyperlink that I added will also create a rectangle in the Bing Maps window:

image

The Area Marker master is just a simple rectangle with four Shape Data rows, and some optional inserted text:

image

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 https://blog.bvisual.net/2015/05/26/calibrating-a-map-in-visio/ .

image

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:

image

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

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

Chris Webb's BI Blog

Microsoft Analysis Services, MDX, DAX, Power Pivot, Power Query and Power BI

davecra.wordpress.com/

Microsoft Office 365 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: