Startseite

OutlookFeiertage.vbs

Druckansicht
Di, 22/01/2008 - 17:05 – wolfgang 
' --------------------------------------------------
' FeiertageLocal.vbs
' Clientseitiges eintragen von Feiertagen in Outlook
' 15.01.2008 Wolfgang Führer
' --------------------------------------------------
 
' Const
Const olAppointmentItem = 1
Const ForAppending = 8
Const olFolderCalender = 9
' EndConst
 
Dim arrAppointmentsDate() 'array für termine datum
Dim arrAppointmentsSubject() 'array für termine text
Dim objOutlook
Dim intFrom 'ab diesem jahr
intFrom = 2008
Dim strLogName 'name des logfiles
strLogName   = "FeiertageLocal.log"
 
Set objWSHShell = CreateObject( "WScript.Shell" )
Set objFSO = CreateObject("Scripting.FileSystemObject")
' define path to file
strScriptFolder = CStr(objWSHShell.CurrentDirectory)
strFullLogPath = strScriptFolder & "\" & strLogName
'Logfile created? - create if not
On Error Resume Next
Set strFile = objFSO.OpenTextFile(strFullLogPath, ForAppending)
If Err.Number <> 0 Then
  Set strFile = objFSO.CreateTextFile(strfulllogpath,vbFalse)
End If
strFile.Close
On Error Goto 0
 
Call subGetAppointments(intFrom)
 
WriteLog "---start--------------------------------------"
 
