home *** CD-ROM | disk | FTP | other *** search
/ PC World 2002 May / PCWorld_2002-05_cd.bin / Akce / install / f_0030 / CreateTable.xba < prev    next >
Encoding:
Extensible Markup Language  |  2002-02-19  |  4.3 KB  |  133 lines
  1. <?xml version="1.0" encoding="UTF-8"?>
  2. <!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
  3. <script:module xmlns:script="http://openoffice.org/2000/script" script:name="CreateTable" script:language="StarBasic">Option Explicit
  4.  
  5. Public Const FirstDayRow = 5          ' Row on month sheet for first day of month
  6. Public Const DateColumn% = 3          ' Column on month sheet with days
  7. Public Const NewYearRow = 4           ' Row on year sheet for January 1st
  8. Public Const NewYearColumn = 2        ' Column on year sheet for January 1st
  9.  
  10.  
  11. Sub CalCreateYearTable(ByVal iSelYear as Integer)
  12. ' Completes the overview for whole year
  13.  
  14. ' Needed by StarOffice Calc and StarOffice Schedule
  15. Dim CalDay as Integer
  16. Dim CalMonth as Integer
  17. Dim i as Integer
  18. Dim s as Integer
  19. Dim oYearCell as object
  20. Dim iDate
  21. Dim ColPos, RowPos as Integer    
  22. Dim oNameCell, oDateCell as Object
  23. Dim iCellValue as Long    
  24. Dim oRangeFebCell, oCellAddress, oFebcell as Object
  25. Dim oRangeBlank as Object
  26. Dim sBlankStyle as String
  27. '    On Error Goto ErrorHandling
  28.     oStatusLine.Start("",140)    'GetResText(sProgress)
  29.     iDate = DateSerial(iSelYear,1,1)
  30.     oYearCell = oSheet.GetCellRangeByName("Year")
  31.     oYearCell.Value = iSelYear
  32.  
  33.     CalMonth = 1
  34.     CalDay = 0
  35.     s = 10
  36.     oStatusLine.SetValue(s)
  37.     For i = 1 To 374
  38.         CalDay = CalDay+1
  39.         If CalDay = 32 Then
  40.             CalDay = 1
  41.             CalMonth = CalMonth+1
  42.             s = s + 10
  43.             oStatusLine.SetValue(s)
  44.         End If
  45.         ColPos = NewYearColumn+(2*CalMonth)
  46.         RowPos = NewYearRow + CalDay
  47.         FormatCalCells(ColPos,RowPos,i)
  48.     Next
  49.     If NOT CalIsLeapYear(iSelYear) Then
  50.         ' Delete 29th February if necessary
  51.         oRangeFebCell = oSheet.GetCellRangeByName("Feb29")
  52.         oCellAddress = oRangeFebCell.RangeAddress
  53.         oFebCell = oSheet.GetCellByPosition(oCellAddress.StartColumn,oCellAddress.StartRow)
  54.         oFebCell.String = ""
  55.         ' Change the CellStyle according to the Range "Blank"
  56.         oRangeBlank = oSheet.GetCellRangebyName("Blank")
  57.         sBlankStyle = oRangeBlank.CellStyle
  58.         oRangeFebCell.CellStyle = sBlankStyle
  59.     End If
  60.     oStatusLine.SetValue(150)
  61.     ErrorHandling:
  62.     If Err <> 0 Then
  63.         MsgBox sError$, 16, sWizardTitle$
  64.     End If
  65. End Sub
  66.  
  67.  
  68.  
  69. Sub CalCreateMonthTable(ByVal iSelYear as Integer, iSelMonth as Integer)
  70. Dim oMonthCell, oDateCell as Object
  71. Dim iDate as Date
  72. Dim oAddress
  73. Dim i, s as Integer
  74. Dim iStartDay as Integer
  75.  
  76. ' Completes the monthly calendar
  77. 'On Error Goto ErrorHandling
  78.     oStatusLine.Start("",40)        'GetResText(sProgess)
  79.     ' Set month
  80.     oMonthCell = oSheet.GetCellRangeByName("Month")
  81.     
  82.     iDate = DateSerial(iSelYear,iSelMonth,1)
  83.     oMonthCell.Value = iDate
  84.     ' Inserting holidays
  85.     iStartDay = (iSelMonth - 1) * 31 + 1
  86.     s = 5
  87.     For i = iStartDay To iStartDay + 30
  88.         oStatusLine.SetValue(s)
  89.         s = s + 1
  90.         FormatCalCells(DateColumn+1,FirstDayRow + i - iStartDay,i)
  91.     Next
  92.     oDateCell = oSheet.GetCellbyPosition(DateColumn,FirstDayRow+i-iStartDay - 1)
  93.     oAddress = oDateCell.RangeAddress
  94.     
  95.     Select Case iSelMonth
  96.         Case 2,4,6,9,11
  97.             oSheet.RemoveRange(oAddress, com.sun.star.sheet.CellDeleteMode.ROWS) 
  98.             If iSelMonth = 2 Then
  99.                 oAddress.StartRow = oAddress.StartRow - 1    
  100.                 oAddress.EndRow = oAddress.StartRow
  101.                 oSheet.RemoveRange(oAddress, com.sun.star.sheet.CellDeleteMode.ROWS)
  102.                 If Not CalIsLeapYear(iSelYear) Then
  103.                     oAddress.StartRow = oAddress.StartRow - 1    
  104.                     oAddress.EndRow = oAddress.StartRow
  105.                     oSheet.RemoveRange(oAddress, com.sun.star.sheet.CellDeleteMode.ROWS)
  106.                 End If
  107.             End If
  108.     End Select
  109.     oStatusLine.SetValue(45)
  110. ErrorHandling:
  111.     If Err <> 0 Then
  112.         MsgBox sError$, 16, sWizardTitle$
  113.     End If
  114. End Sub
  115.  
  116.  
  117.  
  118. Sub FormatCalCells(ColPos,RowPos,i as Integer)
  119. Dim oNameCell, oDateCell as Object
  120. Dim iCellValue as Long
  121.     oDateCell = oSheet.GetCellbyPosition(ColPos-1,RowPos)
  122.     If oDateCell.Value <> 0 Then
  123.         iCellValue = oDateCell.Value
  124.         oDateCell.Value = iCellValue
  125.         If CalBankHolidayName$(i) <> "" Then
  126.             oNameCell = oSheet.GetCellbyPosition(ColPos,RowPos)
  127.             oNameCell.String = CalBankHolidayName$(i)
  128.             If CalTypeOfBankHoliday%(i) = cHolidayType_Full Then
  129.                 oDateCell.CellStyle = cCalStyleWeekend$
  130.             End If
  131.         End If
  132.     End If
  133. End Sub</script:module>