Mangler ugenr/skæve helligedage/Overskrift

Hvad er spørgsmålet? Hvad der mangler ud over det nævnte? Eller hvordan du får det nævnte på kalenderen?

Ugenummeret er let nok. Du får et ugenummer som streng ved at kalde format funktionen:

Uge$ = Format(datosn,"ww",vbMonday ,vbFirstFourDays)

De skæve helligdage er straks lidt mere kompliceret, da påskedag (som alle andre skæve helligdage beregnes ud fra) bliver lagt i forhold til en månekalender, hvorfor den kan ligge temmeligt forskelligt fra år til år.

Denne obskure funktion (jeg har ikke selv lavet den, så spørg mig ikke hvordan den virker!) returnerer den dato hvor påskedag ligger når den får et årstal som parameter:

Public Function Paaskedag(Yr As Integer) As Date

Dim d As Integer
d = (((255 - 11 * (Yr Mod 19)) - 21) Mod 30) + 21
Paaskedag = DateSerial(Yr, 3, 1) + d + (d > 48) + 6 - ((Yr + Yr \ 4 + _
d + (d > 48) + 1) Mod 7)

End Function

Du vil altså hurtigt kunne finde den rigtige tekst, f.eks. gennem et kald til en funktion som:

Public Function HDtekst(Dato As Date) As String
Dim Tekst As String
Select Case Dato - Paaskedag(Year(Dato))
Case 50
  Tekst = "2. Pinsedag"
Case 49
  Tekst = "Pinsedag"
Case 39
  Tekst = "Kristi himmelfartsdag"
Case 26
  Tekst = "St. Bededag"
Case 1
  Tekst = "2. Påskedag"
Case 0
  Tekst = "Påskedag"
Case -2
  Tekst = "Langfredag"
Case -3
  Tekst = "Skærtorsdag"
Case -7
  Tekst = "Palmesøndag"
Case Else
  Tekst = ""
End Select
HDtekst = Tekst
End Function

Jeg håber det er til hjælp...

nedestående kode løser alt det jeg manglede - men jeg mangler stadig at få ugenr til at stå til højre i mandag's feltet på en måde uanset hvor stor feltet står det altid til højre også  selvom jeg skriver i feltet ?



Const SØNDAG = 1
Const MANDAG = 2
Const LØRDAG = 7
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 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




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) = 5) And (Day(dtmDate) = 1) Then
                IsHelligdag = True ' 1 Maj
            ElseIf (Month(dtmDate) = 6) And (Day(dtmDate) = 5) Then
                IsHelligdag = True ' Grundlovsdag
            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, "kalendernavn$"
    WordBasic.Text 10, 28, 213, 13, "Navnet på kalenderen:", "Tekst1"
   
    WordBasic.TextBox 305, 48, 160, 18, "mdnr$"
    WordBasic.Text 10, 52, 213, 13, "Nummeret på den 1. måned:", "Tekst2"
   
    WordBasic.TextBox 305, 72, 160, 18, "aar$"
    WordBasic.Text 10, 76, 268, 13, "Årstallet, hvor den første måned er:", "Tekst3"
   
    WordBasic.TextBox 305, 96, 160, 18, "antal$"
    WordBasic.Text 10, 100, 115, 13, "Antal måneder:", "Tekst4"
   
    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 informationer.kalendernavn$

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$)
   
    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.WordRight 1
     
        Selection.Font.Bold = wdToggle
        Selection.Font.Size = 8
        Selection.Font.Color = wdColorBlue
       
        WordBasic.WordLeft 1
       
        dtmDate = DateSerial(aar, maaned, dag)
           
        If IsHelligdag(DateSerial(aar, maaned, dag)) Then
          WordBasic.ShadingPattern 4
          WordBasic.WordRight 1
         
           
          Selection.Font.Italic = wdToggle
          Selection.Font.Color = wdColorBlack
          Selection.Font.Size = 8
         
          If ((Month(dtmDate) = 5) And (Day(dtmDate) = 1)) Or ((Month(dtmDate) = 6) And (Day(dtmDate) = 5)) Then
            Selection.Font.Size = 8
          Else
            WordBasic.ShadingPattern 4
          End If
         
          Selection.ParagraphFormat.Alignment = wdAlignParagraphRight
         
          Select Case DateSerial(aar, maaned, dag)
                         
            Case Helligdag(CInt(aar), SKÆRTORSDAG)
                Selection.TypeText Text:="Skærtorsdag"
                WordBasic.WordLeft 2
           
            Case Helligdag(CInt(aar), LANGFREDAG)
                Selection.TypeText Text:="Langfredag"
                WordBasic.WordLeft 2
           
            Case Helligdag(CInt(aar), PÅSKEDAG)
                Selection.TypeText Text:="Påskedag"
                WordBasic.WordLeft 2
           
            Case Helligdag(CInt(aar), PÅSKEDAG2)
                Selection.TypeText Text:="2. Påskedag"
                WordBasic.WordLeft 4
                 
            Case Helligdag(CInt(aar), BEDEDAG)
                Selection.TypeText Text:="St.Bededag"
                WordBasic.WordLeft 4
           
            Case Helligdag(CInt(aar), KRISTIHIMMELFARTSDAG)
                Selection.TypeText Text:="Kr.himmelfartsdag"
                WordBasic.WordLeft 4
               
            Case Helligdag(CInt(aar), PINSEDAG)
                Selection.TypeText Text:="Pinsedag"
                WordBasic.WordLeft 2
           
            Case Helligdag(CInt(aar), PINSEDAG2)
                Selection.TypeText Text:="2. Pinsedag"
                WordBasic.WordLeft 4
                   
            Case Else
             
                If (Month(dtmDate) = 1) And (Day(dtmDate) = 1) Then
                  Selection.TypeText Text:="Nytårsdag"
                ElseIf (Month(dtmDate) = 5) And (Day(dtmDate) = 1) Then
                  Selection.TypeText Text:="1. Maj"
                ElseIf (Month(dtmDate) = 6) And (Day(dtmDate) = 5) Then
                  Selection.TypeText Text:="Grundlovsdag"
                ElseIf (Month(dtmDate) = 12) And (Day(dtmDate) = 25) Then
                    Selection.TypeText Text:="Juledag"
                ElseIf (Month(dtmDate) = 12) And (Day(dtmDate) = 26) Then
                    Selection.TypeText Text:="2. Juledag"
                End If
                WordBasic.WordLeft 4
           
           
          End Select
               
        End If
       
       
        Select Case WordBasic.Weekday(datosn)
            Case SØNDAG
                WordBasic.ShadingPattern 4
                WordBasic.CharRight 1
                Selection.Font.Size = 8
               
                WordBasic.ShadingPattern 4
                WordBasic.WordLeft 1
               
            Case MANDAG
                If Not IsHelligdag(DateSerial(aar, maaned, dag)) Then
                    WordBasic.WordRight 1
                    Selection.ParagraphFormat.Alignment = wdAlignParagraphRight
                    Selection.Font.Color = wdColorBlack
                    WordBasic.Insert Str(WEEKNR(Str(datosn)))
                 
                    WordBasic.WordLeft 4
                End If
                               
            Case LØRDAG
                WordBasic.ShadingPattern 4
             
            Case Else
           
        End Select
       
       
       
       
        WordBasic.LineDown 1
        datosn = datosn + 1
        dag = dag + 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

åbn svar

lukket