• Create BookmarkCreate Bookmark
  • Create Note or TagCreate Note or Tag
  • PrintPrint
Share this Page URL
Help

Chapter 18. Event Handling in the Visio ... > VBA Code Behind Events for Visio Obj...

VBA Code Behind Events for Visio Objects

Events in Visio are defined in the Visio type library. Due to this definition set, each Visio object obtains its own event list. These event lists are specific to the Visio objects with which they are associated. For example, a document has a DocumentOpened and a DocumentCreated event, while a page has a BeforeShapeDeleted event. To illustrate this, the application listed in Listing 18.1 shows an event linked to the ShapeAdded event of the document object. The code looks at the object just added and ascertains if it is a shape object, a group object, or any other type of object. If it is a shape object, it then analyzes it to be sure that it has a filled area. If so, it reports the filled area to the user in a message box and then enables that total to be placed as text upon the face of the symbol. If it is a group object, it drills down into each sub-shape object, sums all of the valid filled areas, reports the filled area to the user in a message box, and then enables that total to be placed as text upon the face of the group symbol. The application then creates a custom formula in the EventXFMod cell of the resultant ShapeSheet that calls a slightly different area calculation subroutine, which recalculates the filled area after any resizing of the symbol and reposts the new area to the symbol's text.

Listing 18.1. Advanced Shape Area Calculator and Reporter

Private Sub Document_DocumentOpened(ByVal doc As IVDocument)
    Dim szMessageHolder As String
    szMessageHolder = "Drag out a Shape from the tools, i.e." & vbCrLf
    szMessageHolder = szMessageHolder & "Rectangle Tool, Ellipse Tool, Freeform Tool, Line Tool, Arc Tool, Pencil Tool." & vbCrLf
    szMessageHolder = szMessageHolder & "Or drag any Master from a Stencil." & vbCrLf
    szMessageHolder = szMessageHolder & "After the shape is instantiated, Resize the shape or move the shape or rotate the shape." & vbCrLf
    MsgBox szMessageHolder, vbInformation + vbOKOnly, "Read Me First"
End Sub
Private Sub Document_ShapeAdded(ByVal Shape As IVShape)
    Dim szMessageHolder As String
    Dim intRetVal As Integer
    Dim dblAreaHolder As Double
    dblAreaHolder = 0#
    Dim shpObjSubShape As Visio.Shape
    Dim intSubShapeCount As Integer
    Dim celObjEventXFModCell As Visio.Cell
    If Shape.Type = visTypeShape Then
        If Shape.Cells("Height").Result("in.") > 0 And Shape.Cells("Width").Result("in.") > 0 Then
            szMessageHolder = "The Filled Area of this Shape is: "
            szMessageHolder = szMessageHolder & Shape.AreaIU & " Sq. In." & vbCrLf
            szMessageHolder = szMessageHolder & "Do you want to place the value as text on the Shape?"
            intRetVal = MsgBox(szMessageHolder, vbInformation + vbYesNo, "Demonstration")
            If intRetVal = vbYes Then
                Shape.Text = Shape.AreaIU & " Sq. In."
            End If
        ElseIf Shape.Cells("Height").Result("in.") > 0 Then
            szMessageHolder = "The new Shape has no Width." & vbCrLf
            szMessageHolder = szMessageHolder & "The Shape's Height is: "
            szMessageHolder = szMessageHolder & Shape.Cells("Height").Result("in.") & " in."
            MsgBox szMessageHolder, vbInformation + vbOKOnly, "Demonstration"
        ElseIf Shape.Cells("Width").Result("in.") > 0 Then
            szMessageHolder = "The new Shape has no Height." & vbCrLf
            szMessageHolder = szMessageHolder & "The Shape's Width is: "
            szMessageHolder = szMessageHolder & Shape.Cells("Width").Result("in.") & " in."
            MsgBox szMessageHolder, vbInformation + vbOKOnly, "Demonstration"
        Else
            szMessageHolder = "This Shape Seems to have no area at all!"
            MsgBox szMessageHolder, vbInformation + vbOKOnly, "Demonstration"
        End If
    ElseIf Shape.Type = visTypeGroup Then
