tirsdag den 25. oktober 2016

Regneark i Calc (Årskalender)

Efter at vi tidligere har gennemgået en række dato-funktioner i Calc regneark, vil jeg vise et praktisk eksempel. Makroen herunder danner en to-sidet kalender med helligdage, med seks måneder på hver side. Der er forklarende kommentarer i koden.

Eksempel:




REM  *****  BASIC  *****

Sub Main

this_year = InputBox ("Indtast årstal mellem 1583 og 3000", "Vælg årstal", year(date))

'Kontroller at årstallet brugbart
If (1583 > val(this_year) OR val(this_year) > 3000) then
MsgBox("Årstallet skal være mellem 1583 og 3000", 48, "Fejl")
Stop
End If

Cal_name="Kalender " & this_year

'Kontroller at dokumentet er et regneark
my_doc = ThisComponent
If not my_doc.SupportsService("com.sun.star.sheet.SpreadsheetDocument") then
MsgBox("Dokumentet skal være et regneark", 48, "Fejl")
Stop
End if

my_sheets = my_doc.Sheets
antal=my_sheets.count

If NOT my_sheets.hasbyName(Cal_name) Then

my_sheets.insertNewByName(Cal_name, antal)

End If

the_sheet = my_sheets.getByName(Cal_name)

'Formatér siden
oStyles = my_doc.StyleFamilies.getByName("PageStyles")
    oPstyle = oStyles.getByName(the_sheet.PageStyle)
    oPstyle.FooterIsOn = False
    oPstyle.FooterIsOn = False
    oPstyle.TopMargin=500

'Første linje   
  oRange = the_sheet.getCellRangeByName("A1:L1")
  oRange.merge(True)
  oCell= the_sheet.getCellByPosition(0, 0)
  oCell.String = Cal_name
  FormatDark(oCell)

  oRange = the_sheet.getCellRangeByName("M1:X1")
  oRange.merge(True)
  oCell= the_sheet.getCellByPosition(12, 0)
  oCell.String = Cal_name
  FormatDark(oCell)
 
'Nederste linje    
  oRange = the_sheet.getCellRangeByName("A34:X34")
  oRange.merge(True)
  oCell = the_sheet.getCellRangeByName("A34")
  FormatDark(oCell)

For m = 1 to 12
'Overskriften

  oRange = the_sheet.getCellRangeByPosition(m*2-1-1,1,m*2-1,1)
  oRange.merge(True)
  the_cell = the_sheet.getCellByPosition(m*2-1-1, 1)
  the_cell.String=TheMonthName(m)
  the_cell.HoriJustify = 2
  the_cell.CellBackColor=rgb(150,150,150)
  the_cell.CharColor=rgb(255,255,255)

'Justerer kolonnebredder
  Column= the_sheet.Columns(m*2-1-1)
  Column.Width=550
  Column= the_sheet.Columns(m*2-1)
  Column.Width=4000

Next m 

'For hver måned...
For m = 1 to 12

