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

Text File | 2004-02-13 | 7.8 KB | 272 lines

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ни в коем разе не править этот файл, т.к. перестанет работать Wizard! '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim dateCalEnd        As Date
Dim dateCalStart    As Date
Dim dblDayWidth        As Double
Dim intTimeScale    As Integer
Dim dblCalendarLeft As Double

Dim dblCurDayTop    As Date
Dim dblCurDayBot    As Date

Dim shapeCalendar    As Shape
Dim shapeBackground    As Shape

Const    dblOneCellWidth    As Double = 50
Dim        dblTSCells(5)    As Double
Dim        dblTSDays(5)    As Double

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

Function CalcTimeScale() As Integer
    dblTSCells(1) = 1
    dblTSCells(2) = 3
    dblTSCells(3) = 3
    dblTSCells(4) = 4
    dblTSCells(5) = 4

    dblTSDays(1)  = 1
    dblTSDays(2)  = 7
    dblTSDays(3)  = 30
    dblTSDays(4)  = 91
    dblTSDays(5)  = 365

    CalcTimeScale = 5
    For I=1 To 5
        If dblDayWidth > dblTSCells(I)*dblOneCellWidth/dblTSDays(I) Then
            CalcTimeScale = I
            Exit For
        End If
    Next
    dblDayWidth = Round(dblDayWidth * dblTSDays(CalcTimeScale) / dblOneCellWidth) * dblOneCellWidth / dblTSDays(CalcTimeScale)
End Function

Function GetMinWidth(inKind As Integer) As Double
    GetMinWidth = 0
    Select Case inKind
        Case 1
            GetMinWidth = 45
        Case 2
            GetMinWidth = 100
        Case 3
            GetMinWidth = 100
        Case 4
            GetMinWidth = 45
        Case 5
            GetMinWidth = 100
        Case 6
            GetMinWidth = 190
    End Select
End Function

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    '1-7 (пн. - вс.)
    GetDateWeekDay = Format(inDate, "w")
    If GetDateWeekDay = 7 Then
        GetDateWeekDay = 0
    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 > dateCalEnd+1 Then
        ChackEndDate = dateCalEnd+1
    End If
End Function

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

Sub BuildOneLineInCalendar(inKind As Integer, inTop As Double)
    Dim dateCurDate        As Date
    Dim dateNextDate    As Date
    Dim X1                As Double
    Dim X2                As Double
    Dim shapeText        As String
    Dim shapeCell        As Shape

    dateCurDate = dateCalStart
    Do While dateCurDate < dateCalEnd+1
        dateNextDate = GetNextCellDate(inKind, dateCurDate, shapeText)
        X1 = (dateCurDate - dateCalStart) * dblDayWidth
        X2 = (dateNextDate - dateCalStart) * dblDayWidth
        Set shapeCell = shapeCalendar.DrawRect(X1, inTop, X2, inTop+50)
        shapeCell.Text = shapeText
        If shapeCell.Width < GetMinWidth(inKind) Then
            shapeCell.Text = ""
        End If
        If inKind = 1 AND shapeText = "S" Then
            shapeCell.ColorProperty(CDPT_FILLCOLOR).SetRGB(200, 200, 200)
        End If
        shapeCell.SetCharStyle(1, -1, 0)
        shapeCell.SetParaHAlign(1, -1, 1)
        dateCurDate = dateNextDate
    Loop
End Sub

Sub BuildBackground(inKind As Integer)
    Dim dateCurDate        As Date
    Dim dateNextDate    As Date
    Dim X1                As Double
    Dim X2                As Double
    Dim shapeCell        As Shape
    Dim shapeText        As String
    Dim dblTop            As Double

    dblTop = shapeCalendar.GPinY + shapeCalendar.Height
    Set shapeBackground = thisDoc.ActivePage.DrawGroup(dblCalendarLeft, dblTop, shapeCalendar.GPinX + shapeCalendar.Width, dblTop+50)
    dateCurDate = dateCalStart
    Do While dateCurDate < dateCalEnd+1
        dateNextDate = GetNextCellDate(inKind, dateCurDate, shapeText)
        X1 = (dateCurDate - dateCalStart) * dblDayWidth
        X2 = (dateNextDate - dateCalStart) * dblDayWidth
        Set shapeCell = shapeBackground.DrawRect(X1, 0, X2, 50)
        If inKind = 1 AND GetDateWeekDay(dateCurDate) >= 6 Then
            shapeCell.ColorProperty(CDPT_FILLCOLOR).SetRGB(200, 200, 200)
        End If
        shapeCell.RecalcProperty(CDPT_GPINY)
        dateCurDate = dateNextDate
    Loop
    shapeBackground.LPinX = 0
    shapeBackground.LPinY = 0
    shapeBackground.SetPropertyFormula("=ObjID" & shapeCalendar.ID & ".GPinX", CDPT_GPINX)
    shapeBackground.SetPropertyFormula("=ObjID" & shapeCalendar.ID & ".GPinY + ObjID" & shapeCalendar.ID & ".Height", CDPT_GPINY)
    shapeBackground.SetPropertyFormula("=ObjID" & shapeCalendar.ID & ".Width", CDPT_WIDTH)

    shapeBackground.RecalcProperty(CDPT_GPINX)
    shapeBackground.RecalcProperty(CDPT_GPINY)
    shapeBackground.RecalcProperty(CDPT_WIDTH)
End Sub

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

Sub BuildCalendar()
    dblDayWidth = (thisDoc.PageSizeX - dblCalendarLeft) / (dateCalEnd - dateCalStart + 1)

    intTimeScale = CalcTimeScale()
    AdjustCalendar()

    thisDoc.PageSizeY = (dateCalEnd - dateCalStart + 1) * dblDayWidth + dblCalendarLeft + 100

    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

    Set shapeCalendar = thisDoc.ActivePage.DrawGroup(dblCalendarLeft, 0, (dateCalEnd-dateCalStart+1)*dblDayWidth + dblCalendarLeft, 100)
    shapeCalendar.LPinX = 0
    shapeCalendar.LPinY = 0

    BuildOneLineInCalendar(intTimeScale+1, 0)
    BuildOneLineInCalendar(intTimeScale, 50)
    If intTimeScale = 1 Then
        BuildBackground(intTimeScale)
    Else
        BuildBackground(intTimeScale+1)
    End If
End Sub