Outlook VBA Code snippet to list all the appointment or any items set on the calendar.
After searching all the items on the calendar a new email will open that lists all the items on the calendar
on the date range specified.
To change the date range just change this parameters:
StringToCheck = "[Start] >= '" & ("02/01/2014 12:00 AM") & _
"' AND [End] <= '" & ("02/28/2014 11:59 PM") & "'"
Or can just insert a user form and set the calendar to pop up, so it will be easier to set the date range.
The recipient will be the email address of the current user running this code snippet.
This will need to enable Developer tab on Outlook and choose to create a new macro to run this code snippet.
It's good to have a list of outlook calendar summary for all the appointments and you can send it to someone or have it printed.
Output of course output depends on what you have inputted to the calendar.
This code snippet below works with Outlook 2010, if you happened to use this code in other version of Outlook your input is greatly appreciated. Please post a comment. :)
Below is a sample of how the output looks like:
Appointment No.1
Subject: Buy Ice Cream
Duration:60
Date and Time:2/1/2014 5:00: PM
Appointment No.2
Subject: Relax and Watch Movie
Duration:120
Date and Time:2/3/2014 6:00:00 PM
Appointment No.3
Subject: Go to the beach
Duration:180
Date and Time:2/5/2014 8:00:00 AM
Code Snippet::
Public Sub Get_Calendar_Item()
Dim Report() As String
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
'Construct filter for the next 30-day date range
'Change the date as desired
StringToCheck = "[Start] >= '" & ("02/01/2014 12:00 AM") & _
"' AND [End] <= '" & ("02/28/2014 11:59 PM") & "'"
Set olRecItems = olNS.GetDefaultFolder(olFolderCalendar)
Set olFilterRecITems = olRecItems.Items
olFilterRecITems.IncludeRecurrences = True
olFilterRecITems.Sort "[Start]"
Set xItems = olFilterRecITems.Restrict(StringToCheck)
For Each oappt In xItems
yy = yy + 1
ReDim Preserve Report(xx)
Report(xx) = "Appointment No." & yy & _
vbcrlf & "Subject:" & oappt.Subject & vbcrlf & _
"Duration:" & oappt.Duration & vbcrlf & _
"Date and Time:" & oappt.Start
xx = xx + 1
Next
With objOutlookMsg
.Subject = "Outlook Appointment Calendar Summary"
Set MyAddress = Session.CurrentUser.AddressEntry
.Recipients.Add (MyAddress.Address)
.Recipients.ResolveAll
For i = LBound(Report) To UBound(Report)
.Body = .Body & vbCrLf & Report(i) & vbCrLf
Next i
End With
objOutlookMsg.Display
objOutlookMsg.Save
Set objOutlook = Nothing
End Sub
Comments
Post a Comment