'Region data
Call subOutlookAppointments("1. Weihnachtstag", " 2008/12/25")
Call subOutlookAppointments("1. Weihnachtstag", " 2009/12/25")
Call subOutlookAppointments("1. Weihnachtstag", " 2010/12/25")
Call subOutlookAppointments("1. Weihnachtstag", " 2011/12/25")
Call subOutlookAppointments("1. Weihnachtstag", " 2012/12/25")
Call subOutlookAppointments("1. Weihnachtstag", " 2013/12/25")
Call subOutlookAppointments("1. Weihnachtstag", " 2014/12/25")
Call subOutlookAppointments("1. Weihnachtstag", " 2015/12/25")
Call subOutlookAppointments("2. Weihnachtstag", " 2008/12/26")
Call subOutlookAppointments("2. Weihnachtstag", " 2009/12/26")
Call subOutlookAppointments("2. Weihnachtstag", " 2010/12/26")
Call subOutlookAppointments("2. Weihnachtstag", " 2011/12/26")
Call subOutlookAppointments("2. Weihnachtstag", " 2012/12/26")
Call subOutlookAppointments("2. Weihnachtstag", " 2013/12/26")
Call subOutlookAppointments("2. Weihnachtstag", " 2014/12/26")
Call subOutlookAppointments("2. Weihnachtstag", " 2015/12/26")
Call subOutlookAppointments("Allerheiligen", " 2008/11/01")
Call subOutlookAppointments("Allerheiligen", " 2009/11/01")
Call subOutlookAppointments("Allerheiligen", " 2010/11/01")
Call subOutlookAppointments("Allerheiligen", " 2011/11/01")
Call subOutlookAppointments("Allerheiligen", " 2012/11/01")
Call subOutlookAppointments("Allerheiligen", " 2013/11/01")
Call subOutlookAppointments("Allerheiligen", " 2014/11/01")
Call subOutlookAppointments("Allerheiligen", " 2015/11/01")
Call subOutlookAppointments("Buß- und Bettag (z.T.)", " 2008/11/19")
Call subOutlookAppointments("Buß- und Bettag (z.T.)", " 2009/11/18")
Call subOutlookAppointments("Buß- und Bettag (z.T.)", " 2010/11/17")
Call subOutlookAppointments("Buß- und Bettag (z.T.)", " 2011/11/16")
Call subOutlookAppointments("Buß- und Bettag (z.T.)", " 2012/11/21")
Call subOutlookAppointments("Buß- und Bettag (z.T.)", " 2013/11/20")
Call subOutlookAppointments("Buß- und Bettag (z.T.)", " 2014/11/19")
Call subOutlookAppointments("Buß- und Bettag (z.T.)", " 2015/11/18")
Call subOutlookAppointments("Christi Himmelfahrt", " 2008/05/01")
Call subOutlookAppointments("Christi Himmelfahrt", " 2009/05/21")
Call subOutlookAppointments("Christi Himmelfahrt", " 2010/05/13")
Call subOutlookAppointments("Christi Himmelfahrt", " 2011/06/02")
Call subOutlookAppointments("Christi Himmelfahrt", " 2012/05/17")
Call subOutlookAppointments("Christi Himmelfahrt", " 2013/05/09")
Call subOutlookAppointments("Christi Himmelfahrt", " 2014/05/29")
Call subOutlookAppointments("Christi Himmelfahrt", " 2015/05/14")
Call subOutlookAppointments("Fronleichnam", " 2008/05/22")
Call subOutlookAppointments("Fronleichnam", " 2009/06/11")
Call subOutlookAppointments("Fronleichnam", " 2010/06/03")
Call subOutlookAppointments("Fronleichnam", " 2011/06/23")
Call subOutlookAppointments("Fronleichnam", " 2012/06/07")
Call subOutlookAppointments("Fronleichnam", " 2013/05/30")
Call subOutlookAppointments("Fronleichnam", " 2014/06/19")
Call subOutlookAppointments("Fronleichnam", " 2015/06/04")
Call subOutlookAppointments("Hl. 3 Könige", " 2008/01/06")
Call subOutlookAppointments("Hl. 3 Könige", " 2009/01/06")
Call subOutlookAppointments("Hl. 3 Könige", " 2010/01/06")
Call subOutlookAppointments("Hl. 3 Könige", " 2011/01/06")
Call subOutlookAppointments("Hl. 3 Könige", " 2012/01/06")
Call subOutlookAppointments("Hl. 3 Könige", " 2013/01/06")
Call subOutlookAppointments("Hl. 3 Könige", " 2014/01/06")
Call subOutlookAppointments("Hl. 3 Könige", " 2015/01/06")
Call subOutlookAppointments("Karfreitag", " 2008/03/21")
Call subOutlookAppointments("Karfreitag", " 2009/04/10")
Call subOutlookAppointments("Karfreitag", " 2010/04/02")
Call subOutlookAppointments("Karfreitag", " 2011/04/22")
Call subOutlookAppointments("Karfreitag", " 2012/04/06")
Call subOutlookAppointments("Karfreitag", " 2013/03/29")
Call subOutlookAppointments("Karfreitag", " 2014/04/18")
Call subOutlookAppointments("Karfreitag", " 2015/04/03")
Call subOutlookAppointments("Maifeiertag", " 2008/05/01")
Call subOutlookAppointments("Maifeiertag", " 2009/05/01")
Call subOutlookAppointments("Maifeiertag", " 2010/05/01")
Call subOutlookAppointments("Maifeiertag", " 2011/05/01")
Call subOutlookAppointments("Maifeiertag", " 2012/05/01")
Call subOutlookAppointments("Maifeiertag", " 2013/05/01")
Call subOutlookAppointments("Maifeiertag", " 2014/05/01")
Call subOutlookAppointments("Maifeiertag", " 2015/05/01")
Call subOutlookAppointments("Mariä Himmelfahrt", " 2008/08/15")
Call subOutlookAppointments("Mariä Himmelfahrt", " 2009/08/15")
Call subOutlookAppointments("Mariä Himmelfahrt", " 2010/08/15")
Call subOutlookAppointments("Mariä Himmelfahrt", " 2011/08/15")
Call subOutlookAppointments("Mariä Himmelfahrt", " 2012/08/15")
Call subOutlookAppointments("Mariä Himmelfahrt", " 2013/08/15")
Call subOutlookAppointments("Mariä Himmelfahrt", " 2014/08/15")
Call subOutlookAppointments("Mariä Himmelfahrt", " 2015/08/15")
Call subOutlookAppointments("Neujahr", " 2008/01/01")
Call subOutlookAppointments("Neujahr", " 2009/01/01")
Call subOutlookAppointments("Neujahr", " 2010/01/01")
Call subOutlookAppointments("Neujahr", " 2011/01/01")
Call subOutlookAppointments("Neujahr", " 2012/01/01")
Call subOutlookAppointments("Neujahr", " 2013/01/01")
Call subOutlookAppointments("Neujahr", " 2014/01/01")
Call subOutlookAppointments("Neujahr", " 2015/01/01")
Call subOutlookAppointments("Ostermontag", " 2008/03/24")
Call subOutlookAppointments("Ostermontag", " 2009/04/13")
Call subOutlookAppointments("Ostermontag", " 2010/04/05")
Call subOutlookAppointments("Ostermontag", " 2011/04/25")
Call subOutlookAppointments("Ostermontag", " 2012/04/09")
Call subOutlookAppointments("Ostermontag", " 2013/04/01")
Call subOutlookAppointments("Ostermontag", " 2014/04/21")
Call subOutlookAppointments("Ostermontag", " 2015/04/06")
Call subOutlookAppointments("Ostersonntag", " 2008/03/23")
Call subOutlookAppointments("Ostersonntag", " 2009/04/12")
Call subOutlookAppointments("Ostersonntag", " 2010/04/04")
Call subOutlookAppointments("Ostersonntag", " 2011/04/24")
Call subOutlookAppointments("Ostersonntag", " 2012/04/08")
Call subOutlookAppointments("Ostersonntag", " 2013/03/31")
Call subOutlookAppointments("Ostersonntag", " 2014/04/20")
Call subOutlookAppointments("Ostersonntag", " 2015/04/05")
Call subOutlookAppointments("Pfingstmontag", " 2008/05/12")
Call subOutlookAppointments("Pfingstmontag", " 2009/06/01")
Call subOutlookAppointments("Pfingstmontag", " 2010/05/24")
Call subOutlookAppointments("Pfingstmontag", " 2011/06/13")
Call subOutlookAppointments("Pfingstmontag", " 2012/05/28")
Call subOutlookAppointments("Pfingstmontag", " 2013/05/20")
Call subOutlookAppointments("Pfingstmontag", " 2014/06/09")
Call subOutlookAppointments("Pfingstmontag", " 2015/05/25")
Call subOutlookAppointments("Pfingstsonntag", " 2008/05/11")
Call subOutlookAppointments("Pfingstsonntag", " 2009/05/31")
Call subOutlookAppointments("Pfingstsonntag", " 2010/05/23")
Call subOutlookAppointments("Pfingstsonntag", " 2011/06/12")
Call subOutlookAppointments("Pfingstsonntag", " 2012/05/27")
Call subOutlookAppointments("Pfingstsonntag", " 2013/05/19")
Call subOutlookAppointments("Pfingstsonntag", " 2014/06/08")
Call subOutlookAppointments("Pfingstsonntag", " 2015/05/24")
Call subOutlookAppointments("Tag d. Dt. Einheit", " 2008/10/03")
Call subOutlookAppointments("Tag d. Dt. Einheit", " 2009/10/03")
Call subOutlookAppointments("Tag d. Dt. Einheit", " 2010/10/03")
Call subOutlookAppointments("Tag d. Dt. Einheit", " 2011/10/03")
Call subOutlookAppointments("Tag d. Dt. Einheit", " 2012/10/03")
Call subOutlookAppointments("Tag d. Dt. Einheit", " 2013/10/03")
Call subOutlookAppointments("Tag d. Dt. Einheit", " 2014/10/03")
Call subOutlookAppointments("Tag d. Dt. Einheit", " 2015/10/03")
'EndRegion
 
