PC World Komputer 1998 January/Pcwk0198.iso/Wtestowe/Microgfx/FCTRIALL/ABC.Z/ORGCHART.FRM

Text File | 1996-12-16 | 26KB | 755 lines

VERSION 4.00
Begin VB.Form OrgChartDlg
   Appearance      =   0  'Flat
   BackColor       =   &H00C0C0C0&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Organization Chart DEMO"
   ClientHeight    =   1815
   ClientLeft      =   465
   ClientTop       =   1755
   ClientWidth     =   5535
   FillColor       =   &H00C0C0C0&
   FillStyle       =   0  'Solid
   BeginProperty Font
      name            =   "MS Sans Serif"
      charset         =   0
      weight          =   700
      size            =   8.25
      underline       =   0   'False
      italic          =   0   'False
      strikethrough   =   0   'False
   EndProperty
   ForeColor       =   &H80000008&
   Height          =   2220
   Icon            =   "ORGCHART.frx":0000
   Left            =   405
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   1815
   ScaleWidth      =   5535
   Top             =   1410
   Width           =   5655
   Begin VB.CommandButton OptionsBtn
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      Caption         =   "Options..."
      Height          =   375
      Left            =   4080
      TabIndex        =   5
      Top             =   720
      Width           =   1335
   End
   Begin VB.CommandButton CancelBtn
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      Caption         =   "Cancel"
      Height          =   375
      Left            =   2820
      TabIndex        =   4
      Top             =   1320
      Width           =   1335
   End
   Begin VB.CommandButton BrowseBtn
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      Caption         =   "Browse..."
      Height          =   375
      Left            =   4080
      TabIndex        =   3
      Top             =   240
      Width           =   1335
   End
   Begin VB.CommandButton OKBtn
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      Caption         =   "OK"
      Default         =   -1  'True
      Enabled         =   0   'False
      Height          =   375
      Left            =   1320
      TabIndex        =   2
      Top             =   1320
      Width           =   1335
   End
   Begin VB.TextBox OrgChartTextFileEdit
      Appearance      =   0  'Flat
      BackColor       =   &H00FFFFFF&
      BeginProperty Font
         name            =   "MS Sans Serif"
         charset         =   0
         weight          =   400
         size            =   8.25
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   285
      Left            =   120
      TabIndex        =   1
      Top             =   600
      Width           =   3675
   End
   Begin MSComDlg.CommonDialog OrgChartBrowse
      Left            =   360
      Top             =   1320
      _Version        =   65536
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
   End
   Begin AbcflowLib.ABC ABC1
      Height          =   375
      Left            =   4560
      TabIndex        =   6
      Top             =   1320
      Width           =   495
      _version        =   65536
      _extentx        =   873
      _extenty        =   661
      _stockprops     =   1
   End
   Begin VB.Line Line6
      BorderColor     =   &H00808080&
      X1              =   0
      X2              =   5520
      Y1              =   1800
      Y2              =   1800
   End
   Begin VB.Line Line5
      BorderColor     =   &H00808080&
      X1              =   5520
      X2              =   5520
      Y1              =   1800
      Y2              =   0
   End
   Begin VB.Line Line4
      BorderColor     =   &H00FFFFFF&
      X1              =   5520
      X2              =   0
      Y1              =   0
      Y2              =   0
   End
   Begin VB.Line Line3
      BorderColor     =   &H00FFFFFF&
      X1              =   0
      X2              =   0
      Y1              =   1800
      Y2              =   0
   End
   Begin VB.Line Line2
      BorderColor     =   &H00FFFFFF&
      X1              =   0
      X2              =   5520
      Y1              =   1210
      Y2              =   1210
   End
   Begin VB.Line Line1
      BorderColor     =   &H00808080&
      X1              =   0
      X2              =   5520
      Y1              =   1200
      Y2              =   1200
   End
   Begin VB.Label Label1
      Appearance      =   0  'Flat
      BackColor       =   &H00C0C0C0&
      Caption         =   "ASCII Text File:"
      ForeColor       =   &H80000008&
      Height          =   255
      Left            =   120
      TabIndex        =   0
      Top             =   360
      Width           =   2055
   End
