I have a piece of code that is supposed to find all appointments in a shared calendar between two dates and delete them. However, it ignores the filter and deletes all appointments in the calendar. Could someone take a look at this and give me some idea of what i'm missing please?
Sub DeleteCal_Appts(sCalendarName As String, ap_dateStart As String, ap_startTime As String, ap_dateEnd As String, ap_endTime As String)
Dim objAppointment As AppointmentItem
Dim objAppointments As Items
Dim objNameSpace As Outlook.NameSpace
Dim objRecip As Recipient
Dim sFilter As Object
Dim dtStartTime As Date, dtEndTime As Date
dtStartTime = CDate(ap_dateStart & " " & ap_startTime)
dtEndTime = CDate(ap_dateEnd & " " & ap_endTime)
Dim myOutApp As Object
myOutApp = CreateObject("Outlook.Application")
objNameSpace = myOutApp.GetNamespace("MAPI")
objRecip = objNameSpace.CreateRecipient(sCalendarName)
objRecip.Resolve()
'objAppointments = objNameSpace.GetSharedDefaultFolder(objNameSpace.CreateRecipient("Unit 2 Peanut Delivery Calendar"), 9).Items
objAppointments = objNameSpace.GetSharedDefaultFolder(objNameSpace.CreateRecipient(sCalendarName), 9).Items
sFilter = "[Start] > '" & Format(dtStartTime, "ddddd h:nn AMPM") & "' And [Start] < '" & Format(dtEndTime, "ddddd h:nn AMPM") & "'"
objAppointments.Sort("[Start]", False)
MsgBox("Total Items at begin: " & objAppointments.Count)
objAppointment = objAppointments.Find(sFilter)
For i = objAppointments.Count To 1 Step -1
objAppointment = objAppointments.Item(i)
objAppointment.Delete()
Next
MsgBox("Total Items at finish: " & objAppointments.Count)
objAppointment = Nothing
objAppointments = Nothing
End Sub
Thanks to #TnTinMn got the answer to this. My only remaining stumbling block was for the date conversion from UK to US:
sFilter = "[Start] >= '" & (dtStartTime.ToString("MM/dd/yyyy HH:MM tt")) & "' AND [End] <= '" & (dtEndTime.ToString("MM/dd/yyyy HH:MM tt")) & "'"
objAppointments.Sort("[Start]", False)
itemsCalendar = objAppointments.Restrict(sFilter)
For i = itemsCalendar.Count To 1 Step -1
objAppointment = itemsCalendar.Item(i)
objAppointment.Delete()
Next
Related
I have been trying to bring this piece of code I found here up to date and make it work for my objective but I keep receiving an error where it expects olFolderCalendar to be a variable and it is undefined. Does anyone have any suggestions please?
Private Sub Button2_Click(sender As Object, e As EventArgs) Handles Button2.Click
DeleteCal_Appts("Test Shared Calendar", "12/8/2020", "0:00:01", "12/9/2020", "23:59:59")
End Sub
Sub DeleteCal_Appts(sCalendarName As String, ap_dateStart As String, ap_startTime As String, ap_dateEnd As String, ap_endTime As String)
Dim objAppointment As AppointmentItem
Dim objAppointments As Items
Dim objNameSpace As Outlook.NameSpace
Dim objRecip As Recipient
Dim nInc As Integer
Dim sFilter As VariantType
Dim dtStartTime As Date, dtEndTime As Date
dtStartTime = CDate(ap_dateStart & " " & ap_startTime)
dtEndTime = CDate(ap_dateEnd & " " & ap_endTime)
Dim myOutApp As Object
myOutApp = GetObject("Outlook.Application")
objNameSpace = myOutApp.GetNamespace("MAPI")
objRecip = objNameSpace.CreateRecipient(sCalendarName)
objRecip.Resolve()
objAppointments = objNameSpace.GetSharedDefaultFolder(objNameSpace.CreateRecipient("Owner User"), olFolderCalendar).Items
sFilter = "[Start] > '" & Format(dtStartTime, "ddddd h:nn AMPM") &
"' And [Start] < '" & Format(dtEndTime, "ddddd h:nn AMPM") & "'"
objAppointments.Sort("[Start]", False)
MsgBox("Total Items at begin: " & objAppointments.Count)
objAppointment = objAppointments.Find(sFilter)
While TypeName(objAppointment) <> "Nothing"
'If MsgBox(objAppointment.Subject & vbCrLf & "Delete " & objRec.AddressEntry & " item now? ", vbYesNo, "Delete Calendar Item") = vbYes Then
objAppointment.Delete()
nInc = nInc + 1
'End If
objAppointment = objAppointments.FindNext
End While
MsgBox("Deleted " & nInc & " calendar items.", vbInformation, "Delete done")
MsgBox("Total Items at finish: " & objAppointments.Count)
objAppointment = Nothing
objAppointments = Nothing
End Sub
I mean to get all AppointmentItems in a Date range and return them as a Collection.
This is the function I wrote
Function GetAppointmentItemsDatesRange(ByVal dstart As Date, ByVal dend As Date) As Outlook.Items
'=======================================================
' Get all AppointmentItem in a range of dates
'=======================================================
Dim oCalendar As Outlook.Folder
Set oCalendar = Application.Session.GetDefaultFolder(olFolderCalendar)
Dim objItems As Outlook.Items
Dim objRestrictedItems As Outlook.Items
Set objItems = oCalendar.Items
objItems.IncludeRecurrences = True
'objItems.IncludeRecurrences = False
objItems.Sort "[Start]"
Dim filterRange As String
filterRange = "[Start] >= " & Chr(34) & Format(dstart, "dd/mm/yyyy hh:mm AM/PM") & Chr(34) & " AND " & _
"[End] <= " & Chr(34) & Format(dend, "dd/mm/yyyy hh:mm AM/PM") & Chr(34) ' <-- Line #1'
Set objRestrictedItems = objItems.Restrict(filterRange)
Debug.Print "Filter : " & filterRange
Dim oItem As Outlook.AppointmentItem
Dim iIt As Long
Dim nItFilter As Long, nIt As Long
nItFilter = objRestrictedItems.Count
nIt = 0
Debug.Print nItFilter & " total items"
For Each oItem In objRestrictedItems
If (Not (oItem Is Nothing)) Then
nIt = nIt + 1
Debug.Print oItem.Start & "-" & oItem.End ' <-- Line #2'
End If
Next oItem
Debug.Print nIt & " net items"
Set GetAppointmentItemsDatesRange = objRestrictedItems
End Function
I tried with both .IncludeRecurrences = True and False.
This is the output I get.
False:
Filter : [Start] >= "07/11/2020 05:30 PM" AND [End] <= "07/11/2020 06:15 PM"
9 total items
31/12/2015 9:00:00-31/12/2015 9:00:00
31/01/2017 15:30:00-31/01/2017 15:30:00
18/03/2020 12:00:00-18/03/2020 16:00:00
13/04/2020 8:45:00-13/04/2020 9:00:00
09/09/2020 11:00:00-09/09/2020 12:00:00
28/09/2020 14:45:00-28/09/2020 18:00:00
01/10/2020 13:30:00-01/10/2020 15:00:00
07/11/2020 17:30:00-07/11/2020 17:45:00
07/11/2020 17:45:00-07/11/2020 18:15:00
9 net items
True:
Filter : [Start] >= "07/11/2020 05:30 PM" AND [End] <= "07/11/2020 06:15 PM"
2147483647 total items
07/11/2020 17:30:00-07/11/2020 17:45:00
07/11/2020 17:45:00-07/11/2020 18:15:00
2 net items
So I identify two problems to get to my result:
The outputs of Line #1 and Line #2 seem inconsistent, in both cases.
I do not understand why are the first 7 items not filtered out in the False case, even if I can get rid of them with True.
And I do not understand what are those too many Nothing items in the True case.
I do not know hot to define a Collection where I can add the items that satisfy the If (Not (oItem Is Nothing)) condition, so I can return it upon exiting for the caller to use.
What is the explanation for the questions?
How can I achieve my goal?
Since you found a way to identify the required items, add them to a new collection. Pass that collection to the caller.
Option Explicit
Sub collNotNothingItems()
Dim dtSt As Date
Dim dtEn As Date
Dim notNothingItems As Collection
Dim i As Long
dtSt = Date - 7
dtEn = Date
Set notNothingItems = GetAppointmentItemsDatesRange(dtSt, dtEn)
Debug.Print notNothingItems.count & " in the collection passed to the caller"
For i = 1 To notNothingItems.count
With notNothingItems(i)
Debug.Print .Start & "-" & .End
End With
Next
End Sub
Function GetAppointmentItemsDatesRange(ByVal dstart As Date, ByVal dend As Date) As Collection
'=======================================================
' Get all AppointmentItem in a range of dates
'=======================================================
Dim oCalendar As Folder
Dim objItems As Items
Dim objRestrictedItems As Items
Dim filterRange As String
Dim myItems As Collection
Dim oItem As AppointmentItem
Dim iIt As Long
Dim nItFilter As Long
Dim nIt As Long
Set oCalendar = Application.Session.GetDefaultFolder(olFolderCalendar)
Set objItems = oCalendar.Items
objItems.IncludeRecurrences = True
objItems.Sort "[Start]"
'filterRange = "[Start] >= " & Chr(34) & Format(dstart, "dd/mm/yyyy hh:mm AM/PM") & Chr(34) & " AND " & _
"[End] <= " & Chr(34) & Format(dend, "dd/mm/yyyy hh:mm AM/PM") & Chr(34)
filterRange = "[Start] >= " & Chr(34) & Format(dstart, "yyyy-mm-dd hh:mm AM/PM") & Chr(34) & " AND " & _
"[End] <= " & Chr(34) & Format(dend, "yyyy-mm-dd hh:mm AM/PM") & Chr(34)
Debug.Print "filterRange: " & filterRange
Set objRestrictedItems = objItems.Restrict(filterRange)
nItFilter = objRestrictedItems.count
Debug.Print nItFilter & " total items"
nIt = 0
Set myItems = New Collection
For Each oItem In objRestrictedItems
If (Not (oItem Is Nothing)) Then
nIt = nIt + 1
Debug.Print oItem.Start & "-" & oItem.End
myItems.Add oItem
End If
Next oItem
Debug.Print nIt & " net items"
Set GetAppointmentItemsDatesRange = myItems
End Function
I am extracting all appointments across all Outlook accounts for today.
I am experiencing the same issue encountered in this post here, but I am trying to do this through VBA.
Originally I managed to get the appointments for today, but it would also return reoccurring meetings that are not taking place today (like in the linked question).
I do not understand how the Powershell code, in the answer, manages to filter out the reoccurring appointments, because in my VBA attempt I get the whole week of appointments.
This is my attempt. I've included the filter where I get the appointments for today as well the reoccurring appointments which do not take place today.
Sub GetAllCalendarAppointmentsForToday()
Dim olApplication As Outlook.Application
Dim olNamespace As NameSpace
Dim olAccounts As Accounts
Dim olStore As Outlook.Store
Dim olCalendarFolder As Outlook.Folder
Dim olCalendarItems As Outlook.Items
Dim olTodayCalendarItems As Outlook.Items
Dim strFilter As String
Dim strFilter2 As String
Set olApplication = CreateObject("Outlook.Application")
Set olNamespace = olApplication.Session
Set olAccounts = olNamespace.Accounts
Debug.Print olAccounts.Count
For Each oAccount In olAccounts
Debug.Print oAccount
Set olStore = oAccount.DeliveryStore
Set olCalendarFolder = olStore.GetDefaultFolder(olFolderCalendar)
Set olCalendarItems = olCalendarFolder.Items
olCalendarItems.Sort "[Start]", True
olCalendarItems.IncludeRecurrences = True
Debug.Print olCalendarItems.Count
'Find your today's appointments
strFilter = Format(Now, "ddddd")
strFilter2 = Format(DateAdd("d", 7, Now), "ddddd")
Debug.Print strFilter
Debug.Print strFilter2
'strFilter = "[Start] > " & Chr(34) & strFilter & " 00:00" & Chr(34) & " AND [Start] < " & Chr(34) & strFilter & " 00:00" & Chr(34)
strFilter = "[Start] > " & Chr(34) & strFilter & " 00:00" & Chr(34) & " AND [Start] < " & Chr(34) & strFilter2 & " 00:00" & Chr(34)
Debug.Print strFilter
Set olTodayCalendarItems = olCalendarItems.Restrict(strFilter)
Debug.Print olTodayCalendarItems.Count
Debug.Print "Begin Print of Appointments"
For Each objAppointment In olTodayCalendarItems
Counter = Counter + 1
Debug.Print Counter & ":" & objAppointment.Subject & " " & objAppointment.Location & " [" & objAppointment.Start & "|" & objAppointment.End & "]"
Next
Debug.Print vbNewLine
Next
End Sub
Edit #1:
As per Eugene's answer, I updated the strFilter to be this to no avail
strFilter = [Start] <= '07/15/2020 11:59 PM' AND [End] >= '07/15/2020 12:00 AM'
In addition, I put IncludeReccurence first as well and no change in the results
Edit #2
Replaced the for each loop to use GetFirst() and GetNext() to no avail
Set olTodayCalendarItems = olCalendarItems.Restrict(strFilter)
Set olItem = olTodayCalendarItems.GetFirst()
Do While Not olItem Is Nothing
Set olAppointment = olItem
counter = counter + 1
Debug.Print counter & ":" & olAppointment.Subject & " " & olAppointment.Location & " [" & olAppointment.Start & "|" & olAppointment.End & "]"
Set olItem = olTodayCalendarItems.GetNext()
Loop
Edit #3:
I created a VB.NET application where I used the function, provided in the link in the answer, verbatim and it worked as expected. So maybe there is a issue in VBA (unlikely) or I missed something small in my VBA script?
Edit #4:
The problem was in my logic all along. Items needed to be sorted in ascending. Thank you to both Eugene and niton
The OP left a comment to indicate Restrict is valid.
" ... the link to the docs on IncludeRecurrences ... mentioned that .Sort needs to be done in ascending order"
It is possible .Restrict is not appropriate for this task.
An example using .Find.
Items.IncludeRecurrences property(Outlook) https://learn.microsoft.com/en-us/office/vba/api/outlook.items.includerecurrences
Sub DemoFindNext()
' https://learn.microsoft.com/en-us/office/vba/api/outlook.items.includerecurrences
Dim myNameSpace As Outlook.NameSpace
Dim tdystart As Date
Dim tdyend As Date
Dim myAppointments As Outlook.Items
Dim currentAppointment As Outlook.AppointmentItem
Set myNameSpace = Application.GetNamespace("MAPI")
tdystart = VBA.Format(Now, "Short Date")
tdyend = VBA.Format(Now + 1, "Short Date")
Set myAppointments = myNameSpace.GetDefaultFolder(olFolderCalendar).Items
myAppointments.Sort "[Start]"
myAppointments.IncludeRecurrences = True
Set currentAppointment = myAppointments.Find("[Start] >= """ & tdystart & """ and [Start] <= """ & tdyend & """")
While TypeName(currentAppointment) <> "Nothing"
Debug.Print currentAppointment.Subject
' MsgBox currentAppointment.Subject
Set currentAppointment = myAppointments.FindNext
Wend
End Sub
Microsoft doesn’t recommend using the Count property in case you set the IncludeRecurrences property. The Count property may return unexpected results and cause an infinite loop. Read more about that in the How To: Use Restrict method in Outlook to get calendar items article.
Here is a sample VB.NET code where you can see how you can filter appointment items properly:
Imports System.Text
Imports System.Diagnostics
' ...
Private Sub RestrictCalendarItems(folder As Outlook.MAPIFolder)
Dim dtEnd As DateTime = New DateTime(DateTime.Now.Year, DateTime.Now.Month, _
DateTime.Now.Day, 23, 59, 0, 0)
Dim restrictCriteria As String = "[Start]<=""" + dtEnd.ToString("g") + """" + _
" AND [End]>=""" + DateTime.Now.ToString("g") + """"
Dim strBuilder As StringBuilder = Nothing
Dim folderItems As Outlook.Items = Nothing
Dim resultItems As Outlook.Items = Nothing
Dim appItem As Outlook._AppointmentItem = Nothing
Dim counter As Integer = 0
Dim item As Object = Nothing
Try
strBuilder = New StringBuilder()
folderItems = folder.Items
folderItems.IncludeRecurrences = True
folderItems.Sort("[Start]")
resultItems = folderItems.Restrict(restrictCriteria)
item = resultItems.GetFirst()
Do
If Not IsNothing(item) Then
If (TypeOf (item) Is Outlook._AppointmentItem) Then
counter = counter + 1
appItem = item
strBuilder.AppendLine("#" + counter.ToString() + _
" Start: " + appItem.Start.ToString() + _
" Subject: " + appItem.Subject + _
" Location: " + appItem.Location)
End If
Marshal.ReleaseComObject(item)
item = resultItems.GetNext()
End If
Loop Until IsNothing(item)
If (strBuilder.Length > 0) Then
Debug.WriteLine(strBuilder.ToString())
Else
Debug.WriteLine("There is no match in the " _
+ folder.Name + " folder.")
End If
catch ex As Exception
System.Windows.Forms.MessageBox.Show(ex.Message)
Finally
If Not IsNothing(folderItems) Then Marshal.ReleaseComObject(folderItems)
If Not IsNothing(resultItems) Then Marshal.ReleaseComObject(resultItems)
End Try
End Sub
I'm trying to grab the last week of appointments using VBA in Outlook.
I'm using the .Restrict method, but something is making my string grab 3 years further back.
I start by declaring formatted dates for my time bracket:
myStart = Format(DateAdd("d", -7, Now()), "ddddd h:nn AMPM")
myEnd = Format(Now(), "ddddd h:nn AMPM")
I build a string to hold my restriction criterion.
strRestriction = "[Start] <= '" & myEnd _
& "' AND [End] >= '" & myStart & "'"
Finally I call restrict on my appointment items:
Set oRestrItems = oItems.Restrict(strRestriction)
For a little more context, here's how I use/call the result:
For Each oApptItem In oRestrItems 'oItems will grab everything, but that's hardly perfect.
If oApptItem.Sensitivity <> olPrivate Then
MsgBox (oApptItem.Subject)
MsgBox (oApptItem.Start)
MsgBox (oApptItem.End)
End If
Next
I can guess that you are missing two statements.
oItems.IncludeRecurrences = True
oItems.Sort "[Start]"
If this is the case, you can ask another question about why the Restrict requires these additional statements. Someone may have an answer.
Minimal, Complete, and Verifiable example. Try commenting out either or both statements. You should see that the items are not the same.
Option Explicit
Sub LastWeekAppts()
Dim objFolder As Folder
Dim oItems As items
Dim oRestrItems As items
Dim strRestriction As String
Dim myStart As Date
Dim myEnd As Date
Dim temp As Object
Set objFolder = Session.GetDefaultFolder(olFolderCalendar)
Set oItems = objFolder.items
' *****************************************
' Odd results without these two statements
oItems.IncludeRecurrences = True
oItems.Sort "[Start]"
' *****************************************
myEnd = Date
myStart = DateAdd("d", -7, Date)
Debug.Print " myStart: " & myStart
Debug.Print " myEnd : " & myEnd
strRestriction = "[Start] <= '" & myEnd _
& "' AND [End] >= '" & myStart & "'"
Debug.Print strRestriction
Set oRestrItems = oItems.Restrict(strRestriction)
For Each temp In oRestrItems
Debug.Print temp.start & " - " & temp.Subject
Next temp
End Sub
I sent an outlook (2010) meeting request to all company (4000+) and now I would like to send an additional email to those who accepted the request or accepted tentatively.
How do I do that? When I hit Contact Atendees --> New Email to Atendees in the ribbon it just send a response to all company and not only those who accepted. I also tried to export the contacts but it can only export the name alias and not the entire email addresses.
Any suggestions?
Thanks
The basis of the solution is found here Get Meeting Attendee List Macro
Here it is with minor changes.
Option Explicit
Sub GetAttendeeList()
Dim objApp As Outlook.Application
Dim objItem As Object
Dim objAttendees As Outlook.Recipients
Dim objAttendeeReq As String
Dim objAttendeeOpt As String
Dim objOrganizer As String
Dim dtStart As Date
Dim dtEnd As Date
Dim strSubject As String
Dim strLocation As String
Dim strNotes As String
Dim strMeetStatus As String
Dim strCopyData As String
Dim strCount As String
Dim ino, it, ia, ide
Dim x As Long
Dim ListAttendees As mailitem
'On Error Resume Next
Set objApp = CreateObject("Outlook.Application")
Set objItem = GetCurrentItem()
Set objAttendees = objItem.Recipients
On Error GoTo EndClean:
' Is it an appointment
If objItem.Class <> 26 Then
MsgBox "This code only works with meetings."
GoTo EndClean:
End If
' Get the data
dtStart = objItem.Start
dtEnd = objItem.End
strSubject = objItem.Subject
strLocation = objItem.location
strNotes = objItem.body
objOrganizer = objItem.Organizer
objAttendeeReq = ""
objAttendeeOpt = ""
Set ListAttendees = Application.CreateItem(olMailItem) ' <---
' Get The Attendee List
For x = 1 To objAttendees.count
strMeetStatus = ""
Select Case objAttendees(x).MeetingResponseStatus
Case 0
strMeetStatus = "No Response (or Organizer)"
ino = ino + 1
Case 1
strMeetStatus = "Organizer"
ino = ino + 1
Case 2
strMeetStatus = "Tentative"
it = it + 1
ListAttendees.Recipients.Add objAttendees(x) ' <---
Case 3
strMeetStatus = "Accepted"
ia = ia + 1
ListAttendees.Recipients.Add objAttendees(x) ' <---
Case 4
strMeetStatus = "Declined"
ide = ide + 1
End Select
If objAttendees(x).Type = olRequired Then
objAttendeeReq = objAttendeeReq & objAttendees(x).Name & vbTab & strMeetStatus & vbCrLf
Else
objAttendeeOpt = objAttendeeOpt & objAttendees(x).Name & vbTab & strMeetStatus & vbCrLf
End If
Next
strCopyData = "Organizer: " & objOrganizer & vbCrLf & "Subject: " & strSubject & vbCrLf & _
"Location: " & strLocation & vbCrLf & "Start: " & dtStart & vbCrLf & "End: " & dtEnd & _
vbCrLf & vbCrLf & "Required: " & vbCrLf & objAttendeeReq & vbCrLf & "Optional: " & _
vbCrLf & objAttendeeOpt & vbCrLf & "NOTES " & vbCrLf & strNotes
strCount = "Accepted: " & ia & vbCrLf & _
"Declined: " & ide & vbCrLf & _
"Tentative: " & it & vbCrLf & _
"No response: " & ino
'Set ListAttendees = Application.CreateItem(olMailItem)
ListAttendees.body = strCopyData & vbCrLf & strCount
ListAttendees.Display
ListAttendees.Recipients.ResolveAll ' <---
EndClean:
Set objApp = Nothing
Set objItem = Nothing
Set objAttendees = Nothing
End Sub
Building upon what #niton wrote, I've added support for checking against the Global Address List. This code could be extended to search all address lists available to you by iterating through myAddressLists, however, in most cases, that will probably be more than wanted.
Note that this isn't optimized for speed, but even a list with a few hundred people invited against a GAL of tens of thousands won't take a computer very long to iterate through. Since this doesn't get run very often, the time saved for optimizing this just didn't seem worth it.
Option Explicit
Sub GetAttendeeList()
Dim x As Integer
Dim y As Integer
Dim ino As Integer
Dim it As Integer
Dim ia As Integer
Dim ide As Integer
Dim objApp As Outlook.Application
Dim objItem As Object
Dim objAttendees As Outlook.Recipients
Dim objAttendeeReq As String
Dim objAttendeeOpt As String
Dim strAttendeeName As String
Dim strAttendeeEmail As String
Dim objOrganizer As String
Dim dtStart As Date
Dim dtEnd As Date
Dim strSubject As String
Dim strLocation As String
Dim strNotes As String
Dim strMeetStatus As String
Dim strCopyData As String
Dim strCount As String
Dim strCity As String
Dim folContacts As Outlook.MAPIFolder
Dim oContact As Outlook.ContactItem
Dim colItems As Outlook.Items
Dim oNS As Outlook.NameSpace
Dim ListAttendees As MailItem
Dim strNewRecord As String
Dim myAddressLists As AddressLists
Dim myAddressEntries As AddressEntries
Dim myAddressEntry As AddressEntry
Dim myExchangeUser As ExchangeUser
Dim myExchangeDL As ExchangeDistributionList
Dim myContactItem As ContactItem
On Error Resume Next
Set objApp = CreateObject("Outlook.Application")
Set oNS = Application.GetNamespace("MAPI")
Set folContacts = oNS.GetDefaultFolder(olFolderContacts)
Set colItems = folContacts.Items
Set myAddressLists = oNS.AddressLists
Set myAddressEntries = myAddressLists.Item("Global Address List").AddressEntries
Set objItem = GetCurrentItem()
Set objAttendees = objItem.Recipients
On Error GoTo EndClean:
' Is it an appointment
If objItem.Class <> 26 Then
MsgBox "This code only works with meetings."
GoTo EndClean:
End If
' Get the data
dtStart = objItem.Start
dtEnd = objItem.End
strSubject = objItem.Subject
strLocation = objItem.Location
strNotes = objItem.Body
objOrganizer = objItem.Organizer
objAttendeeReq = ""
objAttendeeOpt = ""
' Get The Attendee List
For x = 1 To objAttendees.Count
strMeetStatus = ""
Select Case objAttendees(x).MeetingResponseStatus
Case 0
strMeetStatus = "No Response (or Organizer)"
ino = ino + 1
Case 1
strMeetStatus = "Organizer"
ino = ino + 1
Case 2
strMeetStatus = "Tentative"
it = it + 1
Case 3
strMeetStatus = "Accepted"
ia = ia + 1
Case 4
strMeetStatus = "Declined"
ide = ide + 1
End Select
strAttendeeName = objAttendees(x).Name
strAttendeeEmail = objAttendees(x).Address
Set oContact = colItems.Find("[Email1Address] = '" & strAttendeeEmail & "'")
If Not oContact Is Nothing Then
Debug.Print "Test", oContact.BusinessAddressCity
strCity = oContact.MailingAddressCity & ", " & oContact.MailingAddressState
End If
If InStr(strAttendeeEmail, "#") = 0 Then
Debug.Print "Searching: " & objAttendees(x).Name
Set myAddressEntry = myAddressEntries.GetFirst()
Do While Not myAddressEntry Is Nothing
If myAddressEntry.Address Like objAttendees(x).Address Then
Debug.Print "Found: " & myAddressEntry.Name
Set myExchangeUser = myAddressEntry.GetExchangeUser()
Set myExchangeDL = myAddressEntry.GetExchangeDistributionList()
Set myContactItem = myAddressEntry.GetContact()
If Not myExchangeUser Is Nothing Then
strAttendeeEmail = myExchangeUser.PrimarySmtpAddress
End If
If Not myExchangeDL Is Nothing Then
strAttendeeEmail = myExchangeDL.PrimarySmtpAddress
End If
If Not myContactItem Is Nothing Then
strAttendeeEmail = myContactItem.Email1Address
End If
GoTo ContactFound
End If
Set myAddressEntry = myAddressEntries.GetNext()
Loop
End If
ContactFound:
strNewRecord = objAttendees(x).Name & vbTab & strAttendeeEmail & vbTab & strMeetStatus & vbTab & strCity & vbCrLf
If objAttendees(x).Type = olRequired Then
objAttendeeReq = objAttendeeReq & strNewRecord
Else
objAttendeeOpt = objAttendeeOpt & strNewRecord
End If
Next
strCopyData = "Organizer: " & objOrganizer & vbCrLf & "Subject: " & strSubject & vbCrLf & _
"Location: " & strLocation & vbCrLf & "Start: " & dtStart & vbCrLf & "End: " & dtEnd & _
vbCrLf & vbCrLf & "Required: " & vbCrLf & objAttendeeReq & vbCrLf & "Optional: " & _
vbCrLf & objAttendeeOpt & vbCrLf & "NOTES " & vbCrLf & strNotes
strCount = "Accepted: " & ia & vbCrLf & _
"Declined: " & ide & vbCrLf & _
"Tentative: " & it & vbCrLf & _
"No response: " & ino
Set ListAttendees = Application.CreateItem(olMailItem)
ListAttendees.Body = strCopyData & vbCrLf & strCount & vbCrLf & Time
ListAttendees.Display
EndClean:
Set objApp = Nothing
Set objItem = Nothing
Set objAttendees = Nothing
End Sub
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
Set objApp = Nothing
End Function