Option Explicit Public Const FirstDayRow = 5 ' Row on month sheet for first day of month Public Const DateColumn% = 3 ' Column on month sheet with days Public Const NewYearRow = 4 ' Row on year sheet for January 1st Public Const NewYearColumn = 2 ' Column on year sheet for January 1st Sub CalCreateYearTable(ByVal iSelYear as Integer) ' Completes the overview for whole year ' Needed by StarOffice Calc and StarOffice Schedule Dim CalDay as Integer Dim CalMonth as Integer Dim i as Integer Dim s as Integer Dim oYearCell as object Dim iDate Dim ColPos, RowPos as Integer Dim oNameCell, oDateCell as Object Dim iCellValue as Long Dim oRangeFebCell, oCellAddress, oFebcell as Object Dim oRangeBlank as Object Dim sBlankStyle as String ' On Error Goto ErrorHandling oStatusLine.Start("",140) 'GetResText(sProgress) iDate = DateSerial(iSelYear,1,1) oYearCell = oSheet.GetCellRangeByName("Year") oYearCell.Value = iSelYear CalMonth = 1 CalDay = 0 s = 10 oStatusLine.SetValue(s) For i = 1 To 374 CalDay = CalDay+1 If CalDay = 32 Then CalDay = 1 CalMonth = CalMonth+1 s = s + 10 oStatusLine.SetValue(s) End If ColPos = NewYearColumn+(2*CalMonth) RowPos = NewYearRow + CalDay FormatCalCells(ColPos,RowPos,i) Next If NOT CalIsLeapYear(iSelYear) Then ' Delete 29th February if necessary oRangeFebCell = oSheet.GetCellRangeByName("Feb29") oCellAddress = oRangeFebCell.RangeAddress oFebCell = oSheet.GetCellByPosition(oCellAddress.StartColumn,oCellAddress.StartRow) oFebCell.String = "" ' Change the CellStyle according to the Range "Blank" oRangeBlank = oSheet.GetCellRangebyName("Blank") sBlankStyle = oRangeBlank.CellStyle oRangeFebCell.CellStyle = sBlankStyle End If oStatusLine.SetValue(150) ErrorHandling: If Err <> 0 Then MsgBox sError$, 16, sWizardTitle$ End If End Sub Sub CalCreateMonthTable(ByVal iSelYear as Integer, iSelMonth as Integer) Dim oMonthCell, oDateCell as Object Dim iDate as Date Dim oAddress Dim i, s as Integer Dim iStartDay as Integer ' Completes the monthly calendar 'On Error Goto ErrorHandling oStatusLine.Start("",40) 'GetResText(sProgess) ' Set month oMonthCell = oSheet.GetCellRangeByName("Month") iDate = DateSerial(iSelYear,iSelMonth,1) oMonthCell.Value = iDate ' Inserting holidays iStartDay = (iSelMonth - 1) * 31 + 1 s = 5 For i = iStartDay To iStartDay + 30 oStatusLine.SetValue(s) s = s + 1 FormatCalCells(DateColumn+1,FirstDayRow + i - iStartDay,i) Next oDateCell = oSheet.GetCellbyPosition(DateColumn,FirstDayRow+i-iStartDay - 1) oAddress = oDateCell.RangeAddress Select Case iSelMonth Case 2,4,6,9,11 oSheet.RemoveRange(oAddress, com.sun.star.sheet.CellDeleteMode.ROWS) If iSelMonth = 2 Then oAddress.StartRow = oAddress.StartRow - 1 oAddress.EndRow = oAddress.StartRow oSheet.RemoveRange(oAddress, com.sun.star.sheet.CellDeleteMode.ROWS) If Not CalIsLeapYear(iSelYear) Then oAddress.StartRow = oAddress.StartRow - 1 oAddress.EndRow = oAddress.StartRow oSheet.RemoveRange(oAddress, com.sun.star.sheet.CellDeleteMode.ROWS) End If End If End Select oStatusLine.SetValue(45) ErrorHandling: If Err <> 0 Then MsgBox sError$, 16, sWizardTitle$ End If End Sub Sub FormatCalCells(ColPos,RowPos,i as Integer) Dim oNameCell, oDateCell as Object Dim iCellValue as Long oDateCell = oSheet.GetCellbyPosition(ColPos-1,RowPos) If oDateCell.Value <> 0 Then iCellValue = oDateCell.Value oDateCell.Value = iCellValue If CalBankHolidayName$(i) <> "" Then oNameCell = oSheet.GetCellbyPosition(ColPos,RowPos) oNameCell.String = CalBankHolidayName$(i) If CalTypeOfBankHoliday%(i) = cHolidayType_Full Then oDateCell.CellStyle = cCalStyleWeekend$ End If End If End If End Sub