For intSubShapeCount = 1 To Shape.Shapes.Count
            Set shObjSubShape = Shape.Shapes.Item(intSubShapeCount)
            If shObjSubShape.Type = visTypeShape Then
                If shObjSubShape.Cells("Height").Result("in.") > 0 And 
shObjSubShape.Cells("Width").Result("in.") > 0 Then
                    dblAreaHolder = dblAreaHolder + shObjSubShape.AreaIU
                End If
            End If
        Next intSubShapeCount
        szMessageHolder = "The Filled Area of this Group Shape is: "
        szMessageHolder = szMessageHolder & dblAreaHolder & " Sq. In." & vbCrLf
        szMessageHolder = szMessageHolder & "Do you want to place the value as text on the Shape?"
        intRetVal = MsgBox(szMessageHolder, vbInformation + vbYesNo, "Demonstration")
        If intRetVal = vbYes Then
            Shape.Text = dblAreaHolder & " Sq. In."
        End If
    Else
        szMessageHolder = "The New Item Is Not A Shape" & vbCrLf & "Not Able To Calculate A Filled Area."
        MsgBox szMessageHolder, vbExclamation + vbOKOnly, "Demonstration"
    End If
    Set celObjEventXFModCell = Shape.Cells("EventXFMod")
    celObjEventXFModCell.FormulaForce = "RUNADDON(""ReRunAreaIU"")"
End Sub
Public Sub ReRunAreaIU()
    Dim MyShape As Visio.Shape
    Dim szMessageHolder As String
    Dim intRetVal As Integer
    Dim dblAreaHolder As Double
    dblAreaHolder = 0#
    Dim shpObjSubShape As Visio.Shape
    Dim intSubShapeCount As Integer
    Dim celObjEventXFModCell As Visio.Cell
    Set MyShape = Visio.ActiveWindow.Selection.Item(1)
    If MyShape.Type = visTypeShape Then
        If MyShape.Cells("Height").Result("in.") > 0 And MyShape.Cells("Width").Result("in.") > 0 Then
            MyShape.Text = MyShape.AreaIU & " Sq. In."
        ElseIf MyShape.Cells("Height").Result("in.") > 0 Then
            szMessageHolder = "The new Shape has no Width." & vbCrLf
            szMessageHolder = szMessageHolder & "The Shape's Height is: "
            szMessageHolder = szMessageHolder & MyShape.Cells("Height").Result("in.") & " in."
            MsgBox szMessageHolder, vbInformation + vbOKOnly, "Demonstration"
        ElseIf MyShape.Cells("Width").Result("in.") > 0 Then
            szMessageHolder = "The new Shape has no Height." & vbCrLf
            szMessageHolder = szMessageHolder & "The Shape's Width is: "
            szMessageHolder = szMessageHolder & MyShape.Cells("Width").Result("in.") & " in."
            MsgBox szMessageHolder, vbInformation + vbOKOnly, "Demonstration"
        Else
            szMessageHolder = "This Shape Seems to have no area at all!"
            MsgBox szMessageHolder, vbInformation + vbOKOnly, "Demonstration"
        End If
    ElseIf MyShape.Type = visTypeGroup Then
        For intSubShapeCount = 1 To MyShape.Shapes.Count
            Set shObjSubShape = MyShape.Shapes.Item(intSubShapeCount)
            If shObjSubShape.Type = visTypeShape Then
                If shObjSubShape.Cells("Height").Result("in.") > 0 And
shObjSubShape.Cells("Width").Result("in.") > 0 Then
                    dblAreaHolder = dblAreaHolder + shObjSubShape.AreaIU
                End If
            End If
        Next intSubShapeCount
        MyShape.Text = dblAreaHolder & " Sq. In."
    Else
        szMessageHolder = "The New Item Is Not A Shape" & vbCrLf & "Not Able To Calculate A Filled Area."
        MsgBox szMessageHolder, vbExclamation + vbOKOnly, "Demonstration"
    End If
End Sub


					  


PREVIEW

                                                                          

Not a subscriber?

Start A Free Trial


  
  • Creative Edge
  • Create BookmarkCreate Bookmark
  • Create Note or TagCreate Note or Tag
  • PrintPrint