Private Sub Application_Startup()
Call SetOutOfOfficeBasedOnCalendar
End Sub
Sub SetOutOfOfficeBasedOnCalendar()
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olFolder As Outlook.Folder
Dim olItems As Outlook.Items
Dim olAppt As Outlook.AppointmentItem
Dim i As Integer
Dim outOfOfficeStart As Date
Dim outOfOfficeEnd As Date
Dim subject As String
Dim autoReplyMessage As String
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.GetDefaultFolder(olFolderCalendar)
Set olItems = olFolder.Items
olItems.Sort "[Start]", True
olItems.IncludeRecurrences = True
Dim filter As String
filter = "[Start] <= '" & Format(Date + 5, "ddddd h:nn AMPM") & "' AND [End] >= '" & Format(Date, "ddddd h:nn AMPM") & "' AND [Categories] = 'Freie Tage (Ferien)'"
Dim olFilteredItems As Outlook.Items
Set olFilteredItems = olItems.Restrict(filter)
If olFilteredItems.count > 0 Then
Set olAppt = olFilteredItems.GetFirst
outOfOfficeStart = olAppt.Start
outOfOfficeEnd = olAppt.End
subject = "Abwesend: " & olAppt.subject
autoReplyMessage = "Ich bin vom " & Format(outOfOfficeStart, "dddd, mmmm dd, yyyy h:nn AM/PM") & " zum " & Format(outOfOfficeEnd, "dddd, mmmm dd, yyyy h:nn AM/PM") & " abwesend. Ihre E-Mail wird nicht bearbeitet."
SetAutomaticReplies outOfOfficeStart, outOfOfficeEnd, autoReplyMessage
Else
MsgBox "No 'Freie Tage (Ferien)' entries found in the next 5 days.", vbInformation
End If
Set olAppt = Nothing
Set olFilteredItems = Nothing
Set olItems = Nothing
Set olFolder = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Sub
Sub SetAutomaticReplies(startDate As Date, endDate As Date, replyMessage As String)
Dim oSession As Object
Dim oAccount As Object
Dim oAutoReply As Object
Set oSession = CreateObject("Outlook.Application").Session
Set oAccount = oSession.Accounts.Item(1)
Set oAutoReply = oAccount.AutoReply
With oAutoReply
.StartTime = startDate
.EndTime = endDate
.InternalReplyMessage = replyMessage
.ExternalReplyMessage = replyMessage
.Enabled = True
End With
oAutoReply.Save
Set oAutoReply = Nothing
Set oAccount = Nothing
Set oSession = Nothing
End Sub