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

Text File | 2004-02-13 | 12.3 KB | 427 lines

Declare Function PPCalendarPropDlg Lib "CDWizards" (ByRef str As String) As Long

Dim arrayWeekSymb(7)    As String
Dim arrayMonthDays(12)    As Integer
Dim arrayQuartalDays(4)    As Integer
Dim shapeCalendar        As Shape

Function GetCalStart() As Double
    GetCalStart = TasksTitle.CustomProp(2).Value
End Function

Sub SetCalStart(inDate As Double)
    TasksTitle.CustomProp(2).Value = inDate
End Sub

Function GetCalEnd() As Double
    GetCalEnd = TasksTitle.CustomProp(3).Value
End Function

Sub SetCalEnd(inDate As Double)
    TasksTitle.CustomProp(3).Value = inDate
End Sub

Function GetDayWidth() As Double
    GetDayWidth = TasksTitle.CustomProp(1).Value
End Function

Sub SetDayWidth(inWidth As Double)
    TasksTitle.CustomProp(1).Value = inWidth
End Sub

Function GetTimeScale() As Integer
    GetTimeScale = TasksTitle.CustomProp(4).Value
End Function

Sub SetTimeScale(inTimeScale As Integer)
    TasksTitle.CustomProp(4).Value = inTimeScale
End Sub

Function GetDateDay(inDate As Date) As Integer
    GetDateDay = Format(inDate, "d")
End Function

Function GetDateMonth(inDate As Date) As Integer
    GetDateMonth = Format(inDate, "m")
End Function

Function GetDateYear(inDate As Date) As Integer
    GetDateYear = Format(inDate, "yyyy")
End Function

Function GetDateWeekDay(inDate As Date) As Integer
    GetDateWeekDay = Format(inDate, "w")
    If GetDateWeekDay = 1 Then
        GetDateWeekDay = 8
    End If
    GetDateWeekDay = GetDateWeekDay - 1
End Function

Function GetDateYearDay(inDate As Date) As Integer
    GetDateYearDay = Format(inDate, "y")
End Function

Function IsLongYear(inDate As Date) As Boolean
    Dim intYear As Integer
    intYear = GetDateYear(inDate)
    IsLongYear = ((intYear MOD 4) = 0) AND (((intYear MOD 100) > 0) OR ((intYear MOD 400) = 0))
End Function

Function ChackEndDate(inDate As Date) As Date
    ChackEndDate = inDate
    If ChackEndDate > GetCalEnd() + 1 Then
        ChackEndDate = GetCalEnd() + 1
    End If
End Function

Function GetNextCellDate(inKind As Integer, inCurDate As Date, ByRef outText As String, IsTop As Integer) As Date
    Dim val        As Integer
    Dim val_d    As Double
    Select Case inKind
        Case 1    ' day
            GetNextCellDate = inCurDate + 1
            outText = arrayWeekSymb(GetDateWeekDay(inCurDate))
        Case 2    ' week
            GetNextCellDate = inCurDate + 8 - GetDateWeekDay(inCurDate)
            If IsTop = 1 Then
                outText = Format(inCurDate, "dd mmm yyyy")
            Else
                outText = Format(inCurDate, "dd.mm")
            End If
        Case 3    ' month
            val = GetDateMonth(inCurDate)
            GetNextCellDate = inCurDate + arrayMonthDays(val) - GetDateDay(inCurDate) + 1
            If val = 2 AND IsLongYear(inCurDate) Then
                GetNextCellDate = GetNextCellDate + 1
            End If
            If IsTop = 1 Then
                outText = Format(inCurDate, "mmm yyyy")
            Else
                outText = Format(inCurDate, "mmm")
            End If
        Case 4    ' quartal
            val = Int((GetDateMonth(inCurDate) - 1) / 3) + 1
            val_d = GetDateYearDay(inCurDate)
            For I = 1 To val-1
                val_d = val_d - arrayQuartalDays(I)
            Next
            GetNextCellDate = inCurDate + arrayQuartalDays(val) - val_d + 1
            If IsLongYear(inCurDate) Then
                GetNextCellDate = GetNextCellDate + 1
            End If
            If val < 4 Then
                outText = String(val, "I")
            Else
                outText = "IV"
            End If
        Case 5    ' year
            If IsLongYear(inCurDate) Then
                GetNextCellDate = inCurDate + 366 - GetDateYearDay(inCurDate)+1
            Else
                GetNextCellDate = inCurDate + 365 - GetDateYearDay(inCurDate)+1
            End If
            outText = Format(inCurDate, "yyyy")
        Case 6    ' year5
            val = GetDateYear(inCurDate)
            GetNextCellDate = CDate("01.01." & ((Int(val / 5) + 1) * 5))
            outText = Format(inCurDate, "yyyy - ") & (((Int(val/5)+1)*5)-1)
    End Select
    GetNextCellDate = ChackEndDate(GetNextCellDate)
