David A Edson

Ceuid Mile Failte an’ welcome back again. In this article I'll discuss a new bit of functionality which came about with Visio 4.5 that can work minor miracles for ye. This is the "HitTest" function available through VBA. Now I suppose I should begin this by describing just what the HitTest function is’ and what it can do for you.

The HitTest function is a Visio API call, which can test any shape that has been dropped, either by dragging from a stencil, copied, or simply moved. This test will return an integer, which tells you if the shape has been dropped;

• outside the boundary of a target shape,
• on the boundary of a target shape, or
• inside the filled area of a 2-D shape, or on the line of a 1-D shape.

These, and many more examples, are but a few of the reasons why this technology is both helpful and important. So let’s, then, have a wee look at the function itself; its syntax and its required arguments:

IntegerReturnValue = object.HitTest(x_test_position, y_test_position, tolerance)

Note, also, that the object is a single object, not a collection. To effectively use this functionality, you will need to test against all potential objects that could be at the given x and y coordinate specified. It is therefore quite easy to test against all of the shapes in a given drawing. You simply obtain the drawings Shapes collection:

Set AllShapes = Visio.ActivePage.Shapes

and obtain the count property:

Set FullCount = AllShapes.Count

and then loop through the shapes obtaining the results of each test until you arrive at the desired result, taking action at that time. The code would look something like the following:

Public Sub WhereDidILand ()
Dim AllShapes As Visio.Shapes
‘the collection of all shapes on the page
Dim Source As Visio.Shape
‘a shape to be tested on its drop
Dim S_PinX As Visio.Cell
‘ the test shapes PinX cell
Dim S_PinY As Visio.Cell
‘ the test shapes PinY cell
Dim FullCount As Integer
‘ the number of shapes on the page
Dim Counter As Integer
‘ a counter for the loop
Dim IntRetVal As Integer
‘ a holder for the function return value
Dim MessageText As String

‘ a string for a user message
Set AllShapes = Visio.ActivePage.Shapes
‘ Get all of the shapes on the active page of the document

FullCount = AllShapes.Count
‘ Find out how many of them exist in this document on this page
Set Source = Visio.ActiveWindow.Selection.Item(1)
‘ get the currently selected shape, i.e. the shape just dropped

For Counter = 1 To FullCount
‘ begin a loop to step through all of the shapes
IntRetVal = AllShapes.Item(Counter).HitTest(S_PinX, S_PinY, 0.125)
‘ perform the actual HitTest using a "fudge-Factor" of 1/8 inch
‘ note we are looking at each shape on the page as the analysis object
‘ and using the test shapes PinX and PinY as the locator

Select Case IntRetVal
‘ begin a select case construct
Case 0
‘ if HitTest returned the integer zero
‘ then the subject was dropped outside the boundary of the target shape
MessageText = "Outside the Target Shape."
Case 1
‘ if HitTest returned the integer one
‘ then the subject was dropped on the boundary of the target shape
MessageText = "On the Boundary of the Target Shape."
Case 2
‘ if HitTest returned the integer two
‘ then the subject was dropped inside the filled area of the target shape
MessageText = "In the Filled Area of the Target Shape."
End Select
‘ end the select case construct

MsgBox "You have just Landed " & MessageText
‘ concatinate and display the message to the user
Next Counter
‘ end of the for Next loop
End Sub
‘end of the subroutine

Weel we can take steps to insure that the test shape itself is eliminated from the selection as follows:

Public Sub WhereDidILand ()
Dim AllShapes As Visio.Shapes
Dim Source As Visio.Shape
Dim S_Name As String
‘ The name of the Source Shape
Dim S_PinX As Visio.Cell
Dim S_PinY As Visio.Cell
Dim Target As Visio.Shape
‘ the target shape to be analysed
Dim FullCount As Integer
Dim Counter As Integer
Dim IntRetVal As Integer
Dim MessageText As String

Set AllShapes = Visio.ActivePage.Shapes
FullCount = AllShapes.Count
Set Source = Visio.ActiveWindow.Selection.Item(1)
S_Name = Source.Name
‘ get the name of the source shape
S_Name = Source.Name

For Counter = 1 To FullCount
Set Target = AllShapes.Item(Counter)
If Target.Name <> S_Name
‘ validate that we are not looking ate the source shape
IntRetVal = Target.HitTest(S_PinX, S_PinY, 0.125)

Select Case IntRetVal
Case 0
MessageText = "Outside the Target Shape."
Case 1
MessageText = "On the Boundary of the Target Shape."
Case 2
MessageText = "In Filled Area of the Target Shape."
End Select

MsgBox "You have just Landed " & MessageText
End If
‘ end the If test
Next Counter
End Sub

Now as tae the issue of having to test against all o’ the shapes in a given Document’s page… It is best to build either a collection or an array of the shapes that you wish to test against, and THEN run the hit test against THAT selection/collection. This will greatly diminish the number of iterations through the loop and truly enhance the speed and functionality of your solution. One method of making this possible is to add a user-defined cell to each of the shapes that you wish to be members of the target selection/collection and then on Document Open build the selection/collection one time and use this public selection/collection as your test criteria loop. The code fragment below illustrates one methodology for implementing this:

Public Sub GetTShapes()
'Build a list of shapes that are target shapes to reduce
'hit test searching when source shapes are dropped
Dim i As Integer
Dim iCt As Integer
Dim iFoundShapes As Integer
Dim shp As Visio.Shape
Dim pg As Visio.Page
Set pg = Visio.ActiveDocument.Pages.Item(1)

‘Scan page 1 for shapes that are target shapes
iCt = pg.Shapes.Count
If iCt < 1 Then Exit Sub
ReDim TLShapes(1 To iCt)
iFoundShapes = 0

For i = 1 To iCt
Set shp = pg.Shapes.Item(i)
If shp.CellExists("User.Class", 1) Then
‘this presumes that shapes exist with a user-defined cell called ``User.Class``
If shp.Cells("User.Class").Formula = """Valid Target""" Then
'We really do have a target shape!
‘ this presumes a user-defined cell on each target shape with
‘ the value ``Valid Target`` in that cell
iFoundShapes = iFoundShapes + 1
TLShapes(iFoundShapes) = shp.Name
End If
End If
Next i

'Collapse the array:
If iFoundShapes > 0 Then ReDim Preserve TLShapes(1 To iFoundShapes)

MsgBox "Retrieved " & UBound(TLShapes) & " Shapes"

End Sub

"Haste ye back."

Dave "The Auld Scotsman" Edson