PC World Komputer 1999 January/pcwk_01_1999.iso/Wtestowe/Vistdstd/Install/Data.Z/Orgchart.BAS

BASIC Source File | 1996-09-05 | 34KB | 842 lines

Attribute VB_Name = "ORGCHART1"
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
'--
'--                       Visio Organization Chart AddOn
'--                       (C)1993 Shapeware Corporation
'--
'--   File Name : OrgChart.bas
'--
'-- Description : Main module for the OrgChart AddOn
'--
'-- Audit Trail:
'--
'-- 09/**/93 - v2.001 - aw -    The procedures that have comments in them are modified,
'--                             all totally changed. Code has been deleted, and bugs that
'--                             had to do with reading orgchart from Visio is corrected.
'--                             CreateOrgChart now colors the 2D shapes again.
'--                             ReadOrgChart can read the orgchart both when user uses
'--                             a combination of 1D and 2D shapes, or 2D shapes and control
'--                             points. In the case of 2D/1D, the y-value of the 2D shape's
'--                             connection point (where the 1D shape is connected )decides
'--                             which 2D shape is partent of another 2D shape.
'-- 07/**/93 - v2.000 - bl -    Added code for read orgchart in menu chart.
'-- **/**/** - v1.001 - rf -    Updated code.
'-- **/**/** - v1.000 - ** -    Created.(PM or TB)
'--
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
Option Explicit
'Option Base 1

'Maximum number of objects for arrays used when create orgchart
Global Const cMax% = 60

'-- Constants used to identify the items in the chart menu
Global Const ShowItems% = 0
Global Const CreateChart% = 1
Global Const ReadChart% = 2

'-- Constants used to identify the items in the command menu
Global Const Promote% = 0
Global Const Demote% = 1
Global Const Delet% = 2
Global Const DeleteBranch% = 3

'-- Used when ask user to clear the orgchart scetched in the outline control
Global Const MB_YESNO = 4
Global Const IDNO = 7

'-- Key Codes
Global Const KEY_BACK = &H8
Global Const KEY_TAB = &H9
Global Const KEY_SHIFT = &H10
Global Const KEY_RETURN = &HD
Global Const KEY_LEFT = &H25
Global Const KEY_UP = &H26
Global Const KEY_RIGHT = &H27
Global Const KEY_DOWN = &H28

Global Const SHIFT_MASK = 1
Global Const CTRL_MASK = 2
Global Const ALT_MASK = 4

Global Const CURSOR_HOURGLASS = 11
Global Const CURSOR_NORMAL = 1

Function BuildOneD(cShapesCount As Integer, objDocument As Visio.Document) As String
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function:   ReadOrgChart()
'-- Functions called:
'-- This function has an effect only when the user has connected the 2D
'-- BuildOneD loops through all the shapes, if it's a one dimensional shape, it checks it's
'-- connections, and saves what is connected to what. This function uses heuristics, it assumes
'-- that if a 1D shape is glued to the bottom most connection point of the 2D shape, (connection
'-- no 4), this 2D shape is the parent of the shape in the other end of the 1D which will be
'-- connections no 2. Format of the string will be: {003 001}{002 001}.... if 003 and 002
'-- are children of 001
'--

    Dim i As Integer
    Dim strS As String
    Dim objShapes As Visio.Shapes, objConnections As Visio.Connects
    Dim TB As String

    TB = Chr$(9)

    Set objShapes = objDocument.Pages(1).Shapes
    For i = 1 To cShapesCount
        If objShapes(i).OneD Then
            Set objConnections = objShapes(i).Connects
            If (objConnections.Count = 2) Then
                'Connections(1) has highest y-value (highest y-value = from shape)
                If objConnections(1).ToPart = (visConnectionPoint + visRowFirst + 1) Then
                    strS = strS & "{" & Format$(objConnections(1).ToSheet.Index, "000") & TB & Format$(objConnections(2).ToSheet.Index, "000") & "}"
                Else    'Connections(2) has highest y-value
                    strS = strS & "{" & Format$(objConnections(2).ToSheet.Index, "000") & TB & Format$(objConnections(1).ToSheet.Index, "000") & "}"
                End If
            End If
        End If
    Next i
    BuildOneD = strS
