Chip 2004 April/CMCD0404.ISO/Software/Demo/conceptdraw/data1.cab/Libraries__Project_Management/Project_Management/GanttChart.cdb

Text File | 2004-02-13 | 5.9 KB | 171 lines

Dim TasksTitle As Shape
' ---------------------------------------------------------------------------
Function IsStarted(this As Shape) As Boolean
    IsStarted = True
End Function
' ---------------------------------------------------------------------------
Function LineInRect(x1 As Long, y1 As Long, x2 As Long, y2 As Long, rx1 As Long, ry1 As Long, rx2 As Long, ry2 As Long) As Boolean
    LineInRect = False
    If (x1>=rx1 AND x1<=rx2 AND y1>=ry1 AND y1<=ry2) OR (x2>=rx1 AND x2<=rx2 AND y2>=ry1 AND y2<=ry2) Then
        LineInRect = True
    End If
End Function
' ---------------------------------------------------------------------------
Function FindShapeByName(inPage As Page, inName As String) As Shape
    FindShapeByName = Null
    For I=1 To inPage.ShapesNum()
        If inPage.Shape(I).Name = inName Then
            Set FindShapeByName = inPage.Shape(I)
            Exit Function
        End If
    Next
End Function
' ---------------------------------------------------------------------------
Function FindShapeByNameInGroup(this As Shape, inName As String) As Shape
    FindShapeByNameInGroup = Null
    For I=1 To this.ShapesNum()
        If this.Shape(I).Name = inName Then
            Set FindShapeByNameInGroup = this.Shape(I)
            Exit Function
        End If
    Next
End Function
' ---------------------------------------------------------------------------
Function FindBottomTask(inPage As Page, inTaskID As Long) As Shape
    FindBottomTask = Null
    Dim MaxY As Double

    MaxY = 0
    For I=1 To inPage.ShapesNum()
        If inPage.Shape(I).Name = "TaskBar" AND inTaskID <> inPage.Shape(I).ID Then
            If inPage.Shape(I).GPinY + inPage.Shape(I).Height > MaxY Then
                Set FindBottomTask = inPage.Shape(I)
                MaxY = inPage.Shape(I).GPinY + inPage.Shape(I).Height
            End If
        End If
    Next
End Function
' ---------------------------------------------------------------------------
Function DelTask(shapeTask As Shape) As Integer
On Error Goto ErrorHandle
    Dim shapeTopTask    As Shape
    Dim shapeBotTask    As Shape

    Dim shapeTasksTitle    As Shape
    Set shapeTasksTitle = FindShapeByName(thisDoc.ActivePage, "TasksTitle")

    Set shapeTopTask = thisDoc.ActivePage.ShapeByID(shapeTask.CustomProp(4).Value)
    Set shapeBotTask = thisDoc.ActivePage.ShapeByID(shapeTask.CustomProp(5).Value)

    If shapeTopTask <> Null Then
        shapeTopTask.CustomProp(5).Value = shapeTask.CustomProp(5).Value
        shapeTopTask.PropertyChanged(CDPT_CUSTOM_VALUE, 5)
    Else
        If shapeBotTask <> Null Then
            shapeBotTask.CustomProp(3).Value = 1
            shapeBotTask.PropertyChanged(CDPT_CUSTOM_VALUE, 3)
            shapeTasksTitle.CustomProp(5).Value = shapeBotTask.ID
        Else
            shapeTasksTitle.CustomProp(5).Value = 0
        End If
    End If
    If shapeBotTask <> Null Then
        shapeBotTask.CustomProp(4).Value = shapeTask.CustomProp(4).Value
        shapeBotTask.SetPropertyFormula(shapeTask.GetPropertyFormula(CDPT_GPINY), CDPT_GPINY)
        shapeBotTask.SetPropertyFormula(shapeTask.GetPropertyFormula(CDPT_CUSTOM_VALUE, 3), CDPT_CUSTOM_VALUE, 3)

        shapeBotTask.PropertyChanged(CDPT_CUSTOM_VALUE, 4)
        shapeBotTask.RecalcProperty(CDPT_GPINY)
        shapeBotTask.RecalcProperty(CDPT_CUSTOM_VALUE, 3)
    End If
    Dim shapeLastTask As Shape
    Set shapeLastTask = FindBottomTask(thisDoc.ActivePage, shapeTask.ID)
    If shapeLastTask <> Null Then
        strFormula = "=ObjID" & shapeLastTask.ID & ".GPinY+ObjID" & shapeLastTask.ID & ".Height-Height-GPinY"
        shapeTasksTitle.SetPropertyFormula(strFormula, CDPT_VARIABLE_Y, 2)
        shapeTasksTitle.RecalcProperty(CDPT_VARIABLE_Y, 2)
    End If

    Dim shapeTimeLine As Shape
    Dim x1 As Long, x2 As Long, y1 As Long, y2 As Long
    Dim rx1 As Long, rx2 As Long, ry1 As Long, ry2 As Long
    rx1 = shapeTask.GPinX
    rx2 = shapeTask.GPinX + shapeTask.Width
    ry1 = shapeTask.GPinY
    ry2 = shapeTask.GPinY + shapeTask.Height
    For I=thisDoc.ActivePage.ShapesNum() To 1 Step -1
        If thisDoc.ActivePage.Shape(I).Name = "TimeLineS" Then
            Set shapeTimeLine = thisDoc.ActivePage.Shape(I)
            If NOT shapeTimeLine.Is1D Then
                x1 = shapeTimeLine.GPinX
                y1 = shapeTimeLine.GPinY
                x2 = x1
                y2 = y1
                If LineInRect(x1, y1, x2, y2, rx1, ry1, rx2, ry2) = True Then
                    thisDoc.ActivePage.RemoveShapeByID(shapeTimeLine.ID)
                End If
            End If
        End If
    Next

    shapeTask.LockDelete = False
    thisDoc.ActivePage.RemoveShapeByID(shapeTask.ID)