End
Attribute VB_Name = "OrgChartDlg"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Dim ABC As Object
Dim FormatIter As Integer
Dim LoopIter As Integer
Dim TotalFormatIter As Integer
Dim req_objs As Integer

Private Sub ABC1_AppQuitNOTIFY()
    End
End Sub

Private Sub BrowseBtn_Click()
    OrgChartBrowse.Action = 1
   ' OrgChartBrowse.Filename = OrgChartTextFileEdit.Text
    OrgChartTextFileEdit.Text = LCase(OrgChartBrowse.Filename)
    OrgChartBrowse.Filename = "*.txt"
End Sub

Private Function CalcPercent() As Integer
    CalcPercent = 100 * ((LoopIter / req_objs) / TotalFormatIter + (FormatIter - 1) / TotalFormatIter) + 1
    If CalcPerent > 100 Then CalcPercent = 100
    If CalcPerent < 0 Then CalcPercent = 0

    LoopIter = LoopIter + 1
End Function

Private Sub CancelBtn_Click()
    Unload OrgChartDlg
End Sub

Private Sub Command2_Click()
    OrgChartBrowse.Action = 1
End Sub

Private Function DoCreateOrgChart(ByVal Filename As String) As Integer
    Dim OrgItem As String

    Dim Chart As Object
    Dim cur_pos As Integer
    Dim len_str As Integer

    Rem Make a new chart
    Set Chart = ABC.New

    Rem Set the right shape palette
    Chart.CurrentShapePalette = "Standard"
    Chart.CurrentShape = "Process"
    ABC.ShapePaletteVisible = False

    Rem Set the Chart's internal type
    Chart.Type = "PROCESS"

    Rem Turn off master items
    Chart.MasterItems.Hideall

    Chart.DrawDirection = 2
    Chart.DrawPositionX = 4
    Chart.DrawPositionY = 1
    Chart.DrawSpacingY = 0.25
    Chart.CurrentLineRouting = 3

    If OrgChartOptionsDlg.TopToBottomRBtn.Value = True Or OrgChartOptionsDlg.BottomToTopRBtn = True Then
        vertical = True
    Else
        vertical = False
    End If

    If OrgChartOptionsDlg.BottomToTopRBtn.Value = True Or OrgChartOptionsDlg.RightToLeftRBtn = True Then
        inverted = True
    Else
        inverted = False
    End If

    If vertical Then
        Chart.PageLayout.Orientation = 1
    Else
        Chart.PageLayout.Orientation = 0
    End If

    Chart.NoRepaint = True


    len_file = FileLen(Filename)
    If len_file < 32767 And len_file > 0 Then

        Dim EntireFile As String
        Dim test_ascCode As Integer
        Dim rank As Integer
        Dim index As Integer
        Dim cur_obj_count As Integer
        Dim num_levels As Integer

        Open Filename For Binary Access Read As #1
        EntireFile = String$(len_file, " ")
        Get #1, , EntireFile
        Close

        Rem Set up the progess bar
        ABC.PercentGauge "Organization Chart DEMO", "PASS 1 of 2: Reading & parsing file..."
        DrawnCount = 0

        req_objs = GetNumLines(EntireFile) + 1

        ReDim ShapeList(req_objs) As Object
        ReDim ShapeRefStack(req_objs) As Integer
        ReDim RelationMap(req_objs, 3) As Integer
        Const first_child = 1, next_sibling = 2, parent = 3

        cur_pos = 1
        index = 2
        cur_obj_count = 1
        ShapeRefStack(1) = 1

        Do While cur_pos < len_file + 1
            test_ascCode = Asc(Mid$(EntireFile, cur_pos, 1))
            rank = 2
            While test_ascCode <> 13 And test_ascCode <> 10 And cur_pos < len_file + 1
                If test_ascCode = 9 Then
                    rank = rank + 1
                Else
                    OrgItem = OrgItem + Chr$(test_ascCode)
                End If
                cur_pos = cur_pos + 1
                test_ascCode = Asc(Mid$(EntireFile, cur_pos, 1))
            Wend
            cur_pos = cur_pos + 1

            OrgItem = FormatOrgString(OrgItem)

            If rank > num_levels Then
                num_levels = rank
            End If

            If Len(OrgItem) > 0 Then
                If rank > index Then
                    index = index + 1
                ElseIf rank < index Then
                    index = rank
                End If

                Chart.DrawPositionX = 1 + (index)
                Chart.DrawPositionY = 2

                cur_obj_count = cur_obj_count + 1

                Set ShapeList(cur_obj_count) = Chart.DrawShape("Process")
                ShapeList(cur_obj_count).Text = OrgItem

                Rem update status bar
                DrawnCount = DrawnCount + 1
                ABC.PercentGaugeValue = 100 * DrawnCount / (req_objs - 1)


                'Give all the shapes some attributes here
                ShapeList(cur_obj_count).Shape.FillColor = ABC.YELLOW
                ShapeList(cur_obj_count).Shape.BorderColor = ABC.BLUE
                ShapeList(cur_obj_count).Shape.ShadowStyle = 1
                ShapeList(cur_obj_count).Shape.NumberShown = False
                ShapeList(cur_obj_count).Shape.BorderWidth = 3
                ShapeList(cur_obj_count).Shape.FitShapeToText



                ShapeRefStack(index) = cur_obj_count

                RelationMap(cur_obj_count, parent) = ShapeRefStack(index - 1)
                RelationMap(cur_obj_count, next_sibling) = RelationMap(RelationMap(cur_obj_count, parent), first_child)
                RelationMap(RelationMap(cur_obj_count, parent), first_child) = cur_obj_count
                RelationMap(cur_obj_count, first_child) = 0

                OrgItem = ""
            End If
            If ABC.PercentGaugeCancelled Then Exit Do
        Loop

        If ABC.PercentGaugeCancelled Then GoTo DoCreateAbort

        ABC.PercentGauge "Organization Chart DEMO", "PASS 2 of 2: Formatting chart..."

        Rem There are currently five iterations of formatting
        TotalFormatIter = 5
        FormatIter = 0

        'We need to go through the list and make sure
        'the sizes work according to the Options Dlg
        Const size_cx = 1, size_cy = 2
        Dim finished As Integer
        ReDim obj_size_level(req_objs, 2) As Double
        Dim counter As Integer

        finished = False
        cur_obj_count = 1
        index = 1
        Call NewGaugeLoop

        'Here we traverse the tree gathering the maximum size box in each level
        While Not ABC.PercentGaugeCancelled And Not finished
            Rem update status bar
            ABC.PercentGaugeValue = CalcPercent()

            If cur_obj_count <> 1 Then
                If ShapeList(cur_obj_count).Height > obj_size_level(index, size_cy) Then
                    obj_size_level(index, size_cy) = ShapeList(cur_obj_count).Height
                End If

                If ShapeList(cur_obj_count).Width > obj_size_level(index, size_cx) Then
                    obj_size_level(index, size_cx) = ShapeList(cur_obj_count).Width
                End If
            End If
            If RelationMap(cur_obj_count, first_child) = 0 Then
                ShapeRefStack(index) = cur_obj_count

                cur_obj_count = RelationMap(cur_obj_count, next_sibling)

                While cur_obj_count = 0 And index <> 1
                    index = index - 1
                    If index > 1 Then
                        cur_obj_count = ShapeRefStack(index)
                        If cur_obj_count Then
                            cur_obj_count = RelationMap(cur_obj_count, next_sibling)
                        End If
                    End If
                Wend
            Else
                ShapeRefStack(index) = cur_obj_count
                index = index + 1
                cur_obj_count = RelationMap(cur_obj_count, first_child)
            End If
            If index = 1 Then
                finished = True
            End If
        Wend

        'Now we have to adjust if the manager's size increases.
        If OrgChartOptionsDlg.IncreaseMgrSize.Value = True Then
            For counter = num_levels - 1 To 2 Step -1
                If obj_size_level(counter, size_cx) < obj_size_level(counter + 1, size_cx) Then
                    obj_size_level(counter, size_cx) = obj_size_level(counter + 1, size_cx)
                End If
                If obj_size_level(counter, size_cy) < obj_size_level(counter + 1, size_cy) Then
                    obj_size_level(counter, size_cy) = obj_size_level(counter + 1, size_cy)
                End If
            Next
        End If

        'Reinitialize the loop vars
        finished = False
        cur_obj_count = 1
        index = 1
        Call NewGaugeLoop

        'Here we traverse the tree gathering the maximum size box in each level
        While Not ABC.PercentGaugeCancelled And Not finished
            Rem update status bar
            ABC.PercentGaugeValue = CalcPercent()

            If cur_obj_count <> 1 Then
                If OrgChartOptionsDlg.EqualWithinLevels.Value = True Then
                    ShapeList(cur_obj_count).Width = obj_size_level(index, size_cx)
                    ShapeList(cur_obj_count).Height = obj_size_level(index, size_cy)
                Else    'The object has to be at least as big as the biggest on the next level
                    If OrgChartOptionsDlg.IncreaseMgrSize.Value = True Then
                        If index < num_levels And index > 1 Then
                            If ShapeList(cur_obj_count).Width < obj_size_level(index + 1, size_cx) Then
                                ShapeList(cur_obj_count).Width = obj_size_level(index + 1, size_cx)
                            End If
                            If ShapeList(cur_obj_count).Height < obj_size_level(index + 1, size_cy) Then
                                ShapeList(cur_obj_count).Height = obj_size_level(index + 1, size_cy)
                            End If
                        End If
                    End If
                End If
            End If
            If RelationMap(cur_obj_count, first_child) = 0 Then
                ShapeRefStack(index) = cur_obj_count

                cur_obj_count = RelationMap(cur_obj_count, next_sibling)

                While cur_obj_count = 0 And index <> 1
                    index = index - 1
                    If index > 1 Then
                        cur_obj_count = ShapeRefStack(index)
                        If cur_obj_count Then
                            cur_obj_count = RelationMap(cur_obj_count, next_sibling)
                        End If
                    End If
                Wend
            Else
                ShapeRefStack(index) = cur_obj_count
                index = index + 1
                cur_obj_count = RelationMap(cur_obj_count, first_child)
            End If
            If index = 1 Then
                finished = True
            End If
        Wend


        'Format the chart *here*
        'start at the top (the "God" object)

        ReDim size_branch(req_objs) As Double
        ReDim size_level(req_objs) As Double
        Dim box_spacing_peers As Double
        Dim box_spacing_levels As Double
       ' Dim vertical As Integer
       ' Dim inverted As Integer


        box_spacing_peers = Val(OrgChartOptionsDlg.BoxSpacing.Text)
        box_spacing_levels = box_spacing_peers * 2

        finished = False
        cur_obj_count = 1
        index = 1
        Call NewGaugeLoop

        'We're just calculating the sizes that these shapes need so far.
        While Not ABC.PercentGaugeCancelled And Not finished
            Rem update status bar
            ABC.PercentGaugeValue = CalcPercent()

            If cur_obj_count <> 1 Then
                If vertical = True Then
                    If ShapeList(cur_obj_count).Height > size_level(index) Then
                        size_level(index) = ShapeList(cur_obj_count).Height
                    End If
                Else
                    If ShapeList(cur_obj_count).Width > size_level(index) Then
                        size_level(index) = ShapeList(cur_obj_count).Width
                    End If
                End If
            End If
            If RelationMap(cur_obj_count, first_child) = 0 Then
                ShapeRefStack(index) = cur_obj_count

                For counter = 1 To index
                    If vertical = True Then
                        size_branch(ShapeRefStack(counter)) = size_branch(ShapeRefStack(counter)) + ShapeList(cur_obj_count).Width + box_spacing_peers
                    Else
                        size_branch(ShapeRefStack(counter)) = size_branch(ShapeRefStack(counter)) + ShapeList(cur_obj_count).Height + box_spacing_peers
                    End If
                Next

                cur_obj_count = RelationMap(cur_obj_count, next_sibling)

                While cur_obj_count = 0 And index <> 1
                    index = index - 1
                    If index > 1 Then
                        cur_obj_count = ShapeRefStack(index)
                        If cur_obj_count Then
                            cur_obj_count = RelationMap(cur_obj_count, next_sibling)
                        End If
                    End If
                Wend
            Else
                ShapeRefStack(index) = cur_obj_count
                index = index + 1
                cur_obj_count = RelationMap(cur_obj_count, first_child)
            End If
            If index = 1 Then
                finished = True
            End If
        Wend


        Dim posX As Double
        Dim posY As Double
        Dim newline As Object


        'I'll have to admit - this is a little hard to follow - but it's BASIC you know, Visual or not
        'Can't do too much about the recursion stuff in BASIC

        posX = box_spacing_peers + size_branch(1)
        posY = 0
        mirrorX = box_spacing_peers + size_branch(1)
        mirrorY = box_spacing_levels
        cur_obj_count = 1
        index = 1
        finished = False

        For counter = 2 To num_levels
            mirrorY = mirrorY + size_level(counter) + box_spacing_levels
        Next

        Call NewGaugeLoop

        'This is recursion in disguise....
        'Don't be confused-> X and Y are reversed if this is not vertical
        While Not ABC.PercentGaugeCancelled And Not finished
            Rem update status bar
            ABC.PercentGaugeValue = CalcPercent()

            If cur_obj_count <> 1 Then
                If vertical Then
                    ShapeList(cur_obj_count).CenterX = posX - (size_branch(cur_obj_count) / 2)
                Else
                    ShapeList(cur_obj_count).CenterY = posX - (size_branch(cur_obj_count) / 2)
                End If
                posY = box_spacing_levels
                For counter = 2 To index - 1
                    posY = posY + size_level(counter) + box_spacing_levels
                Next
                If vertical Then
                    If inverted Then
                        ShapeList(cur_obj_count).Bottom = mirrorY - posY
                    Else
                        ShapeList(cur_obj_count).Top = posY
                    End If
                Else
                    If inverted Then
                        ShapeList(cur_obj_count).Right = mirrorY - posY
                    Else
                        ShapeList(cur_obj_count).Left = posY
                    End If
                End If
            End If

            If RelationMap(cur_obj_count, first_child) = 0 Then
                posX = posX - size_branch(cur_obj_count)

                cur_obj_count = RelationMap(cur_obj_count, next_sibling)

                While cur_obj_count = 0 And index <> 1
                    index = index - 1
                    If index > 1 Then
                        cur_obj_count = ShapeRefStack(index)
                        If cur_obj_count Then
                            cur_obj_count = RelationMap(cur_obj_count, next_sibling)
                        End If
                    End If
                Wend
            Else
                ShapeRefStack(index) = cur_obj_count
                index = index + 1
                cur_obj_count = RelationMap(cur_obj_count, first_child)

            End If

            If index = 1 Then
                finished = True
            End If
        Wend

        Call NewGaugeLoop
        Junk = CalcPercent()  ' since we're skipping an object in this loop

        For counter = 2 To req_objs
            If ABC.PercentGaugeCancelled Then Exit For
            ABC.PercentGaugeValue = CalcPercent()

            If RelationMap(counter, parent) > 1 Then
                If vertical Then
                    If inverted Then
                        Set newline = Chart.DrawLine(ShapeList(RelationMap(counter, parent)), ShapeList(counter), 0, 2)
                    Else
                        Set newline = Chart.DrawLine(ShapeList(RelationMap(counter, parent)), ShapeList(counter), 2, 0)
                    End If
                Else
                    If inverted Then
                        Set newline = Chart.DrawLine(ShapeList(RelationMap(counter, parent)), ShapeList(counter), 3, 1)
                    Else
                        Set newline = Chart.DrawLine(ShapeList(RelationMap(counter, parent)), ShapeList(counter), 1, 3)
                    End If
                End If

                newline.Line_.StemWidth = 3
                newline.Line_.DestArrowStyle = 0
                newline.Line_.SourceArrowStyle = 0
                newline.Line_.Color = ABC.BLUE
            End If
        Next

        DoCreateOrgChart = 1
    Else
        DoCreateOrgChart = 0
    End If

