Using VBA, is there a way to retrieve the dates from my session's Automatic Replies (Out Of Office)?

Question

I'm trying to develop a macro that would add the dates of the active (or nearest) Out Of Office dates to my signature. Kind of a "Upcoming OOO" signal.

For this, I need to retrieve such dates from the Automatic Replies section.

Is there a way to retrieve them?

Answer 1

Thanks to @Nathan_Sav for the hint. Used the following page for help as well:

https://4sysops.com/archives/automate-out-of-office-messages-in-outlook-with-visual-basic-for-applications-vba/

It works for me, but I had to get rid of the standard signature: still it is useful for me. It works based on upcomings events, rather than the Automatic Replies configuration.

Need to declare inspectors in ThisOutlookSession to trigger on events:

Private WithEvents CsInspect As Outlook.Inspectors

It can be activated on Startup, ...

Private Sub Application_Startup()
    Call General_Handler
End Sub

... or on a specific macro that I can setup as a button:

Public Sub TurnOnSignature()
    Call General_Handler
End Sub

It would be setting the with-events variable...

Private Sub General_Handler()
    Set CsInspect = Application.Inspectors
End Sub

Constants:

Const GrSgnName = "My Name (and position)"
Const GrSgnComp = "My Company"
Const GrSgnLocn = "My Location"
Const GrSngPhon = "My Phone Number"

Const SingGrL = "<br><br>"
Const SingGrE = "</p>"

The function that will build my new signature:

Function GralSignature() As String

Const SignStr = "<span style= 'font-family: Calibri;'>"
Const SignEnd = "</span>"
    
    GrlSignNm = GSignHTML1(GrSgnName, 13, False)
    GrlSignCo = GSignHTML1(GrSgnComp, 12, False)
    GrlSignLc = GSignHTML1(GrSgnLocn, 12, False)
    GrlSignPh = GSignHTML1(GrSngPhon, 12, False)
    GrlSignOO = GSignHTML1(Check_Next_OOOs(20), 12, True)
    GrlSigntr = GrlSignNm & GrlSignOO & GrlSignCo & GrlSignLc & GrlSignPh
    GrlSigntr = SignStr & SingGrL & GrlSigntr & SignEnd

GralSignature = GrlSigntr

End Function

Auxiliary function to add formating to the HTML-based text: Function GSignHTML1(StrConvert As String, StrSz As Long, StrBl As Boolean) As String Dim SingGrS As String

SingGrS = "<p style= 'margin: 0; padding: 0; font-size: " & StrSz & ";"
If StrBl = True Then
    SingGrS = SingGrS & "font-weight: bold;"
End If
    SingGrS = SingGrS & "'>"

GSignHTML1 = SingGrS & StrConvert & SingGrE

End Function

Function to loop on all my upcoming out-of-office events between the current date and the days I specify (calendar-based). It will retrieve the soonest.

Function Check_Next_OOOs(VarDays As Long) As String

Dim OlNSpa_ As NameSpace
Dim OlMeets As Object
Dim OlItems As Items
Dim OlMeet_ As AppointmentItem
Dim DateStr As Date, DateEnd As Date, StrDStr As String, StrDEnd As String
Dim DateFlt As String, OOOStr As Date, OOOEnd As Date, SuccFlag As Boolean

DateStr = Date
DateEnd = Date + VarDays
StrDStr = "[START] >= " & Chr(34) & DateStr & Chr(34)
StrDEnd = "[END] <= " & Chr(34) & DateEnd & Chr(34)
DateFlt = StrDStr & " AND " & StrDEnd

Check_Next_OOOs = DateStr & "-" & DateEnd

Set OlNSpa_ = Application.GetNamespace("MAPI")
Set OlMeets = OlNSpa_.GetDefaultFolder(olFolderCalendar)
Set OlItems = OlMeets.Items.Restrict(DateFlt)
    OlItems.Sort "[START]"

For Each OlMeet_ In OlItems
    With OlMeet_
        If .BusyStatus = 3 Then
            Debug.Print .Subject, .Start, .End
            OOOStr = .Start
            OOOEnd = .End
            SuccFlag = True
            Exit For
        End If
    End With
Next OlMeet_

If SuccFlag = True Then
    If Format(OOOEnd, "hh:mm:ss") = "00:00:00" Then
        OOOEnd = OOOEnd - 1
    End If
Check_Next_OOOs = Format(OOOStr, "yyyy mmm dd") & " - " & Format(OOOEnd, "yyyy mmm dd")
Check_Next_OOOs = "OOO " & Check_Next_OOOs

Else: Check_Next_OOOs = ""
End If

End Function

Finally, the result:

Thanks!