I reader of one of my earlier posts, Copy Data from one Shape to Another ( see http://davidjpp.wordpress.com/2009/02/02/copying-data-from-one-shape-to-another/ ) asked how a cow can inherit the field number of from the field that it in. I think that this is just an example of how you can automatically update any Shape Data value from an underlying container, but I will use a cow in a field example anyway. This example uses VBA code, but should be good to use in any version of Visio since Visio 2000.
I created a field shape, actually just a filled green rectangle with a brown dash line, with a single Shape Data row, Prop.FieldName. I also created a cow shape from Clip Art, and added two Shape Data rows, Prop.Name and Prop.InField. I also added an optional third Shape Data row, Prop.Quadrant, to add extra precision, if required.
So that you can easily see what the value is in the Prop.Name and Prop.InField rows, I inserted a custom formula into the text of the Cow shape:
=Prop.Name & IF(STRSAME(Prop.InField,””),” is not in a field”,” is in quadrant ” & Prop.Quadrant & ” of the “& Prop.InField & ” field”)
Thus, you can see which field the cow is in, and even which part of the field.
Obviously, you can type in the name (and quadrant) of the field that the cow is in, but you want it to update automatically whenever a cow is dropped into a field; moved between fields; moved out of any field; or even if the name of the field is changed. To do this, I added a formula in the EventXFMod cell of the Events section of the Cow shape.
The formula is:
=CALLTHIS(“GetContainerProp”,,”Prop.InField”,”Prop.FieldName”, “Prop.Quadrant”)
This is a call to the GetContainerProp macro with the parameters Prop.InField , Prop.FieldName and Prop.Quadrant.
The VBA method, GetContainerProp , is based on the ListShapesThatContain example in the Shapes \ Spatial Neighbor List in the Visio SDK Code Samples Library.
Public Sub GetContainerProp(ByVal shp As Visio.Shape, _
ByVal shpProp As String, ByVal containerProp As String, _
ByVal quadrantProp As String)
Dim vsoShapeOnPage As Visio.Shape
Dim intTolerance As Integer
Dim vsoReturnedSelection As Visio.Selection
Dim strSpatialRelation As String
Dim intSpatialRelation As VisSpatialRelationCodes
'Abort if source cell not found
If shp.CellExistsU(shpProp, Visio.visExistsAnywhere) = 0 Then
Exit Sub
Else
'Remove current formula
shp.CellsU(shpProp).FormulaForceU = "="""""
If Not shp.CellExistsU(quadrantProp, Visio.visExistsAnywhere) = 0 Then
shp.CellsU(quadrantProp).FormulaForceU = "="""""
End If
End If
'Initialize string
strSpatialRelation = ""
'Set tolerance argument
intTolerance = 0
'Set Spatial Relation argument
intSpatialRelation = visSpatialContainedIn + visSpatialTouching + visSpatialOverlap
'Get the set of spatially related shapes
'that meet the criteria set by the arguments.
Set vsoReturnedSelection = shp.SpatialNeighbors _
(intSpatialRelation, intTolerance, 0)
'Evaluate the results.
If vsoReturnedSelection.Count = 0 Then
'No shapes met the criteria set by
'the arguments of the method.
Else
'Check each shape in the selection
For Each vsoShapeOnPage In vsoReturnedSelection
'Abort if target cell not found
If Not vsoShapeOnPage.CellExistsU(containerProp, _
Visio.visExistsAnywhere) = 0 Then
'Check that the source Pin is over the container
If vsoShapeOnPage.HitTest(shp.Cells("PinX").ResultIU, _
shp.Cells("PinY").ResultIU, 0) Then
shp.CellsU(shpProp).FormulaForceU = _
"=GUARD(" & vsoShapeOnPage.NameID & "!" & containerProp & ")"
'Enter formula in the optional quadrant cell
If Not shp.CellExistsU(quadrantProp, Visio.visExistsAnywhere) = 0 Then
shp.CellsU(quadrantProp).FormulaForceU = _
"=GUARD(RECTSECT(" & vsoShapeOnPage.NameID & "!Width, " & _
vsoShapeOnPage.NameID & "!Height," & _
"PinX - (" & vsoShapeOnPage.NameID & "!PinX - " & _
vsoShapeOnPage.NameID & "!LocPinX + " & _
vsoShapeOnPage.NameID & "!Width * 0.5 ), " & _
"PinY - (" & vsoShapeOnPage.NameID & "!PinY - " & _
vsoShapeOnPage.NameID & "!LocPinY + " & _
vsoShapeOnPage.NameID & "!Height * 0.5) , 0 ))"
End If
Exit For
End If
End If
Next vsoShapeOnPage
End If
End Sub
This code works by utilizing the Shape.SpatialNeighbors property to get a list of the shapes that the cow is contained in; touching or overlapping (these are the Relation parameter). Each shape in this list is checked to see if has the required container cell, and, if it does, the Shape.HitTest method is used to check that the feet of the cow (its PinX and PinY) are in the field. To have a closer approximation of the cows feet position, and changed the LocPinY of the cow shape to be Height*0.
It is worth noting that the default for the SpatialNeighbors property is to include Visible geometry sections, and in the case of the imported Clip Art image that I used, it worked because a Geometry section existed with Geometry1.NoShow = FALSE, even though there is no fill or lines.
Note that the quadrant numbers for the RECTSECT() function start on the right, then increase anticlockwise:
There two cases that are not covered by my example, namely, when a field is deleted or moved away from any cows that are in it. The latter case can be handled by fixing the PinX and PinY of the Cow to be relative to the underlying field, but the former case needs code to react to the missing field. This can be done, but is beyond the scope of this post. In any case, I would recommend using events in an Add-In (usually vb.net or C#) for a more complete and robust solution, since lots of simultaneous individual calls with CALLTHIS() in VBA will degrade performance at some point.
Download the example Visio file from WhichFieldIsTheCowIn.vsd