End Function

Function BuildTwoD(cShapesCount As Integer, objDocument As Visio.Document) As String
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function:   ReadOrgChart()
'-- Functions called:
'-- BuildTwoD loops through all the shapes, and if it's a two dimensional shape it checks it's
'-- connections, and saves what is connected to what. Format of the string will be..
'-- 001PeterCR
'-- 002TroyCR
'-- 003AirenCR.....
'--

    Dim i As Integer
    Dim strS As String
    Dim objShapes As Visio.Shapes, objConnections As Visio.Connects
    Dim CR As String, TB As String

    CR = Chr$(13): TB = Chr$(9)

    Set objShapes = objDocument.Pages(1).Shapes
    For i = 1 To cShapesCount
        If Not objShapes(i).OneD Then
            strS = strS & Format$(Str$(i), "000") & objShapes(i).Text '& CR
            Set objConnections = objShapes(i).Connects
            '-- This is only the case if the user choses to use the 2D shape's control point to
            '-- to connect to another shape instead of 1D connectors.
            If objConnections.Count > 0 Then
                strS = strS & TB & Format$(objConnections(1).ToSheet.Index, "000")
            End If
            strS = strS & CR
        End If
    Next i
    BuildTwoD = strS
End Function

Sub ConvertStr(strTwoD As String, cShapesCount As Integer)
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function:   ReadOrgChart()
'-- Functions called:
'-- ConvertStr loops through all the shapes in strTwoD and changes the format from being a list
'-- of shapes, each followed by their parent, to a list of shapes, each followed by their
'-- children.
'--

    Dim i As Integer, iTab As Integer, iPos As Integer, iCr As Integer
    Dim strParent As String, strShape As String, strRside As String
    Dim CR As String, TB As String

    CR = Chr$(13): TB = Chr$(9)

    For i = 1 To cShapesCount
        iPos = InStr(strTwoD, Format$(i, "000"))
         If iPos <> 0 Then
            strShape = Mid$(strTwoD, iPos, 3)
            iCr = InStr(iPos, strTwoD, CR)
            iTab = InStr(iPos, strTwoD, TB)
            '-- Take the parent and find the line it's on, and add the current shape
            '-- to it's list of children.
            If iTab <> 0 And iTab < iCr Then
                strParent = Mid$(strTwoD, iTab + 1, 3)
                iPos = InStr(strTwoD, CR & strParent)
                iPos = iPos + 1                 '-- Get pass the CR character
                iCr = InStr(iPos, strTwoD, CR)
                strRside = Right$(strTwoD, Len(strTwoD) - (iCr - 1))
                strTwoD = Left$(strTwoD, iCr - 1) & "#" & strShape & strRside
                '-- Go back to the current shape again, and remove the parent in the list.
                iPos = InStr(strTwoD, Format$(i, "000"))
                iPos = InStr(iPos, strTwoD, TB & strParent)
                strRside = Right$(strTwoD, Len(strTwoD) - (iPos + 3))
                strTwoD = Left$(strTwoD, iPos - 1) & strRside
            End If
        End If
    Next i
End Sub

