Er der nogen, der kender til et modul med en dansk kalender, hvor hverdage, lørdag, søn- og helligedage er angivet. Det skal bruges til en webshop, hvor vi gerne vil angive en leveringsdag som næste hverdag. Derfor skal helligdage, der jo flytter sig være opdaterede.
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
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
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
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 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
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.
Ny bruger
Nybegynder
Opret
Preview
