Re: Feiertag gelöscht....
- From: "Ull" <Frank-R.Ullrich@xxxxxx>
- Date: 12 Jun 2006 05:28:20 -0700
Heiko Blank wrote:
Habe aus versehen in meinem Outlook-Kalender (Outlook 2002), welchem ich
über ActiveSync (3.8) mit meinem PDA synchronisiere Feiertage gelöscht.
Meine Frage, wie kann ich Feiertage wieder in Outlook eintragen, ohne dass
ich diese als Serientermin hinterlegen?
Gruß Heiko
Hei Heiko,
.... du kannst auch zum Eintragen folgendes Macro verwenden. Ich habe es
ansich für MS PROJECT erstellt und dann für OUTLOOK angepasst.
Speichere beides als 'bas'-Datei ab.
Bundesweite Feiertage werden im OUTLOOK als 'abwesend' gekennzeichne
und im MS-Project als "arbeitsfrei".
Die Osterformel ist eine modifizierte Formel nach Gauß.
Bei Fragen, melde dich bitte.
Gruß
Frank-R. Ullrich
ps.: Fehler durch falschen Zeilenumbruch möglich :-((
' ************** BAS-Datei
******************************************
Attribute VB_Name = "Kalender"
Option Explicit
'
'Kalenderprogramm für Excel, Outlook, MS-Project
'Fragen, Anregungen: Frank-R.Ullrich@xxxxxx
'
Private Type Termin
datum As Long
text As String
art As Integer 'in OutLook: =0 : ohne Reservierung / =3 :
Abwesend
End Type
Private Tage() As Termin, anz_tage%, j_anf%, j_end%
Public Sub feiertage()
Dim I%
'' MS Project und Excel
' If j_anf = 0 Then
' j_anf = Year(Now)
' Else
' j_anf = j_end + 1
' End If
' j_end = j_anf + 10
' OutLook
j_anf = Year(Now)
j_end = j_anf + 1
'
anz_tage = 25 ' Anzahl der Feiertage
ReDim Tage(anz_tage)
For I = j_anf To j_end
Call feiertage_im_Jahr(I)
Call schreibe_Kalender(I - j_anf)
Next I
End Sub
Private Sub feiertage_im_Jahr(J As Integer)
Dim osternd As Long, weihnachtd As Long, dat As Long, dat1ad As Long
If J < 100 Then
J = J + 2000
End If
osternd = ostern(J)
weihnachtd = DateSerial(J, 12, 25)
' "freie" Feiertage (Outlook-Kennung "3")
Tage(1) = fund(DateSerial(J, 1, 1), "Neujahr", 3)
Tage(2) = fund(DateSerial(J, 5, 1), "1. Mai", 3)
Tage(3) = fund(DateSerial(J, 10, 3), "Tag der deutschen Einheit", 3)
Tage(4) = fund(weihnachtd - 1, "Heilig Abend", 3)
Tage(5) = fund(weihnachtd, "1. Weihnachtsfeiertag", 3)
Tage(6) = fund(weihnachtd + 1, "2. Weihnachtsfeiertag", 3)
Tage(7) = fund(osternd - 2, "Karfreitag", 3)
Tage(8) = fund(osternd + 1, "Ostermontag", 3)
Tage(9) = fund(osternd + 39, "Christi Himmelfahrt", 3)
Tage(10) = fund(osternd + 50, "Pfingstmontag", 3)
Tage(11) = fund(DateSerial(J, 12, 31), "Silvester", 3)
' Feiertage am Sonntag oder besondere Tage
Tage(12) = fund(osternd, "Ostersonntag", 0)
Tage(13) = fund(osternd + 49, "Pfingstsonntag", 0)
dat = weihnachtd
While Weekday(dat) > vbSunday
dat = dat - 1
Wend
dat1ad = dat - 21
Tage(14) = fund(dat1ad, "1. Advent", 0)
dat = DateSerial(J, 10, 1)
While Weekday(dat) <> vbSunday
dat = dat + 1
Wend
Tage(15) = fund(dat, "Erntedankfest", 0)
dat = osternd - 45
While Weekday(dat) <> vbMonday
dat = dat - 1
Wend
Tage(16) = fund(dat, "Rosenmontag", 0)
Tage(17) = fund(dat + 2, "Aschermittwoch", 0)
' in best. Bundesländern "freie" Feiertage
Tage(18) = fund(DateSerial(J, 1, 6), "Hl. Drei Könige", 0)
Tage(19) = fund(osternd + 60, "Fronleichnam", 0)
Tage(20) = fund(DateSerial(J, 8, 15), "Mariae Himmelfahrt", 0)
Tage(21) = fund(DateSerial(J, 10, 31), "Reformationstag", 0)
Tage(22) = fund(DateSerial(J, 11, 1), "Allerheiligen", 0)
Tage(23) = fund(dat1ad - 11, "Buß- und Bettag", 0)
End Sub
Private Function fund(n As Long, t As String, a As Integer) As Termin
fund.datum = n
fund.text = t
fund.art = a
End Function
Private Sub schreibe_Kalender(J)
Dim I%, datumx As String
For I = 1 To anz_tage
If Tage(I).datum > 0 Then
' Excel
''Cells(i, 1) = Tage(i).Text
''Cells(i, 3 + j) = Format(Tage(i).datum, "dd.mm.yy")
' MS Projekt
'' If Tage(i).art > 0 Then
'' BaseCalendarEditDays Name:="Standard",
StartDate:=Tage(i).datum, Working:=False, Default:=False ' o
'' End If
' OutLook
Call Ausgabe.Termin_nach_Outlook(Tage(I).datum, Tage(I).text,
Tage(I).art)
End If
Next I
End Sub
Private Function ostern(jahr As Integer)
'
' nach :Claus Tøndering
' http://www.tondering.dk/claus/cal/node3.html
'
Dim C%, G%, H%, I%, J%, L%
Dim em%, ed%
G = jahr Mod 19
C = jahr \ 100
H = (C - C \ 4 - (8 * C + 13) \ 25 + 19 * G + 15) Mod 30
I = H - (H \ 28) * (1 - (29 \ (H + 1)) * ((21 - G) \ 11))
J = (jahr + jahr \ 4 + I + 2 - C + C \ 4) Mod 7
L = I - J
em = 3 + (L + 40) \ 44
ed = L + 28 - 31 * (em \ 4)
ostern = DateSerial(jahr, em, ed)
End Function
' ************** BAS-Datei
******************************************
Attribute VB_Name = "Ausgabe"
Option Explicit
Sub Termin_nach_Outlook(datum As Long, text As String, art As Integer)
'
' Eintag in den OutLook-Kalender
'
' vgl: http://www.office.gmxhome.de/_excel_outlook.htm (Rainer
Beckerbauer)
'
Dim outapp As Object, apptOutApp As Object
Set outapp = CreateObject("Outlook.Application")
Set apptOutApp = outapp.CreateItem(1) 'olAppointmentItem)
If test(datum, text) Then ' Datum schon vorhanden?
Set apptOutApp = Nothing
Set outapp = Nothing
Exit Sub
End If
With apptOutApp
.Start = Format(datum, "dd.mm.yyyy") & " 00:00"
.Subject = text ' Text
.Body = text ' Text im Feld
.ReminderSet = False ' keine Erinnerung
.AllDayEvent = True ' ganzen tag
.BusyStatus = art ' Status an dem Tag
.Save
End With
'Variablen leeren,... sonst "kotzt" Outlook irgendwann mal
Set apptOutApp = Nothing
Set outapp = Nothing
End Sub
Private Function test(datum As Long, text As String) As Boolean
'
' Vergleich des Kalender-Eintrages
'
'
' vgl: http://www.office.gmxhome.de/_excel_outlook.htm (Rainer
Beckerbauer)
'
Dim myOlApp As Object, myOLSpace As Object, myOLFolder As Object
Dim myOlDateRange As Object, sAppoint As Object
Dim startdate As Date, enddate As Date
Set myOlApp = CreateObject("Outlook.Application")
Set myOLSpace = myOlApp.GetNamespace("MAPI")
Set myOLFolder = myOLSpace.GetDefaultFolder(olFolderCalendar)
test = False
startdate = datum - 1
enddate = datum
Set myOlDateRange = myOLFolder.Items.Restrict("[Start] >= '" &
startdate & "' And [End] < & '" & enddate + 1 & "'")
For Each sAppoint In myOlDateRange ' Suchen nach dem Text
With sAppoint
test = (.Subject = text)
If test Then
Exit For ' Abbruch, wenn gefunden
End If
End With
Next
Set myOLFolder = Nothing
Set myOLSpace = Nothing
Set myOlApp = Nothing
End Function
.
- References:
- Feiertag gelöscht....
- From: Heiko Blank
- Feiertag gelöscht....
- Prev by Date: Re: Name des Netzwerkes ausblenden
- Next by Date: Re: Outlook Security Settings
- Previous by thread: Re: Feiertag gelöscht....
- Next by thread: Outlook-Sicherheit vs. Thunderbird
- Index(es):
Relevant Pages
|