Sub CreateOrgChart()
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function:   frmOrgChart.mnuChartItem_Click()
'-- Functions called:   DrawOrgChart()
'-- CreateOrgChart loops through the items in the form's outline control and finds the max level,
'-- numbers of leaves, and parent chain. It calls DrawOrgChart which draws the organizational
'-- chart in Visio.
'--
    ReDim rgParent(cMax) As Integer, rgLeft(cMax) As Integer, rgRight(cMax) As Integer
    Dim cLevels As Integer, cLeaves As Integer, fIsLeaf As Integer
    Dim iIndex  As Integer, iIndent As Integer

    cLevels = 0
    cLeaves = 0

    For iIndex = 0 To frmOrgChart.Outline1.ListCount - 1

        If frmOrgChart.Outline1.Indent(iIndex) < 1 Then
            rgParent(iIndex) = -1           'the root, has no parent
        ElseIf frmOrgChart.Outline1.Indent(iIndex) > frmOrgChart.Outline1.Indent(iIndex - 1) Then
            rgParent(iIndex) = iIndex - 1
        Else
            iIndent = iIndex - 1
            While frmOrgChart.Outline1.Indent(iIndex) <> frmOrgChart.Outline1.Indent(iIndent)
                iIndent = rgParent(iIndent)
            Wend
            rgParent(iIndex) = rgParent(iIndent)
        End If

        '-- The item is a leaf if it doesn't have any children
        fIsLeaf = Not (frmOrgChart.Outline1.HasSubItems(iIndex))

        '-- If it's a leaf, then set it's left- and right "pointer" to NULL
        If Not fIsLeaf Then
            rgLeft(iIndex) = -1
            rgRight(iIndex) = -1
        Else
            rgLeft(iIndex) = cLeaves
            rgRight(iIndex) = cLeaves
            iIndent = rgParent(iIndex)
            While iIndent <> -1
                If rgLeft(iIndent) = -1 Then rgLeft(iIndent) = cLeaves
                rgRight(iIndent) = cLeaves
                iIndent = rgParent(iIndent)
            Wend
        End If

        If frmOrgChart.Outline1.Indent(iIndex) > cLevels Then
            cLevels = frmOrgChart.Outline1.Indent(iIndex)
        End If

        If fIsLeaf Then cLeaves = cLeaves + 1
    Next iIndex

    DrawOrgChart rgParent(), rgLeft(), rgRight(), cLeaves, cLevels
    Exit Sub
End Sub

Sub DeleteItem()
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function:   frmOrgChart.mnuCommandItem()
'-- Functions called:   SuperExpand(), PromoteChild(), TopExpand(), UpdateFields()
'-- DeleteItem has to update the indentation level for all of the children of the item to be
'-- deleted before the item is removed since otherwise the children will be deleted as well.
'--
    Dim ctl As Control

    'Short form...
    Set ctl = frmOrgChart.Outline1

    'SuperExpand (ctl.ListIndex)
    Select Case ctl.ListIndex
        Case -1:
            Beep       '-- Nothing in the outline control
        Case 0:        '-- Try to delete the root
            If ctl.HasSubItems(ctl.ListIndex) Then
                Beep
                'If one child - ok
                'If more than one child then tell user it cannot be done
            Else
                ctl.RemoveItem ctl.ListIndex
            End If
        Case Else:
            '-- Delete the item after all of it's children's indent have been updated.
            PromoteChild ctl.ListIndex + 1, (ctl.Indent(ctl.ListIndex))
            ctl.RemoveItem ctl.ListIndex
    End Select
    UpdateFields
End Sub

Sub DeleteItemBranch()
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function:   frmOrgChart.mnuCommandItem()
'-- Functions called:
'-- DeleteItemBranch deletes the item identified by ListIndex, and all of it's children.
'-- (RemoveItem method removes the item and all of it's subordinate items for an outline
'-- control).
'--
    Dim ctl As Control

    'Short form...
    Set ctl = frmOrgChart.Outline1

    If ctl.ListIndex <> -1 Then
        ctl.RemoveItem (ctl.ListIndex)
        frmOrgChart.Outline1.AddItem ""
        ctl.ListIndex = 0
        ctl.Indent(ctl.ListIndex) = 0
        UpdateFields
    Else
        Beep
    End If
End Sub

