Dansk kalender

hvilken "kode sprog" skal den være i..

Følgende VB-funktion beregner helligdagene:

Const SKÆRTORSDAG = 1
Const LANGFREDAG = 2
Const PÅSKEDAG = 3
Const PÅSKEDAG2 = 4 ' 2. påskedag
Const BEDEDAG = 5
Const KRISTIHIMMELFARTSDAG = 6
Const PINSEDAG = 7
Const PINSEDAG2 = 8 ' 2. pinsedag

Function glrPåskedag(intYear As Integer) As Variant
    ' Udregner påskedag for et givet årstal
    ' Beregningsmetode ifl. Gauss
    Dim a As Integer
    Dim b As Integer
    Dim c As Integer
    Dim d As Integer
    Dim e As Integer
    Dim k As Integer
    Dim p As Integer
    Dim q As Integer
    Dim M As Integer
    Dim n As Integer
    Dim intDay As Integer
    Dim intMonth As Integer

    k = intYear \ 100
    p = (13 + 8 * k) \ 25
    q = k \ 4
    M = (15 - p + k - q) Mod 30
    n = (4 + k - q) Mod 7
    'Debug.Print k, p, q, m, n
    a = intYear Mod 19
    b = intYear Mod 4
    c = intYear Mod 7
    d = (19 * a + M) Mod 30
    e = (2 * b + 4 * c + 6 * d + n) Mod 7

    If d + e <= 9 Then
        intDay = 22 + d + e
        intMonth = 3
    ElseIf (d = 29) And (e = 6) Then
        intDay = 19
        intMonth = 4
    ElseIf (d = 28) And (e = 6) And (a > 10) Then
        intDay = 18
        intMonth = 4
    Else
        intDay = d + e - 9
        intMonth = 4
    End If
    glrPåskedag = DateSerial(intYear, intMonth, intDay)
End Function

Function Helligdag(intYear As Integer, Helligdagstype As Integer) As Variant
    ' Returnerer datoen for de forskydelige helligdage.
    ' Helligdagstypen angives med en af de prædefinerede konstanter

    Select Case Helligdagstype
        Case SKÆRTORSDAG
            Helligdag = glrPåskedag(intYear) - 3
        Case LANGFREDAG
            Helligdag = glrPåskedag(intYear) - 2
        Case PÅSKEDAG
            Helligdag = glrPåskedag(intYear)
        Case PÅSKEDAG2
            Helligdag = glrPåskedag(intYear) + 1
        Case BEDEDAG
            Helligdag = glrPåskedag(intYear) + 26
        Case KRISTIHIMMELFARTSDAG
            Helligdag = glrPåskedag(intYear) + 39
        Case PINSEDAG
            Helligdag = glrPåskedag(intYear) + 49
        Case PINSEDAG2
            Helligdag = glrPåskedag(intYear) + 50
    End Select
End Function

Function IsHelligdag(dtmDate As Variant) As Integer
    ' Returnerer TRUE hvis dtmDate er en helligdag
    Dim intYear As Integer
    Dim dtmPåskedag As Variant

    intYear = Year(dtmDate)
    dtmPåskedag = glrPåskedag(intYear)

    Select Case dtmDate - dtmPåskedag
        Case -3, -2, 0, 1, 26, 39, 49, 50
            IsHelligdag = True
        Case Else
            If (Month(dtmDate) = 1) And (Day(dtmDate) = 1) Then
                IsHelligdag = True ' Nytårsdag
            ElseIf (Month(dtmDate) = 12) And (Day(dtmDate) = 25) Then
                IsHelligdag = True ' Juledag
            ElseIf (Month(dtmDate) = 12) And (Day(dtmDate) = 26) Then
                IsHelligdag = True ' 2. juledag
            End If
    End Select
End Function

Koden laver en kalender - men mangler hvad der skal til for at vise helligdage ?



Function WEEKNR(InputDate As Long) As Integer
Dim a As Integer, b As Integer, c As Long, d As Integer
    WEEKNR = 0
    If InputDate < 1 Then Exit Function
    a = Weekday(InputDate, vbSunday)
    b = Year(InputDate + ((8 - a) Mod 7) - 3)
    c = DateSerial(b, 1, 1)
    d = (Weekday(c, vbSunday) + 1) Mod 7
    WEEKNR = Int((InputDate - c - 3 + d) / 7) + 1
End Function


Const SKÆRTORSDAG = 1
Const LANGFREDAG = 2
Const PÅSKEDAG = 3
Const PÅSKEDAG2 = 4 ' 2. påskedag
Const BEDEDAG = 5
Const KRISTIHIMMELFARTSDAG = 6
Const PINSEDAG = 7
Const PINSEDAG2 = 8 ' 2. pinsedag