End Function

Sub BuildOneLineInCalendar(inKind As Integer, inTop As Double, isLineNum As Integer)
On Error Goto ErrorHandle
    Dim dateCurDate        As Date
    Dim dateNextDate    As Date
    Dim X1                As Double
    Dim X2                As Double
    Dim shapeText        As String
    Dim shapeCell        As Shape
    Dim varVariable        As Variable

    dateCurDate = GetCalStart()
    Do While dateCurDate < GetCalEnd() + 1
        dateNextDate = GetNextCellDate(inKind, dateCurDate, shapeText, (isLineNum=0))
        X1 = (dateCurDate - GetCalStart()) * GetDayWidth()
        X2 = (dateNextDate - GetCalStart()) * GetDayWidth()
        Set shapeCell = shapeCalendar.DrawRect(X1, inTop, X2, inTop+50)


        shapeCell.Text = shapeText
        shapeCell.SetPropertyFormula("_AND(_TEXTWIDTH(TheText)<Width;_TEXTHEIGHT(TheText;Width)<Height)", CDPT_SHOWTEXT)
        shapeCell.RecalcProperty(CDPT_SHOWTEXT)
        If inKind = 1 AND shapeText = "S" Then
            shapeCell.FillColor.SetRGB(200, 200, 200)
        Else
            shapeCell.FillColor.SetRGB(255, 255, 255)
        End If
        shapeCell.PenPattern = 1
        shapeCell.SetCharStyle(1, -1, 0)
        shapeCell.SetParaHAlign(1, -1, 1)
        shapeCell.FillPattern = 1
        shapeCell.FillPatColor.SetRGB(255, 255, 255)
        dateCurDate = dateNextDate
    Loop
ErrorHandle:
End Sub

Sub BuildBackground(inKind As Integer, inCalWidth As Double)
On Error Goto ErrorHandle
    Dim shapeBackground    As Shape
    Dim shapeCell        As Shape
    Dim dateCurDate        As Date
    Dim dateNextDate    As Date
    Dim X1                As Double
    Dim X2                As Double
    Dim shapeText        As String
    Dim dblTop            As Double

    Set shapeBackground = TasksTitle.DrawGroup(TasksTitle.ControlDot(7).X, 100, inCalWidth + TasksTitle.ControlDot(7).X, 101)
    shapeBackground.LPinX = 0
    shapeBackground.LPinY = 0
    shapeBackground.GPinX = TasksTitle.ControlDot(7).X
    shapeBackground.GPinY = 100
    shapeBackground.Name = "Background"
    dateCurDate = GetCalStart()
    Do While dateCurDate < GetCalEnd()+1
        dateNextDate = GetNextCellDate(inKind, dateCurDate, shapeText)
        X1 = (dateCurDate - GetCalStart()) * GetDayWidth()
        X2 = (dateNextDate - GetCalStart()) * GetDayWidth()
        Set shapeCell = shapeBackground.DrawRect(X1, 0, X2, 1)
        shapeCell.LPinY = 0
        shapeCell.GPinY = 0
        shapeCell.LPinX = 0
        shapeCell.GPinX = X1
        If inKind = 1 AND GetDateWeekDay(dateCurDate) >= 6 Then
            shapeCell.FillColor.SetRGB(200, 200, 200)
        Else
            shapeCell.FillColor.SetRGB(255, 255, 255)
        End If
        shapeCell.PenPattern = 1
        shapeCell.FillPattern = 1
        shapeCell.FillPatColor.SetRGB(255, 255, 255)
        shapeCell.SetPropertyFormula("=0", CDPT_LPINY)
        shapeCell.SetPropertyFormula("=0", CDPT_GPINY)
        shapeCell.SetPropertyFormula("=0", CDPT_LPINX)
        shapeCell.SetPropertyFormula("=" & X1, CDPT_GPINX)
        shapeCell.RecalcProperty(CDPT_LPINY)
        shapeCell.RecalcProperty(CDPT_GPINY)
        shapeCell.RecalcProperty(CDPT_LPINX)
        shapeCell.RecalcProperty(CDPT_GPINX)
        dateCurDate = dateNextDate
    Loop
    shapeBackground.SetPropertyFormula("=100", CDPT_GPINY)
    shapeBackground.SetPropertyFormula("=Parent.Controls.X7", CDPT_GPINX)
    shapeBackground.SetPropertyFormula("=Parent.Variables.Y2+1", CDPT_HEIGHT)

    shapeBackground.PropertyChanged(CDPT_LPINX)
    shapeBackground.PropertyChanged(CDPT_LPINY)
    shapeBackground.RecalcProperty(CDPT_GPINX)
    shapeBackground.RecalcProperty(CDPT_GPINY)
    shapeBackground.RecalcProperty(CDPT_HEIGHT)
    shapeBackground.PropertyChanged(CDPT_VARIABLE_Y, 2)
