home *** CD-ROM | disk | FTP | other *** search
- '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
- ' ни в коем разе не править этот файл, т.к. перестанет работать 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
-