Sub DemoteChild(iIndex As Integer, iIndent As Integer)
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function:   DeleteItem()
'-- Functions called:   DemoteChild() - recursive
'-- DemoteChild loops through the children of the item (items in the list can be children if
'-- their index follow in sequence after the index of The item, and they have an indentation
'-- larger than the indentation for The item.)
'--

    Dim ctl As Control

    '-- Short form...
    Set ctl = frmOrgChart.Outline1

    '-- Stop recursion at this point..
    If iIndex = ctl.ListCount Then
        Exit Sub
    ElseIf Not ctl.Indent(iIndex) > iIndent Then
        Exit Sub
    End If

    '-- Adjust indentation..
    ctl.Indent(iIndex) = ctl.Indent(iIndex) + 1
    SuperExpand iIndex
    '-- Call recursively..
    DemoteChild iIndex + 1, iIndent
End Sub

Sub DemoteItem()
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function:   mnuCommandItem()
'-- Functions called:   DemoteChild()
'-- DemoteItem adjust the indentation for the item itself, and then adjust the indentation
'-- for the item's child. However, if the outline control is empty or the item is the root,
'-- or the item doesn't have a preceding item with indent level equal or greater to it's own,
'-- it'll just beep.
'--

    Dim ctl As Control
    Dim iIndent As Integer

    'Short form...
    Set ctl = frmOrgChart.Outline1

    If ctl.ListIndex <> -1 Then
        '-- Cannot demote the item if it's a root, or if there's no item preceding it with
        '-- indent level equal or larger to it's own indent level.
        If ctl.Indent(ctl.ListIndex) > 0 Then
            If Not ctl.Indent(ctl.ListIndex - 1) < ctl.Indent(ctl.ListIndex) Then
                iIndent = ctl.Indent(ctl.ListIndex)
                ctl.Indent(ctl.ListIndex) = ctl.Indent(ctl.ListIndex) + 1
                '-- It still eludes me why they disappear, but for now solve
                '-- the problem by expanding..
                SuperExpand (ctl.ListIndex)
                DemoteChild ctl.ListIndex + 1, iIndent
            Else
                Beep
            End If
        Else
            Beep
        End If
    Else
        Beep
    End If
End Sub

Private Sub DrawOrgChart(rgParent() As Integer, rgLeft() As Integer, rgRight() As Integer, cLeaves As Integer, cLevels As Integer)
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function:   CreateOrgChart()
'-- Functions called:   GlueMe(), PosX(), PosY()
'-- DrawOrgChart sets up the environment in Visio (exits if it cannot create or get the
'-- existing Visio) and then drops instances of the master "Position" onto the page according
'-- to the number of items in the form's outline control. It assigns text to the instances, sets
'-- their fill color, and calls GlueMe in order to connect the different instances of "Position".
'--

    ReDim objArray(cMax) As Object
    Dim objPage As Visio.Page, objStencil As Visio.Document, objMasters As Visio.Masters
    Dim objMaster As Visio.Master, objParent As Object, objShapes As Visio.Shapes
    Dim iIndex As Integer, iIndent As Integer
    Dim X As Double, Y As Double

    'Get the active instance of Visio, or run one
    If vaoGetObject() <> visOK Then
        MsgBox "Cannot get an instance of Visio."
        End
    End If

    'Create a new document based on sample.vst
    'and get the stencil, master, and page objects
    g_appVisio.Documents.Add ("VB Solutions.vst")
    Set objStencil = g_appVisio.Documents.Item("VB Solutions.vss")
    Set objMasters = objStencil.Masters
    Set objMaster = objMasters.Item("Position")
    Set objPage = g_appVisio.ActivePage

    'Calculat the pin of each Position shape based on cLeaves and cLevels.
    For iIndex = 0 To frmOrgChart.Outline1.ListCount - 1
        X = PosX(cLeaves, rgRight(iIndex), rgLeft(iIndex))
        Y = PosY(cLevels, iIndex)
        Set objArray(iIndex) = objPage.Drop(objMaster, X, Y)
        objArray(iIndex).Text = (frmOrgChart.Outline1.List(iIndex))
        Set objShapes = objArray(iIndex).Shapes
    Next iIndex

    'Glue each child to its parent
    For iIndex = 0 To frmOrgChart.Outline1.ListCount - 1
        iIndent = rgParent(iIndex)
        If iIndent <> -1 Then
            objArray(iIndex).Cells("Controls.X1").GlueTo objArray(rgParent(iIndex)).Cells("Connections.X4")
        End If
    Next iIndex