ErrorHandle:
End Sub

Sub AdjustCalendar()
    Dim val As Integer
    Select Case GetTimeScale()
        Case 2
            val = GetDateWeekDay(GetCalStart())
            SetCalStart(GetCalStart() - val + 1)
        Case 3
            val = GetDateDay(GetCalStart())
            SetCalStart(GetCalStart() - val + 1)
        Case 4
            val = Int((GetDateMonth(GetCalStart())-1) / 3) * 3 + 1
            SetCalStart(CDate("01." & val & "." & GetDateYear(GetCalStart())))
        Case 5
            SetCalStart(CDate("01.01." & GetDateYear(GetCalStart())))
    End Select
End Sub

'+---------------------------------------------------
'!    line 0
'+---------------------------------------------------
'!    line 1
'+---------------------------------------------------
Function GetTimeScaleForLine(inLineNum As integer, inTimeScale As Integer) As Integer
    GetTimeScaleForLine = inTimeScale
    If inLineNum = 0 Then
        If inTimeScale = 3 Then
            GetTimeScaleForLine = 5
        Else
            GetTimeScaleForLine = inTimeScale + 1
        End If
    End If
End Function

Function RecalcTimeLines(shpTasksTitle As Shape) As Integer
On Error Goto ErrorHandle
    Dim dblStart        As Double
    Dim dblEnd            As Double
    Dim dblComplete        As Double
    Dim shapeTask        As Shape

    Dim strFormula        As String
    Dim dblPosS            As Double
    Dim dblPosE            As Double
    Dim dblPosC            As Double
    Dim dblDayWidth        As Double
    Dim dblCalStart        As Double

    dblDayWidth = GetDayWidth()
    dblCalStart = GetCalStart()

    For I=1 To thisDoc.ActivePage.ShapesNum()
        If thisDoc.ActivePage.Shape(I).Name = "TaskBar" Then
            Set shapeTask = thisDoc.ActivePage.Shape(I)
            If IsDate(shapeTask.CustomProp(6).Value) Then
                dblStart = CDbl(CDate(shapeTask.CustomProp(6).Value))
            Else
                dblStart = dblCalStart
            End If
            If IsDate(shapeTask.CustomProp(7).Value) Then
                dblEnd = CDbl(CDate(shapeTask.CustomProp(7).Value))
            Else
                dblEnd = dblCalStart + 2
            End If
            dblComplete = shapeTask.CustomProp(9).Value

            strFormula = shapeTask.GetPropertyFormula(CDPT_VARIABLE_X, 7)
            shapeTask.Variable(7).X = shpTasksTitle.Width
            shapeTask.SetPropertyFormula(strFormula, CDPT_VARIABLE_X, 7)
            shapeTask.RecalcProperty(CDPT_VARIABLE_X, 7)

            dblPosS = (dblStart - dblCalStart) * dblDayWidth + shapeTask.Variable(6).X
            shapeTask.ControlDot(1).X = dblPosS
            dblPosE = (dblEnd - dblCalStart + 1) * dblDayWidth + shapeTask.Variable(6).X
            shapeTask.ControlDot(2).X = dblPosE
            dblPosC = (dblPosE - dblPosS) * dblComplete + dblPosS
            shapeTask.ControlDot(3).X = dblPosC

            shapeTask.PropertyChanged(CDPT_CONTROL_X, 1)
            shapeTask.PropertyChanged(CDPT_CONTROL_X, 2)
            shapeTask.PropertyChanged(CDPT_CONTROL_X, 3)
            shapeTask.PropertyChanged(CDPT_CUSTOM_VALUE, 1)
        End if
    Next
ErrorHandle:
End Function