'Dag for dag...
For d= 1 to Day(LastDayOfMonth(DateValue("1-" & m & "-" & this_year))
the_date=DateValue(d & "-" & m & "-" & this_year)

'Skriv datoen i første kolonne
the_cell = the_sheet.getCellByPosition(m*2-1-1, d + 1)
the_cell.Value=the_date
the_cell.NumberFormat=109
'Formatter cellen
FormatLight(the_cell)

'Skriv ugedagens bogstav i anden kolonne
the_Othercell = the_sheet.getCellByPosition(m*2-1, d + 1)

'Lørdag og søndag formateres
    Select Case WeekDay(the_date)
    Case 1
        FormatLight(the_Othercell)
        the_Othercell.String="S"
    Case 2
        the_Othercell.String="M"
    Case 3
        the_Othercell.String="T"
    Case 4
        the_Othercell.String="O"
    Case 5
        the_Othercell.String="T"                       
    Case 6
        the_Othercell.String="F"
    Case 7
        FormatLight(the_Othercell)
        the_Othercell.String="L"               
End Select

'Tilføj helligdage
generic_date= left(STR(the_date),5)
oFA = createUnoService( "com.sun.star.sheet.FunctionAccess" )

'Faste helligdage
Select Case generic_date

case "01-01"
        FormatLight(the_Othercell)
        the_Othercell.String=the_Othercell.String & " Nytårsdag"
case "05-06"
        FormatLight(the_Othercell)
        the_Othercell.String=the_Othercell.String &" Grundlovsdag"
case "24-12"
        FormatLight(the_Othercell)
        the_Othercell.String=the_Othercell.String &" Juleaften"
case "25-12"
        FormatLight(the_Othercell)
        the_Othercell.String=the_Othercell.String &" Juledag"
case "26-12"
        FormatLight(the_Othercell)
        the_Othercell.String=the_Othercell.String &" 2. Juledag"               

'Skæve helligdage
'Der findes ingen påske-beregning i Basic, men vi kan eksekvere regnearksfunktionen =Påskedag)
        the_Othercell.String=the_Othercell.String &" Påskedag"
case Left(STR(CDate(oFA.callFunction( "EASTERSUNDAY", array( this_year ) )+1 ) ),5)
        FormatLight(the_Othercell)
        the_Othercell.String=the_Othercell.String &" 2. Påskedag"     
case Left(STR(CDate(oFA.callFunction( "EASTERSUNDAY", array( this_year ) )-2 ) ),5)
        FormatLight(the_Othercell)
        the_Othercell.String=the_Othercell.String &" Langfredag"              
case Left(STR(CDate(oFA.callFunction( "EASTERSUNDAY", array( this_year ) )-3 ) ),5)
        FormatLight(the_Othercell)
        the_Othercell.String=the_Othercell.String &" Skærtorsdag"
case Left(STR(CDate(oFA.callFunction( "EASTERSUNDAY", array( this_year ) )+49 ) ),5)
        FormatLight(the_Othercell)
        the_Othercell.String=the_Othercell.String &" Pinsedag"      
case Left(STR(CDate(oFA.callFunction( "EASTERSUNDAY", array( this_year ) )+50 ) ),5)
        FormatLight(the_Othercell)
        the_Othercell.String=the_Othercell.String &" 2. Pinsedag"   
case Left(STR(CDate(oFA.callFunction( "EASTERSUNDAY", array( this_year ) )+26 ) ),5)
        FormatLight(the_Othercell)
        the_Othercell.String=the_Othercell.String &" St. Bededag"   
        case Left(STR(CDate(oFA.callFunction( "EASTERSUNDAY", array( this_year ) )+39 ) ),5)
        FormatLight(the_Othercell)
        the_Othercell.String=the_Othercell.String &" Kr. Himmelfartsdag"            
End Select

Next d    'Dags-loopet slutter
Next m    'Måneds-loopet slutter

End Sub

Function LastDayOfMonth(d As Date) As Date
'Beregn hvor mange dage i måneden
  Dim nYear As Integer
  Dim nMonth As Integer
  nYear = Year(d)        'Current year
  nMonth = Month(d) + 1  'Next month, unless it was December.
  If nMonth > 12 Then    'If it is December then nMonth is now 13
    nMonth = 1           'Roll the month back to 1
    nYear = nYear + 1    'but increment the year
  End If
  LastDayOfMonth = CDate(DateSerial(nYear, nMonth, 1)-1)
End Function

Function TheMonthName(m)
'Omsætter månedstal til månedsnavn
CompatibilityMode(True)
TheMonthName=MonthName(m)
End Function

Sub FormatLight(oCell)
'Formatér lys grå
        oCell.CellBackColor=rgb(200,200,200)
        oCell.CharColor=rgb(255,255,255)
End Sub

Sub FormatDark(oCell)
'Formatér overskrift
  oCell.CharHeight=18
  oCell.HoriJustify = 2
  oCell.CellBackColor=rgb(100,100,100)
  oCell.CharColor=rgb(255,255,255)
End Sub