End Sub

Function FindRoot(strTwoD As String) As String
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function:   ReadOrgChart()
'-- Functions called:
'-- FindRoot loops through all the shapes and decides which shape is the root in the
'-- organizational tree.
'--

    Dim iTab As Integer, iCr As Integer, iPos As Integer, iStart As Integer
    Dim CR As String, TB As String, strRoot As String

    CR = Chr$(13): TB = Chr$(9)
    iStart = 1

    strRoot = Mid$(strTwoD, iStart, 3)
    iTab = InStr(iStart, strTwoD, TB)
    iCr = InStr(iStart, strTwoD, CR)

    Do While (iTab < iCr)
        iStart = iCr + 1
        strRoot = Mid$(strTwoD, iStart, 3)
        iTab = InStr(iStart, strTwoD, TB)
        iCr = InStr(iStart, strTwoD, CR)
    Loop
    FindRoot = strRoot
End Function

Sub ImportStr(strTwoD As String, ByVal strTop As String, Indent As Integer)
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function:   ReadOrgChart()
'-- Functions called:   ImportStr() - recursive
'-- ImportStr loops through all the shapes in strTwoD and sketches the outline of the
'-- organizational chart in the form's outline control.
'--

    Dim i As Integer, iPos As Integer, iNo As Integer, iCr As Integer
    Dim strNewTop As String, temp As String
    Dim CR As String, TB As String

    CR = Chr$(13): TB = Chr$(9)
    strNewTop = strTop
    iPos = InStr(1, strTwoD, strNewTop)

    If iPos <> 1 Then
        While Mid$(strTwoD, iPos - 1, 1) = "#"
            iPos = InStr(iPos + 1, strTwoD, strNewTop)
        Wend
    End If

    iPos = iPos + 3
    iCr = InStr(iPos, strTwoD, CR)
    iNo = InStr(iPos, strTwoD, "#")

    If iNo <> 0 And iNo < iCr Then
        temp = Mid$(strTwoD, iPos, iNo - iPos)
    Else
        temp = Mid$(strTwoD, iPos, iCr - iPos)
    End If

    frmOrgChart.Outline1.AddItem temp
    frmOrgChart.Outline1.Indent(frmOrgChart.Outline1.ListCount - 1) = Indent

    Do While iNo <> 0 And iNo < iCr
        temp = Mid$(strTwoD, iNo + 1, 3)
        ImportStr strTwoD, temp, Indent + 1
        iNo = InStr(iNo + 1, strTwoD, "#")
    Loop
End Sub

Sub MergeStr(strOneDShapes As String, strTwoDShapes As String)
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function:   ReadOrgChart()
'-- Functions called:
'-- MergeStr merges the two strings, strOneD and strTwoD, and leave the result in strTwoD.
'-- (If the user has used the 2D shape's control point to connect to the other shape,
'-- no merging is needed.)
'--
    Dim iConnections As Integer, i As Integer, iCr As Integer, iPos As Integer
    Dim iStart1 As Integer, iStart2 As Integer
    Dim strFrom As String, strTo As String
    Dim CR As String, TB As String

    CR = Chr$(13): TB = Chr$(9)
    iStart1 = 2: iStart2 = 1
    iConnections = Len(strOneDShapes) / 9

    For i = 1 To iConnections                   'Parent/Child connections
        '-- String of OneD shapes...
        strFrom = Mid$(strOneDShapes, iStart1, 3)
        iStart1 = iStart1 + 4
        strTo = Mid$(strOneDShapes, iStart1, 3)
        '-- String of TwoD shapes...
        iPos = InStr(1, strTwoDShapes, strFrom)
        iStart2 = iPos
        iCr = InStr(iStart2, strTwoDShapes, CR)
        'If we're at the end of the string, prepare for appending....
        If iCr = 0 Then
            iCr = Len(strTwoDShapes) + 1
        End If
        strFrom = Right$(strTwoDShapes, Len(strTwoDShapes) - (iCr - 1))
        strTwoDShapes = Left$(strTwoDShapes, iCr - 1) & TB & strTo & strFrom
        iStart1 = iStart1 + 5
    Next i