Function glrPåskedag(intYear As Integer) As Variant
    ' Udregner påskedag for et givet årstal
    ' Beregningsmetode ifl. Gauss
    Dim a As Integer
    Dim b As Integer
    Dim c As Integer
    Dim d As Integer
    Dim e As Integer
    Dim k As Integer
    Dim p As Integer
    Dim q As Integer
    Dim M As Integer
    Dim n As Integer
    Dim intDay As Integer
    Dim intMonth As Integer

    k = intYear \ 100
    p = (13 + 8 * k) \ 25
    q = k \ 4
    M = (15 - p + k - q) Mod 30
    n = (4 + k - q) Mod 7
    'Debug.Print k, p, q, m, n
    a = intYear Mod 19
    b = intYear Mod 4
    c = intYear Mod 7
    d = (19 * a + M) Mod 30
    e = (2 * b + 4 * c + 6 * d + n) Mod 7

    If d + e <= 9 Then
        intDay = 22 + d + e
        intMonth = 3
    ElseIf (d = 29) And (e = 6) Then
        intDay = 19
        intMonth = 4
    ElseIf (d = 28) And (e = 6) And (a > 10) Then
        intDay = 18
        intMonth = 4
    Else
        intDay = d + e - 9
        intMonth = 4
    End If
    glrPåskedag = DateSerial(intYear, intMonth, intDay)
End Function

Function Helligdag(intYear As Integer, Helligdagstype As Integer) As Variant
    ' Returnerer datoen for de forskydelige helligdage.
    ' Helligdagstypen angives med en af de prædefinerede konstanter

    Select Case Helligdagstype
        Case SKÆRTORSDAG
            Helligdag = glrPåskedag(intYear) - 3
        Case LANGFREDAG
            Helligdag = glrPåskedag(intYear) - 2
        Case PÅSKEDAG
            Helligdag = glrPåskedag(intYear)
        Case PÅSKEDAG2
            Helligdag = glrPåskedag(intYear) + 1
        Case BEDEDAG
            Helligdag = glrPåskedag(intYear) + 26
        Case KRISTIHIMMELFARTSDAG
            Helligdag = glrPåskedag(intYear) + 39
        Case PINSEDAG
            Helligdag = glrPåskedag(intYear) + 49
        Case PINSEDAG2
            Helligdag = glrPåskedag(intYear) + 50
    End Select
End Function

Function IsHelligdag(dtmDate As Variant) As Integer
    ' Returnerer TRUE hvis dtmDate er en helligdag
    Dim intYear As Integer
    Dim dtmPåskedag As Variant

    intYear = Year(dtmDate)
    dtmPåskedag = glrPåskedag(intYear)

    Select Case dtmDate - dtmPåskedag
        Case -3, -2, 0, 1, 26, 39, 49, 50
            IsHelligdag = True
        Case Else
            If (Month(dtmDate) = 1) And (Day(dtmDate) = 1) Then
                IsHelligdag = True ' Nytårsdag
            ElseIf (Month(dtmDate) = 12) And (Day(dtmDate) = 25) Then
                IsHelligdag = True ' Juledag
            ElseIf (Month(dtmDate) = 12) And (Day(dtmDate) = 26) Then
                IsHelligdag = True ' 2. juledag
            End If
    End Select
End Function




Public Sub MAIN()
Dim x
Dim errtext$
Dim maaned
Dim aar
Dim teller
Dim dag
Dim datosn

Dim datolr
Dim dmaaned
Dim temp

ReDim dage__$(7)
dage__$(1) = "S ": dage__$(2) = "M ": dage__$(3) = "T "
dage__$(4) = "O ": dage__$(5) = "T "
dage__$(6) = "F ": dage__$(7) = "L "

ReDim mdr__$(12)
mdr__$(1) = "Januar": mdr__$(2) = "Februar": mdr__$(3) = "Marts"
mdr__$(4) = "April": mdr__$(5) = "Maj": mdr__$(6) = "Juni"
mdr__$(7) = "Juli": mdr__$(8) = "August": mdr__$(9) = "September"
mdr__$(10) = "Oktober": mdr__$(11) = "November": mdr__$(12) = "December"

WordBasic.BeginDialog 630, 122, "Opretter kalender"
    WordBasic.TextBox 305, 24, 160, 18, "mdnr$"
    WordBasic.Text 10, 28, 213, 13, "Nummeret på den 1. måned:", "Tekst1"
    WordBasic.TextBox 305, 48, 160, 18, "aar$"
    WordBasic.Text 10, 52, 268, 13, "Årstallet, hvor den første måned er:", "Tekst2"
    WordBasic.TextBox 305, 72, 160, 18, "antal$"
    WordBasic.Text 10, 76, 115, 13, "Antal måneder:", "Tekst3"
    WordBasic.OKButton 521, 21, 88, 21
    WordBasic.CancelButton 521, 48, 88, 21
WordBasic.EndDialog

Dim informationer As Object: Set informationer = WordBasic.CurValues.UserDialog

start:
x = WordBasic.Dialog.UserDialog(informationer, 1)
On Error GoTo -1: On Error GoTo slut
If x = 0 Then GoTo slut

'Checker dataene fra dialogboksen
If WordBasic.Val(informationer.mdnr$) < 1 Then
    errtext$ = "Månedsnummer skal være større end 0"
    GoTo fejl