DoCreateAbort:

    Chart.View = 2
    Chart.NoRepaint = False
    Chart.Repaint

    ABC.HidePercentGauge

End Function

Private Sub Form_Load()
    Set ABC = CreateObject("ABCFlow.application")
    ABC.Visible = True
    OrgChartTextFileEdit = LCase(App.Path + "\ORGCHRT1.TXT")
    Load OrgChartOptionsDlg
    ABC.RegisterEvent ABC1, APPNAME, "AppQuitNOTIFY"
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Unload OrgChartOptionsDlg
End Sub

Private Function FormatOrgString(ByVal OrgString As String) As String
    Dim index As Integer
    Dim len_str As Integer
    Dim test_ascCode As Integer
    Dim in_quotes As Integer
    Dim FormattedStr As String

    index = 1
    in_quotes = False
    len_str = Len(OrgString)
    FormattedStr = ""

    While index < (len_str + 1)
        test_ascCode = Asc(Mid$(OrgString, index))
        If test_ascCode = 34 Then
            in_quotes = Not in_quotes
        ElseIf in_quotes Then
            FormattedStr = FormattedStr + Chr$(test_ascCode)
        ElseIf test_ascCode = 44 Then: Rem comma
            FormattedStr = FormattedStr + Chr$(13)
        End If

        index = index + 1

    Wend
    FormatOrgString = FormattedStr