End Sub

Sub movedown()
'/************* Needs to be worked on *********/
Dim dumnum As Variant
Dim intnum As Integer
Dim intabv As Integer
Dim intblw As Integer
Dim strT As String
Dim ctl As Control

    '-- short form...
    Set ctl = frmOrgChart.Outline1

    ctl.Refresh
    If ctl.ListIndex = 0 Then
        Beep
        Exit Sub
    End If
    intnum = ctl.ListIndex + 1
    If ctl.ListCount - intnum > 0 Then
        dumnum = Abs(ctl.Indent(intnum) - ctl.Indent(ctl.ListIndex))
        If dumnum > 1 Then
            Beep
            Exit Sub
        Else
            intblw = ctl.Indent(intnum)
        End If
    Else
        Beep
        Exit Sub
    End If
    intnum = intnum - 2
    If intnum > -1 Then
        intabv = ctl.Indent(intnum)
    Else
        intabv = intblw
    End If
    If (ctl.ListIndex + 2) < ctl.ListCount Then
        intnum = Abs(ctl.Indent(ctl.ListIndex) - ctl.Indent(ctl.ListIndex + 2))
    Else
        intnum = 1
    End If
    dumnum = Abs(intabv - intblw)
    If dumnum < 2 And intnum < 2 Then
        strT = ctl.List(ctl.ListIndex)
        ctl.List(ctl.ListIndex) = ctl.List(ctl.ListIndex + 1)
        ctl.List(ctl.ListIndex + 1) = strT
        ctl.Indent(ctl.ListIndex + 1) = ctl.Indent(ctl.ListIndex)
        ctl.Indent(ctl.ListIndex) = intblw
        ctl.ListIndex = ctl.ListIndex + 1
        SuperExpand (ctl.ListIndex)
        TopExpand (ctl.ListIndex)
    Else
        Beep
    End If
End Sub

Sub moveup()
'/******** Needs to be worked on ********/
    Dim Thing As String
    Dim ctl As Control

    '-- Short form...
    Set ctl = frmOrgChart.Outline1

    Thing = ctl.List(ctl.ListIndex)
    If ctl.ListIndex - 1 >= 0 Then
        ctl.ListIndex = ctl.ListIndex - 1
        movedown
        If ctl.ListIndex + 1 >= ctl.ListCount Then
            ctl.ListIndex = ctl.ListIndex - 1
            Exit Sub
        End If
        If ctl.List(ctl.ListIndex + 1) <> Thing Then
            ctl.ListIndex = ctl.ListIndex - 1
        Else
            ctl.ListIndex = ctl.ListIndex + 1
        End If
    Else
        Beep
    End If
End Sub

Private Function PosX(cLeaves As Integer, aright As Integer, aleft As Integer) As Double
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling funcions:    DrawOrgChart()
'-- Functions called:
'-- PosX calculates the x position for where to drop the instance of the master based on how
'-- many children the object has.
'--
    Dim MulX As Double, OffX As Double

    MulX = 1.25
    OffX = 5# - (1# * cLeaves) / 2
    PosX = OffX + MulX * (aright + aleft) / 2#
End Function

