16. december 2004 - 15:05
#2
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
25. december 2006 - 10:57
#3
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