WriteLog "---ready--------------------------------------"
 
Set objOutlook = Nothing
 
WScript.quit(0)
 
Sub subGetAppointments(intFrom) 'read appointments into array 
  Dim objNameSpace
  Dim objFolder
  Dim MyItems
  Dim total
  Set objOutlook = CreateObject("Outlook.application")
  Set objNameSpace = objOutlook.GetNameSpace("MAPI")
  Set objFolder = objNameSpace.GetDefaultFolder(olFolderCalender)
  Set MyItems = objFolder.Items
  total = 0
  For Each CurrentAppointment In MyItems
     If DatePart("yyyy", CDate(CurrentAppointment.Start)) >=  intFrom Then
       total = total + 1
       'WScript.echo " " & CurrentAppointment.subject & " -> " & CDate(CurrentAppointment.Start) 
       ReDim preserve arrAppointmentsDate (total)
       ReDim preserve arrAppointmentsSubject (total)
       arrAppointmentsDate(total) = CDate(CurrentAppointment.Start) 
       arrAppointmentsSubject(total) = CurrentAppointment.subject
     End If
  Next
  Set objNameSpace = Nothing
  Set objFolder = Nothing
  Set MyItems = Nothing
End Sub
 
 
Sub subOutlookAppointments(strSub, strdat)
  Dim flagIsSet 
  Dim objKal
  flagIsSet = 0
  For count = 1 To UBound(arrAppointmentsDate)
     If arrAppointmentsDate(count) =  CDate(strdat) And arrAppointmentsSubject(count) = strSub Then
       'WScript.echo " " & strSub & " -> " & CDate(strdat) & "   ... already exist"
       WriteLog " " & strSub & " -> " & CDate(strdat) & "   ... already exist"
       flagIsSet = 1
       Exit For
     End If
  Next
  If flagIsSet = 0 Then
    Set objOutlook = CreateObject("Outlook.application")
    Set objKal = objOutlook.CreateItem(olAppointmentItem)
    objKal.AllDayEvent = vbTrue
    objKal.ReminderSet = vbFalse
    objKal.Categories = "Feiertag"
    objKal.Subject = strSub
    objKal.Start = CDate(strdat)    
    objKal.Save
    'WScript.echo " " & strSub & " -> " & CDate(strdat) & "   ... set"
    WriteLog " " & strSub & " -> " & CDate(strdat) & "   ... set"
    Set objKal = Nothing 
   End If          
End Sub
 
Sub WriteLog(strVal)
  Dim strFile
  Set strFile = objFSO.OpenTextFile(strFullLogPath, ForAppending)
  strFile.WriteLine(Now & " | " & strVal)
  'strFile.WriteLine(strVal)
  strFile.Close
End Sub