Private Function PosY(cLevels As Integer, Index As Integer) As Double
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling funcions:    DrawOrgChart()
'-- Functions called:
'-- PosY calculates the y position for where to drop the instance of the master based on how
'-- many levels the tree has.
'--

    Dim OffY As Double
    Dim separation As Double

    separation = 1
    OffY = 4.5 + (cLevels * separation) / 2
    PosY = OffY - (frmOrgChart.Outline1.Indent(Index)) * separation
End Function

Sub PromoteChild(iIndex As Integer, iIndent As Integer)
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function:   DeleteItem()
'-- Functions called:   PromoteChild() - recursive
'-- PromoteChild loops through the children of The item (items in the list can be children if
'-- their index follow in sequence after the index of The item, and they have an indentation
'-- larger than the indentation for The item.)
'--

    Dim ctl As Control

    '-- Short form...
    Set ctl = frmOrgChart.Outline1

    '-- Stop recursion at this point..
    '-- Looks pretty stupid to use an if/end for this, but basic's OR checks doesn't skip
    '-- the second case if the first evaluated to true, which in our case would result in
    '-- a control error message.
    If iIndex = ctl.ListCount Then
        Exit Sub
    ElseIf Not ctl.Indent(iIndex) > iIndent Then
        Exit Sub
    End If

    PromoteChild iIndex + 1, iIndent
    '-- Adjust indentation..
    ctl.Indent(iIndex) = ctl.Indent(iIndex) - 1
End Sub

Sub PromoteItem()
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function :  frmOrgChart.mnuCommandItem()
'-- Functions called :  PromoteChild()
'-- PromoteItem adjust the indentation of the item's child, and then adjust the indentation
'-- for the item itself. However, if the outline control is empty or the item's indentation
'-- level is smaller than 2, it'll just beep.
'--

    Dim ctl As Control

    '-- Short form...
    Set ctl = frmOrgChart.Outline1

    If ctl.ListIndex <> -1 Then
        '-- Cannot promote an item with indent 0 or 1 since we want one root only..
        If ctl.Indent(ctl.ListIndex) > 1 Then
            PromoteChild ctl.ListIndex + 1, (ctl.Indent(ctl.ListIndex))
            ctl.Indent(ctl.ListIndex) = ctl.Indent(ctl.ListIndex) - 1
            UpdateFields
        Else
            Beep
        End If
    Else
        Beep
    End If
End Sub

Sub ReadOrgChart()
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function:   frmOrgChart.mnuChartItem_Click()
'-- Functions called:   BuildOneD(), BuildTwoD(), MergeStr(), ConvertStr(), ImportStr(),
'--                     FindRoot()
'-- ReadOrgChart creates or get the excisting Visio, reads the number of shapes that are on the
'-- active document's page, seperates these shapes into one dimensional and two dimensional,
'-- merge the two sets in order to build the tree in the frmOrgChart's outline control
'--
    Dim objDocument As Visio.Document
    Dim cShapesCount As Integer, i As Integer
    Dim strOneD As String, strTwoD As String, strRoot As String

    On Error GoTo LBLReadOrgChartError

    If vaoGetObject() <> visOK Then
        MsgBox "Cannot achieve an instance of Visio!"
        End
    End If

    '-- Make sure that the drawing window is the active window because if we delete
    '-- a drawing window, the stencil window becomes active
    For i = 1 To g_appVisio.Windows.Count
        If g_appVisio.Windows(i).Type = visDrawing Then
            g_appVisio.Windows(i).Activate
        End If
    Next i

    Screen.MousePointer = CURSOR_HOURGLASS
    Set objDocument = g_appVisio.ActiveDocument
    cShapesCount = objDocument.Pages(1).Shapes.Count
    strOneD = BuildOneD(cShapesCount, objDocument)
    strTwoD = BuildTwoD(cShapesCount, objDocument)
    If strOneD <> "" Then
        MergeStr strOneD, strTwoD
    End If
    strRoot = FindRoot(strTwoD)
    ConvertStr strTwoD, cShapesCount

    frmOrgChart.Text1.Text = " "
    frmOrgChart.Outline1.Clear

    '-- Build the org chart tree in the outline control
    ImportStr strTwoD, strRoot, 0
    '-- Expand the tree
    If frmOrgChart.mnuChartItem(ShowItems).Checked = True Then
        For i = 1 To frmOrgChart.Outline1.ListCount - 1
            TopExpand (i)
        Next
    End If
    frmOrgChart.Outline1.ListIndex = frmOrgChart.Outline1.ListCount - 1
    UpdateFields
    Screen.MousePointer = CURSOR_NORMAL

    Exit Sub