End Function

Private Function GetNumLines(test_str As String) As Integer
    Dim len_str As Integer
    Dim index As Integer
    Dim in_line_feed As Integer
    Dim test_ascCode As Integer
    Dim total_lines As Integer

    in_line_feed = True
    index = 1
    len_str = Len(test_str)
    total_lines = 0

    While index < len_str + 1
        test_ascCode = Asc(Mid$(test_str, index))
        If test_ascCode = 13 Or test_ascCode = 10 Then
            If Not in_line_feed Then
                total_lines = total_lines + 1
                in_line_feed = True
            End If
        Else
            in_line_feed = False
        End If
        index = index + 1
    Wend
    GetNumLines = total_lines

End Function

Private Sub NewGaugeLoop()
    LoopIter = 0
    FormatIter = FormatIter + 1
End Sub

Private Sub OKBtn_Click()
    OrgChartDlg.WindowState = 1 ' iconize form
    OrgChartDlg.Refresh
    success = DoCreateOrgChart(OrgChartTextFileEdit.Text)
End Sub

Private Sub OptionsBtn_Click()
    OrgChartDlg.Enabled = False
    OrgChartOptionsDlg.Show
End Sub

Private Sub OrgChartTextFileEdit_Change()
    Call ValidateFilename
End Sub

Private Sub ValidateFilename()
   On Error Resume Next
   Attr = GetAttr(OrgChartTextFileEdit)
   If Err Then
        OKBtn.Enabled = False
   Else
        OKBtn.Enabled = True
   End If
End Sub