End If
If WordBasic.Val(informationer.mdnr$) > 12 Then
    errtext$ = "Månedsnummer skal være mindre end eller lig 12"
    GoTo fejl
End If
If WordBasic.Val(informationer.aar$) < 1900 Then
    errtext$ = "Makroen kan ikke håndtere årstal før 1900"
    GoTo fejl
End If
If WordBasic.Val(informationer.aar$) > 4000 Then
    errtext$ = "Makroen kan ikke håndtere årstal større end 4000"
    GoTo fejl
End If
If WordBasic.Val(informationer.antal$) < 1 Then
    errtext$ = "Antallet af måneder skal være større end 0"
    GoTo fejl
End If
If WordBasic.Val(informationer.antal$) > 12 Then
    errtext$ = "Makroen kan maksimalt håndtere 12 måneder"
    GoTo fejl
End If



WordBasic.Bold 1
WordBasic.Insert "Hesselholt feriekalenderen"

WordBasic.TableInsertTable ConvertFrom:="", NumColumns:=Str(WordBasic.Val(informationer.antal$) * 2), NumRows:="33", InitialColWidth:="Auto", Format:="16", Apply:="1"

maaned = WordBasic.Val(informationer.mdnr$)
aar = WordBasic.Val(informationer.aar$)


For teller = 1 To WordBasic.Val(informationer.antal$)
   
  '  Selection.MoveDown Unit:=wdLine, Count:=30, Extend:=wdExtend
  '  Selection.Font.Bold = wdToggle
  '  Selection.Font.Size = 8
 
   
    WordBasic.TableSelectColumn
    WordBasic.TableColumnWidth ColumnWidth:="1,5 cm", RulerStyle:="2"
    WordBasic.CharLeft 1
    WordBasic.CharRight 2, 1
    WordBasic.TableMergeCells
    WordBasic.CharLeft 1
    WordBasic.EditBookmark Name:="her", SortBy:=0, Add:=1
   
    WordBasic.Bold 1
    WordBasic.Insert Str(aar)
    WordBasic.Bold 0
    WordBasic.WordLeft 1
    WordBasic.LineDown 1
    WordBasic.CharRight 2, 1
    WordBasic.TableMergeCells
   
   
    WordBasic.ShadingPattern 6
    WordBasic.Bold 1
    WordBasic.Insert mdr__$(maaned)
   
    WordBasic.Bold 0
    WordBasic.WordLeft 1
    WordBasic.LineDown 1
    dag = 1
    datosn = WordBasic.DateSerial(aar, maaned, dag)
   
   
       
    dmaaned = maaned
    While dmaaned = maaned
        WordBasic.Insert dage__$(WordBasic.Weekday(datosn))
        WordBasic.FormatTabs Position:="1,1 cm", Align:=2, Leader:=0, Set:=1
        WordBasic.Insert Chr(9)
        WordBasic.Insert Str(WordBasic.Day(datosn))
        WordBasic.BorderRight 0
   
             
        WordBasic.CharRight 1
        Selection.Font.Bold = wdToggle
        Selection.Font.Size = 8
        Selection.Font.Color = wdColorBlue
        WordBasic.CharLeft 1
       
           
     
        Select Case IsHelligdag(datesn)
          Case True
            WordBasic.ShadingPattern 4
            WordBasic.CharRight 1
            Selection.Font.Italic = wdToggle
            Selection.Font.Color = wdColorBlack
            Selection.Font.Size = 9
         
            WordBasic.ShadingPattern 4
        '    Selection.TypeText Text:="Nytår"
           
            WordBasic.CharLeft 1
           
         
          Case Else
         
        End Select
       
        Select Case WordBasic.Weekday(datosn)
            Case 1
                WordBasic.ShadingPattern 4
                WordBasic.CharRight 1
                Selection.Font.Size = 8
               
                WordBasic.ShadingPattern 4
                WordBasic.CharLeft 1
            Case 1 + 1
               
               
             
               
               
                ' WordBasic.Insert Str(WEEKNR(Str(datosn)))
               
               
               
            Case 1 + 6
                WordBasic.ShadingPattern 4
             
            Case Else
           
        End Select
        WordBasic.LineDown 1
        datosn = datosn + 1
        maaned = WordBasic.Month(datosn)
    Wend

    temp = WordBasic.Day(datosn)

    While temp <= 30
        WordBasic.BorderRight 0
        WordBasic.LineDown 1
        temp = temp + 1
    Wend

    WordBasic.EditBookmark Name:="her", SortBy:=0, GoTo:=1
    WordBasic.CenterPara
    WordBasic.LineDown 1
    WordBasic.CenterPara
    WordBasic.EditBookmark Name:="her", SortBy:=0, GoTo:=1
    WordBasic.BorderBottom 0
    WordBasic.NextCell
    aar = WordBasic.Year(datosn)
Next teller

WordBasic.StartOfDocument

GoTo slut

fejl:
WordBasic.MsgBox errtext$
GoTo start

slut:

End Sub