ErrorHandle:
End Function
' ---------------------------------------------------------------------------
Function GetTasksTitle() As Shape
    Dim libTasksTitle    As Master
    Dim shapeTasksTitle    As Shape

    GetTasksTitle = Null
    Set shapeTasksTitle = FindShapeByName(thisDoc.ActivePage, "TasksTitle")
    If shapeTasksTitle = Null Then
        Dim ProjectLib As Library
        Set ProjectLib    = thisApp.OpenLib("Project Management/Gantt Chart Shapes.cdl")
        If ProjectLib = Null Then
            Exit Function
        End If
        Set libTasksTitle = ProjectLib.MasterByName("TasksTitle")
        If libTasksTitle = Null Then
            Exit Function
        End If
        Set shapeTasksTitle = thisDoc.ActivePage.DropStamp(libTasksTitle.Shape, 100, 100)
        shapeTasksTitle.LPinX = 0
        shapeTasksTitle.LPinY = 0
    End If
    Set TasksTitle = shapeTasksTitle
    Set GetTasksTitle = shapeTasksTitle
End Function
' ---------------------------------------------------------------------------
Sub MenuItemDelTask(cmdArgs As String)
    Dim shapeTask As Shape
    thisDoc.StartRebuild()
    For I=thisDoc.ActiveView.SelectedNum() To 0 Step -1
        Set shapeTask = thisDoc.ActiveView.GetSelectedShape(I)
        If shapeTask <> Null Then
            If shapeTask.Name = "TaskBar" Then
                DelTask(shapeTask)
            End If
        End If
    Next
    thisDoc.EndRebuild()
End Sub
' ---------------------------------------------------------------------------
Function MakeGanttMenu() As Integer
    Dim mi As MenuItem

    If thisDoc.CustomMenu.MenuItemsNum() = 0 Then
        thisDoc.CustomMenu.Caption = "Gantt Chart"

        set mi = thisDoc.CustomMenu.AddMenuItem(0)
        mi.Caption = "Delete Task"
        mi.SetCmdProcessing("MenuItemDelTask")
    End If
End Function
' ---------------------------------------------------------------------------
Dim shpTasksTitle    As Shape
Set shpTasksTitle = GetTasksTitle()
shpTasksTitle.Variable(3).X = 0
MakeGanttMenu()
' ---------------------------------------------------------------------------