Function BuildCalendar(this As Shape, inFlag As Integer) As Integer
On Error Goto ErrorHandle
    Dim shapeForDel        As Shape
    Dim ret                As Long

    Dim calStart        As Double
    Dim calEnd            As Double
    Dim intScale        As Long

    BuildCalendar = 0
    Set TasksTitle = this

    If inFlag = 1 Then
        Dim str As String
        Dim val As Double

        str = GetCalStart() & " " & GetCalEnd() & " " & (GetTimeScale()-1) & Space(32)
        ret = PPCalendarPropDlg(str)
        If ret = -1 Then
            Exit Function
        End If
        SetCalStart(CDbl(str))
        str = Trim(Right(str, Len(str) - InStr(str, " ")))
        SetCalEnd(CDbl(str))
        str = Trim(Right(str, Len(str) - InStr(str, " ")))
        SetTimeScale(CInt(str)+1)
    End If

    Set shapeForDel = FindShapeByNameInGroup(TasksTitle, "Calendar")
    If shapeForDel <> Null Then
        TasksTitle.RemoveShapeByID(shapeForDel.ID)
    End If
    Set shapeForDel = FindShapeByNameInGroup(TasksTitle, "Background")
    If shapeForDel <> Null Then
        TasksTitle.RemoveShapeByID(shapeForDel.ID)
    End If
    Select Case GetTimeScale()
        Case 1
            SetDayWidth(50)
        Case 2
            SetDayWidth(150 / 7)
        Case 3
            SetDayWidth(150 / 30.4375)
        Case 4
            SetDayWidth(200 / 92)
        Case 5
            SetDayWidth(200 / 365.25)
    End Select
    AdjustCalendar()

    arrayWeekSymb(1) = "M"
    arrayWeekSymb(2) = "T"
    arrayWeekSymb(3) = "W"
    arrayWeekSymb(4) = "T"
    arrayWeekSymb(5) = "F"
    arrayWeekSymb(6) = "S"
    arrayWeekSymb(7) = "S"

    arrayMonthDays(01) = 31
    arrayMonthDays(02) = 28
    arrayMonthDays(03) = 31
    arrayMonthDays(04) = 30
    arrayMonthDays(05) = 31
    arrayMonthDays(06) = 30
    arrayMonthDays(07) = 31
    arrayMonthDays(08) = 31
    arrayMonthDays(09) = 30
    arrayMonthDays(10) = 31
    arrayMonthDays(11) = 30
    arrayMonthDays(12) = 31

    arrayQuartalDays(1) = 31 + 28 + 31
    arrayQuartalDays(2) = 30 + 31 + 30
    arrayQuartalDays(3) = 31 + 31 + 30
    arrayQuartalDays(4) = 31 + 30 + 31

    thisDoc.ActivePage.ReorderShape(TasksTitle.SubID, 1)
    thisDoc.StartRebuild()

    Dim dblCalWidth As Double
    dblCalWidth = (GetCalEnd() - GetCalStart() + 1) * GetDayWidth()

    TasksTitle.SetNullFormula(CDPT_WIDTH)
    TasksTitle.Width = TasksTitle.ControlDot(7).X + dblCalWidth
    TasksTitle.PropertyChanged(CDPT_WIDTH)
    Set shapeCalendar = TasksTitle.DrawGroup(TasksTitle.ControlDot(7).X, 0, TasksTitle.ControlDot(7).X + dblCalWidth, TasksTitle.Height)

    BuildOneLineInCalendar(GetTimeScaleForLine(0, GetTimeScale()), 0, 0)
    BuildOneLineInCalendar(GetTimeScaleForLine(1, GetTimeScale()), TasksTitle.Height*0.5, 1)

    thisDoc.EndRebuild()
    thisDoc.StartRebuild()

    If GetTimeScale() > 1 Then
        BuildBackground(GetTimeScaleForLine(0, GetTimeScale()), dblCalWidth)
    Else
        BuildBackground(GetTimeScaleForLine(1, GetTimeScale()), dblCalWidth)
    End If

    shapeCalendar.LPinX = 0
    shapeCalendar.LPinY = 0
    shapeCalendar.Name = "Calendar"
    shapeCalendar.SetPropertyFormula("=Parent.Controls.X7", CDPT_GPINX)
    shapeCalendar.RecalcProperty(CDPT_GPINX)

    thisDoc.PageSizeX = TasksTitle.GPinX + TasksTitle.Width + 100

    RecalcTimeLines(TasksTitle)

    thisDoc.EndRebuild()
    thisDoc.UpdateAllViews()

    BuildCalendar = 1
ErrorHandle:
End Function