LBLReadOrgChartError:
    If objDocument Is Nothing Then
        MsgBox ("There is no open document in Visio")
    End If
    MsgBox Error$(Err)
    Exit Sub
End Sub

Sub SuperExpand(Index As Integer)
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling functions:  frmOrgChart.mnuCommandItem(), text1.keydown(), text1.keyup(),
'--                     general.movedown , DemoteChilde(), PromoteAll()
'-- Functions called :  SuperExpand() - recursiv
'-- SuperExpand traverses the path backwards until it finds a parent which is visible, makes
'-- the children for this parent visible using the expand property, and calls itself recursively
'-- to see if the item (index) is now visible.
'--

    Dim cCounter As Integer

    If Not (frmOrgChart.Outline1.IsItemVisible(Index)) Then
        cCounter = 1
        Do While Not (frmOrgChart.Outline1.IsItemVisible(Index - cCounter))
            cCounter = cCounter + 1
        Loop
    '***********************************
    '-- This line sometimes has a side effect - it adds an item to the outline orgchart tree
    '-- when user hits the TAB or SHIFT/TAB. Should be corrected.
         frmOrgChart.Outline1.Expand(Index - cCounter) = True
        SuperExpand (Index)
    End If
End Sub

Function TopEngine(Index As Integer) As Integer
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function:   TopExpand()
'-- Functions called:   TopEngine() - recursive
'--

    Dim cCounter As Integer

    cCounter = 1
    If frmOrgChart.Outline1.HasSubItems(Index) Then
        frmOrgChart.Outline1.Expand(Index) = True
            Do While (frmOrgChart.Outline1.Indent(Index + cCounter) = frmOrgChart.Outline1.Indent(Index) + 1)
                cCounter = cCounter + TopEngine(Index + cCounter)
                If Index + cCounter >= frmOrgChart.Outline1.ListCount - 1 Then Exit Do
            Loop
    End If
    TopEngine = cCounter
End Function

Sub TopExpand(Index As Integer)
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling functions :
'-- Functions called  : TopEngine()
'-- TopExpands soul purpose is to call TopEngine() and to recieve whatever value it returns (a
'-- value which is not needed). TopEngine needs to be a function because it calls itself, and
'-- in VB you cannot ignore return values like in C. Since TopEngine needs to be called several
'-- times, TopExpand functions as a filter for the useless return value and saves us variable
'-- declarations everywhere else.
'--
    Dim iCrap As Integer
    iCrap = TopEngine(Index)
End Sub

Sub UpdateFields()
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling functions:  Form_Load(), frmOrgChart.mnuCommandItem_Click(), outline1.Click(),
'--                     Text1.KeyDown(), Text1.KeyUp()
'-- Functions called :
'-- UpdateFields checks to see if there's anything in the form's outline control, and if so,
'-- updates the text control according to the outline controls text, and enables the menu item
'-- "CreateOrgChart". If the outline is blank, the text box is blanked, and the menu item is
'-- disabled.
'--

    If Not (frmOrgChart.Outline1.ListIndex = 0 And frmOrgChart.Outline1.List(0) = "") Then
        frmOrgChart.Text1.Text = frmOrgChart.Outline1.Text
        frmOrgChart.mnuChartItem(CreateChart).Enabled = True
    Else
        frmOrgChart.Text1.Text = ""
        frmOrgChart.mnuChartItem(CreateChart).Enabled = False
    End If
End Sub