I am trying to download an Excel attachment with the subject keyword.
I managed to create a code but sometimes it is giving Error 440 "Array Index out of Bounds".
The code got stuck in this part.
If Items(i).Class = Outlook.OlObjectClass.OlMail Then
Here is the code
Sub Attachment()
Dim N1 As String
Dim En As String
En = CStr(Environ("USERPROFILE"))
saveFolder = En & "\Desktop\"
N1 = "Mail Attachment"
If Len(Dir(saveFolder & N1, vbDirectory)) = 0 Then
MkDir (saveFolder & N1)
End If
Call Test01
End Sub
Private Sub Test01()
Dim Inbox As Outlook.Folder
Dim obj As Object
Dim Items As Outlook.Items
Dim Attach As Object
Dim MailItem As Outlook.MailItem
Dim i As Long
Dim Filter As String
Dim saveFolder As String, pathLocation As String
Dim dateFormat As String
Dim dateCreated As String
Dim strNewFolderName As String
Dim Creation As String
Const Filetype1 As String = "xlsx"
Const Filetype2 As String = "xlsm"
Const Filetype3 As String = "xlsb"
Const Filetype4 As String = "xls"
Dim Env As String
Env = CStr(Environ("USERPROFILE"))
saveFolder = Env & "\Desktop\Mentor Training\"
Set Inbox = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
'If Inbox.Items.Restrict("[UnRead] = True").Count = 0 Then
' MsgBox "No Mentor Training Mail In Inbox"
' Exit Sub
'End If
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " >= '4/2/2017' AND " & _
Chr(34) & "urn:schemas:httpmail:hasattachment" & _
Chr(34) & "=1 AND" & Chr(34) & _
Chr(34) & "urn:schemas:httpmail:read" & _
Chr(34) & "= 0"
Set Items = Inbox.Items.Restrict(Filter)
For i = 1 To Items.Count
If Items(i).Class = Outlook.OlObjectClass.olMail Then
Set obj = Items(i)
Debug.Print obj.subject
For Each Attach In obj.Attachments
If Right(LCase(Attach.fileName), Len(Filetype1)) = Filetype1 Then 'For searching only excel files
dateFormat = Format(obj.ReceivedTime(), "dd-mm-yyyy hh-mm")
Attach.SaveAsFile saveFolder & "(" & dateFormat & ")" & " " & Attach
End If
If Right(LCase(Attach.fileName), Len(Filetype2)) = Filetype2 Then 'For searching only excel files
dateFormat = Format(obj.ReceivedTime(), "dd-mm-yyyy hh-mm")
Attach.SaveAsFile saveFolder & "(" & dateFormat & ")" & " " & Attach
End If
If Right(LCase(Attach.fileName), Len(Filetype3)) = Filetype3 Then 'For searching only excel files
dateFormat = Format(obj.ReceivedTime(), "dd-mm-yyyy hh-mm")
Attach.SaveAsFile saveFolder & "(" & dateFormat & ")" & " " & Attach
End If
If Right(LCase(Attach.fileName), Len(Filetype4)) = Filetype4 Then 'For searching only excel files
dateFormat = Format(obj.ReceivedTime(), "dd-mm-yyyy hh-mm")
Attach.SaveAsFile saveFolder & "(" & dateFormat & ")" & " " & Attach
End If
obj.UnRead = False
DoEvents
obj.Save
Next
End If
Next
MsgBox "Attachment Saved"
End Sub
It was my understanding that arrays in vba started at 0 by default. So if there is only one item in the list it will be located at Items(0). And since your for statement starts by looking at Items(1) it will throw that error. Changing it to:
For i = 0 To Items.Count - 1
should work I believe.
The filter may return zero items.
Set Items = Inbox.Items.Restrict(Filter)
If Items.Count > 0 then
For i = 1 To Items.Count
No need for setting up multiple dot objects simply use
If Items(i).Class = olMail Then
You may also wanna set your objects to nothing, once your done with them...
Set Inbox = Nothing
Set obj = Nothing
Set Items = Nothing
Set Attach = Nothing
Set MailItem = Nothing
End Sub
Related
Yesterday we have finalized and tested the code (the first part of the code is VBScript) and the second part of the code is (in Excel VBA) to move file from one source folder to one destination folder successfully based on two hour delay (i.e. each file which will come to source folder will upload 2 hour delay), however the situation is that i have actually 15 source folders and 15 destination folders.
One method is that i should create 15 VBScript files and 15 Excel files that contains the code for each source and destination folder which i believe is not efficient way. I have tried a lot to add multiple source and destination folder options in the below mentioned code(s) but i am not successful, can anyone help me, i will be thankful.
the below mentioned code is VBscript
Dim oExcel, strWB, nameWB, wb
strWB = "E:\Delta\Folder monitor.xlsm"
nameWB = Left(strWB, InStr(StrReverse(strWB), "\") - 1)
nameWB = Right(strWB, Len(nameWB))
Set objExcel = GetObject(,"Excel.Application")
Set wb = objExcel.Workbooks(nameWB)
if wb is nothing then wbscript.quit 'the necessary workbook is not open...
dim strComputer, strDirToMonitor, strTime, objWMIService, colMonitoredEvents, objEventObject, MyFile
strComputer = "."
'# WMI needs two backslashes (\\) as path separator and each of it should be excaped.
'# So, you must use 4 backslashes (\\\\) as path separator!
strDirToMonitor = "E:\\\\Delta\\\\Source" 'use here your path
'# Monitor Above every 10 secs...
strTime = "10"
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colMonitoredEvents = objWMIService.ExecNotificationQuery _
("SELECT * FROM __InstanceOperationEvent WITHIN " & strTime & " WHERE " _
& "Targetinstance ISA 'CIM_DirectoryContainsFile' and " _
& "TargetInstance.GroupComponent= " _
& "'Win32_Directory.Name=" & Chr(34) & strDirToMonitor & Chr(34) & "'")
Do While True
Set objEventObject = colMonitoredEvents.NextEvent()
Select Case objEventObject.Path_.Class
Case "__InstanceCreationEvent"
' msgbox "OK"
'MsgBox "A new file was just created: " & _
MyFile = StrReverse(objEventObject.TargetInstance.PartComponent)
'// Get the string to the left of the first \ and reverse it
MyFile = (StrReverse(Left(MyFile, InStr(MyFile, "\") - 1)))
MyFile = Mid(MyFile, 1, Len(MyFile) - 1)
'send the information to the waiting workbook:
objExcel.Application.Run "'" & strWB & "'!GetMonitorInformation", Array(MyFile,Now)
End Select
Loop
and the second code for this purpose should be copied in a standard module:
Option Explicit
Private Const ourScript As String = "FolderMonitor.vbs"
Private Const fromPath As String = "E:\Delta\Source\"
Sub startMonitoring()
Dim strVBSPath As String
strVBSPath = ThisWorkbook.Path & "\VBScript\" & ourScript
TerminateMonintoringScript 'to terminate monitoring script, if running..
Shell "cmd.exe /c """ & strVBSPath & """", 0
End Sub
Sub TerminateMonintoringScript()
Dim objWMIService As Object, colItems As Object, objItem As Object, Msg
As String
Set objWMIService = GetObject("winmgmts:\\" & "." & "\root\CIMV2")
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Process", "WQL", 48)
For Each objItem In colItems
If objItem.Caption = "wscript.exe" Then
'// msg Contains the path of the exercutable script and the script name
On Error Resume Next
Msg = objItem.CommandLine 'for the case of null
On Error GoTo 0
'// If wbscript.exe runs the monitoring script:
If InStr(1, Msg, ourScript) > 0 Then
Debug.Print "Terminate Wscript process..."
objItem.Terminate 'terminate process
End If
End If
Next
Set objWMIService = Nothing: Set colItems = Nothing
End Sub
Sub GetMonitorInformation(arr As Variant)
'call DoSomething Sub after 2 hours (now IT WILL RUN AFTER 1 MINUTE, for testing reasons...)
'for running after 2 hours you should change "00:01:00" in "02:00:00":
arr(0) = Replace(arr(0), "'", "''") 'escape simple quote (') character'
Application.OnTime CDate(arr(1)) + TimeValue("00:01:00"), "'DoSomething """ & CStr(arr(0)) & """'"
Debug.Print "start " & Now 'just for testing (wait a minute...)
'finaly, this line should be commented.
End Sub
Sub DoSomething(strFileName As String)
Const toPath As String = "E:\Delta\Destination\"
If Dir(toPath & strFileName) = "" Then
Name fromPath & strFileName As toPath & strFileName
Debug.Print strFileName & " moved from " & fromPath & " to " & toPath 'just for testing...
Else
MsgBox "File """ & toPath & strFileName & """ already exists in this location..."
End If
End Sub
you can see the previous query here on the link Previous Query
Please, use the next scenario. It assumes that you will fill the necessary path in an existing Excel sheet. Since, it will take the necessary paths based on a cell selection, it is necessary to name the sheet in discussion as "Folders". In Column A:A you should fill the 'Source' folder path (ending in backslash "") and in B:B, the 'Destination' folder path (also ending in backslash).
The proposed solution takes the necessary paths based on your selection in A:A column. The 'Destination' path is extracted based on the selection row.
Please, replace the existing string with the next one, adapting the two necessary paths:
Dim oExcel, strWB, nameWB, wb
strWB = "C:\Teste VBA Excel\Folder monitor.xlsm" 'use here your workbook path!!!
nameWB = Left(strWB, InStr(StrReverse(strWB), "\") - 1)
nameWB = Right(strWB, Len(nameWB))
Set objExcel = GetObject(,"Excel.Application")
Set wb = objExcel.Workbooks(nameWB)
if wb is nothing then wbscript.quit 'the necessary workbook is not open...
dim strComputer, strDirToMonitor, strTime, objWMIService, colMonitoredEvents, objEventObject, MyFile
strComputer = "."
'# WMI needs two backslashes (\\) as path separator and each of it should be excaped.
'# So, you must use 4 backslashes (\\\\) as path separator!
strDirToMonitor = "C:\\\\test\\\\test" 'use here your path !!!
'# Monitor Above every 10 secs...
strTime = "10"
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colMonitoredEvents = objWMIService.ExecNotificationQuery _
("SELECT * FROM __InstanceOperationEvent WITHIN " & strTime & " WHERE " _
& "Targetinstance ISA 'CIM_DirectoryContainsFile' and " _
& "TargetInstance.GroupComponent= " _
& "'Win32_Directory.Name=" & Chr(34) & strDirToMonitor & Chr(34) & "'")' and " _
' & "'Win32_Directory.Name=" & Chr(34) & strDirToMonitor & Chr(34) & "'")
Do While True
Set objEventObject = colMonitoredEvents.NextEvent()
Select Case objEventObject.Path_.Class
Case "__InstanceCreationEvent"
MyFile = StrReverse(objEventObject.TargetInstance.PartComponent)
' Get the string to the left of the first \ and reverse it
MyFile = (StrReverse(Left(MyFile, InStr(MyFile, "\") - 1)))
MyFile = Mid(MyFile, 1, Len(MyFile) - 1)
'send the information to the waiting workbook:
objExcel.Application.Run "'" & strWB & "'!GetMonitorInformation", Array(MyFile, Now, strDirToMonitor)
End Select
Loop
The adapted script sends also the source path to the waiting workbook...
TerminateMonintoringScript Sub remains exactly as it is.
Please, copy the next adapted code instead of existing one, in the used standard module (TerminateMonintoringScript included, even not modified):
Option Explicit
Private Const ourScript As String = "FolderMonitor.vbs"
Private fromPath As String, toPath As String
Sub startMonitoring()
Dim strVBSPath As String, actCell As Range, strTxt As String, pos As Long, endP As Long, oldPath As String
Set actCell = ActiveCell
If actCell.Parent.Name <> "Folders" Then MsgBox "Wrong activated sheet...": Exit Sub
fromPath = actCell.Value
If actCell.Column <> 1 Or Dir(fromPath, vbDirectory) = "" Then Exit Sub 'not a valid path in the selected cell
strVBSPath = ThisWorkbook.Path & "\VBScript\" & ourScript
'change the script necessary "strDirToMonitor" variable path, if the case:__________________________
strTxt = ReadFile(strVBSPath)
pos = InStr(strTxt, Replace(fromPath, "\", "\\\\"))
If pos = 0 Then 'if not the correct path already exists
pos = InStr(strTxt, "strDirToMonitor = """) 'start position of the existing path
endP = InStr(strTxt, """ 'use here your path") 'end position of the existing path
'extract existing path:
oldPath = Mid(strTxt, pos + Len("strDirToMonitor = """), endP - (pos + Len("strDirToMonitor = """)))
strTxt = Replace(strTxt, oldPath, _
Replace(Left(fromPath, Len(fromPath) - 1), "\", "\\\\")) 'replacing existing with the new one
'drop back the updated string in the vbs file:
Dim iFileNum As Long: iFileNum = FreeFile
Open strVBSPath For Output As iFileNum
Print #iFileNum, strTxt
Close iFileNum
End If
'__________________________________________________________________________________________________
TerminateMonintoringScript 'to terminate monitoring script, if running...
Application.Wait Now + TimeValue("00:00:02") 'to be sure that the next line will load the updated file...
Shell "cmd.exe /c """ & strVBSPath & """", 0 'run the VBScript
End Sub
Function ReadFile(strFile As String) As String 'function to read the vbscript string content
Dim iTxtFile As Integer
iTxtFile = FreeFile
Open strFile For Input As iTxtFile
ReadFile = Input(LOF(iTxtFile), iTxtFile)
Close iTxtFile
End Function
Sub TerminateMonintoringScript()
Dim objWMIService As Object, colItems As Object, objItem As Object, Msg As String
Set objWMIService = GetObject("winmgmts:\\" & "." & "\root\CIMV2")
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Process", "WQL", 48)
For Each objItem In colItems
If objItem.Caption = "wscript.exe" Then
'// msg Contains the path of the exercutable script and the script name
On Error Resume Next
Msg = objItem.CommandLine 'for the case of null
On Error GoTo 0
'// If wbscript.exe runs the monitoring script:
If InStr(1, Msg, ourScript) > 0 Then
Debug.Print "Terminate Wscript process..."
objItem.Terminate 'terminate process
End If
End If
Next
Set objWMIService = Nothing: Set colItems = Nothing
End Sub
Sub GetMonitorInformation(arr As Variant)
'call DoSomething Sub after 2 hours (now IT WILL RUN AFTER 1 MINUTE, for testing reasons...)
'for running after 2 hours you should change "00:01:00" in "02:00:00":
arr(0) = Replace(arr(0), "'", "''") 'escape simple quote (') character'
fromPath = Replace(arr(2), "\\\\", "\")
Dim rngFrom As Range: Set rngFrom = ThisWorkbook.Sheets("Folders").Range("A:A").Find(what:=fromPath)
toPath = rngFrom.Offset(, 1).Value
Application.OnTime CDate(arr(1)) + TimeValue("00:00:30"), "'DoSomething """ & fromPath & "\" & CStr(arr(0)) & """, """ & toPath & CStr(arr(0)) & """'"
Debug.Print Now; " start " & arr(0) & fromPath & "\" & CStr(arr(0)) 'just for testing (wait a minute...)
'finaly, this line should be commented.
End Sub
Sub DoSomething(sourceFileName As String, destFilename As String)
If Dir(destFilename) = "" Then
Name sourceFileName As destFilename
Debug.Print sourceFileName & " moved to " & destFilename 'just for testing...
Else
Debug.Print "File """ & destFilename & """ already exists in this location..."
End If
End Sub
Sub DoSomething_(strFileName As String) 'cancelled
If Dir(toPath & strFileName) = "" Then
Name fromPath & strFileName As toPath & strFileName
Debug.Print strFileName & " moved from " & fromPath & " to " & toPath 'just for testing...
Else
MsgBox "File """ & toPath & strFileName & """ already exists in this location..."
End If
End Sub
So, you only need to replace the existing VBA code with the above adapted one, to place the 'source'/'destination' paths in columns A:B of one of Excel sheets, which to be named "Folders".
Select in column A:A a 'Source' cell and run startMonitoring.
Play with files creation and check their moving from the new 'source' to the new 'destination'...
But you have to understand that only a session of the WMI class can run at a specific moment. This means that you cannot simultaneously monitor more than one folder...
I am still documenting regarding the possibility to use a query able to be common for multiple folders. But I never could see such an approach till now and it may not be possible...
I wrote code to pick up unread email and with other criteria.
The code runs but For Each itm In olFolder.Items.Restrict(sFilter) is not working.
For example if there are 4 unread emails in the inbox the For Each should loop 4 times but the loop is happening only 2 times.
Sub ReadOutlookEmails_WithCriteria()
Dim olApp As Outlook.Application, olNs As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder, olMail As Outlook.MailItem
Dim eFolder As Outlook.Folder '~~> additional declaration
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim objAtt As Outlook.Attachment
Dim olItem As Outlook.MailItem
Dim olReply As MailItem ' Reply
Dim olRecip As Recipient
Dim i As Long
Dim x As Date, ws As Worksheet '~~> declare WS variable instead
Dim lrow As Long '~~> additional declaration
Set ws = ActiveSheet '~~> or you can be more explicit using the next line
Set EC = ThisWorkbook.Sheets("Email Search Criteria")
Set IE = ThisWorkbook.Sheets("Inbox Emails")
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("Rejected Emails")
Todays_Date = EC.Range("E2").Value
IE.Rows("2:10000").Clear
Incr = 2
For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders
If eFolder = "Mandatory Training Enrollment" Then 'IF_Check_1
Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders(eFolder.Name): Debug.Print olFolder
sFilter = "[ReceivedTime] >= '" & Todays_Date & "' AND [UNREAD]=TRUE"
Debug.Print olFolder.Items.Restrict(sFilter).Count
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
For Each itm In olFolder.Items.Restrict(sFilter) ''''Problem is over here
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
If itm.Attachments.Count = EC.Range("B2") Then 'itm Like "*" & EC.Range("A2") & "*" And'IF_Check_2
For Each objAtt In itm.Attachments
Debug.Print "Subject Name - " & itm: Debug.Print "Attachment Type - " & objAtt.DisplayName
Debug.Print "Attachment Size - " & objAtt.Size: Debug.Print "Attachments Count - " & objAtt.Index
Debug.Print "Subject Name - " & EC.Range("A2"): Debug.Print "Attachment Type - " & EC.Range("C2")
Debug.Print "Attachment Size - " & EC.Range("D2"): Debug.Print "Attachments Count - " & EC.Range("B2")
If objAtt.Size <= EC.Range("D2") And UCase(objAtt.Filename) Like UCase("*" & EC.Range("C2")) Then
IE.Range("A" & Incr) = olFolder
IE.Range("B" & Incr) = itm.SenderName
IE.Range("C" & Incr) = itm
IE.Range("D" & Incr) = objAtt.DisplayName
IE.Range("E" & Incr) = itm.Attachments.Count
IE.Range("F" & Incr) = objAtt.Size
IE.Range("G" & Incr) = "Pass"
Set olReply = itm.ReplyAll
'Set olRecip = olReply.Recipients.Add("Email Address Here") ' Recipient Address
'olRecip.Type = olCC
olReply.Body = "Hello," & vbNewLine & vbNewLine & "Email Success" & vbNewLine & vbNewLine & "Thank you. " & vbCrLf & olReply.Body
olReply.Display
'olReply.SentOnBehalfOfName = onBehalfOf
'olReply.SendUsingAccount = getGenericMailboxAccount(onBehalfOf)
olReply.Send
itm.UnRead = False
End If
Next objAtt
ElseIf itm.Attachments.Count <> EC.Range("B2") Then 'IF_Check_2
FailReason1 = "Attament is not a PDF"
FailReason2 = "Attachment size is more than 10MB"
FailReason3 = "Attachment is missing with email"
FailReason4 = "Attachments are more than 1"
IE.Range("A" & Incr) = olFolder
IE.Range("B" & Incr) = itm.SenderName
IE.Range("C" & Incr) = itm
IE.Range("D" & Incr) = ""
IE.Range("E" & Incr) = itm.Attachments.Count
IE.Range("F" & Incr) = ""
IE.Range("G" & Incr) = "Fail"
EBody = "Hello," & vbNewLine & vbNewLine & "Email Not Success." & vbNewLine & vbNewLine _
& "Fail Reason Might Be One Of The Below Mentioned:" & vbNewLine & vbNewLine _
& "*" & FailReason1 & vbNewLine & vbNewLine _
& "*" & FailReason2 & vbNewLine & vbNewLine _
& "*" & FailReason3 & vbNewLine & vbNewLine _
& "*" & FailReason4 & vbNewLine & vbNewLine _
Set olReply = itm.ReplyAll
'Set olRecip = olReply.Recipients.Add("Email Address Here") ' Recipient Address
'olRecip.Type = olCC
'olReply.Body = "Hello," & vbCrLf & "Email Not Success" & vbCrLf & FailReason1 & vbCrLf & FailReason2 & vbCrLf & FailReason3 & vbCrLf & olReply.Body
olReply.Body = EBody & vbCrLf & olReply.Body
olReply.Display
'olReply.SentOnBehalfOfName = onBehalfOf
'olReply.SendUsingAccount = getGenericMailboxAccount(onBehalfOf)
olReply.Send
itm.UnRead = False
itm.Move SubFolder
End If 'IF_Check_2
Incr = Incr + 1
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Next itm ' Its passing to the next statement even though loop is not completed.
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Set olFolder = Nothing
End If ''IF_Check_1
Next eFolder
End Sub
Your are modifying (by setting the Unread property to false) the very collection you are iterating over.
Do not use foreach - use a down loop.
set restrItems = olFolder.Items.Restrict(sFilter)
For i = restrItems.Count to 1 Step -1
set itm = restrItems(i)
First of all, you need to make sure the date object is formatted in the way Outlook understands:
sFilter = "[ReceivedTime] >= '" & Todays_Date & "' AND [UNREAD]=TRUE"
Use the Format function available in VBA.
sFilter = "[ReceivedTime] > '" & Format(Todays_Date, "ddddd h:nn AMPM") & "'"
The code below removes duplicate items from a folder in Outlook.
My request:
If two exact items exist, keep the copy that has been read, and delete the copy that has not been read.
Sub RemoveDuplicateItems()
Dim objFolder As Folder
Dim objDictionary As Object
Dim i As Long
Dim objItem As Object
Dim strKey As String
Set objDictionary = CreateObject("scripting.dictionary")
'Select a source folder
Set objFolder = Outlook.Application.Session.PickFolder
If Not (objFolder Is Nothing) Then
For i = objFolder.Items.Count To 1 Step -1
Set objItem = objFolder.Items.Item(i)
Select Case objFolder.DefaultItemType
'Check email subject, body and sent time
Case olMailItem
strKey = objItem.Subject & "," & objItem.Body & "," & objItem.SentOn
'Check appointment subject, start time, duration, location and body
Case olAppointmentItem
strKey = objItem.Subject & "," & objItem.Start & "," & objItem.Duration & "," & objItem.Location & "," & objItem.Body
'Check contact full name and email address
Case olContactItem
strKey = objItem.FullName & "," & objItem.Email1Address & "," & objItem.Email2Address & "," & objItem.Email3Address
'Check task subject, start date, due date and body
Case olTaskItem
strKey = objItem.Subject & "," & objItem.StartDate & "," & objItem.DueDate & "," & objItem.Body
End Select
strKey = Replace(strKey, ", ", Chr(32))
'Remove the duplicate items
If objDictionary.Exists(strKey) = True Then
objItem.Delete
Else
objDictionary.Add strKey, True
End If
Next i
End If
End Sub
You could save EntryId to delete an item with data previously saved in the dictionary.
Check each item instead of assuming the type will be the default type for the folder.
Option Explicit
Sub RemoveDuplicateUnreadItems()
' Remove duplicates, with a preference for unread items
Dim objFolder As Folder
Dim objDictionary As Object
Dim i As Long
Dim objItem As Object
Dim strKey As String
Dim dictionaryItem As Object
Set objDictionary = CreateObject("scripting.dictionary")
'Select a source folder
'Set objFolder = Session.PickFolder
Set objFolder = Session.GetDefaultFolder(olFolderInbox).Folders("Test")
If Not (objFolder Is Nothing) Then
For i = objFolder.Items.count To 1 Step -1
Set objItem = objFolder.Items.Item(i)
Select Case objItem.Class
'Check email subject, body and sent time
Case olMail
strKey = objItem.Subject & "," & objItem.Body & "," & objItem.SentOn
'Check appointment subject, start time, duration, location and body
Case olAppointment
strKey = objItem.Subject & "," & objItem.Start & "," & objItem.duration & "," & objItem.Location & "," & objItem.Body
'Check contact full name and email address
Case olContact
strKey = objItem.fullName & "," & objItem.Email1Address & "," & objItem.Email2Address & "," & objItem.Email3Address
'Check task subject, start date, due date and body
Case olTask
strKey = objItem.Subject & "," & objItem.startDate & "," & objItem.DueDate & "," & objItem.Body
Case Else
Debug.Print "Unexpected class: " & objItem.Class
'MsgBox "Unexpected class: " & objItem.Class
'objItem.Display
GoTo skipClass
End Select
strKey = Replace(strKey, ", ", Chr(32))
'Debug.Print objItem.Subject
'Remove the duplicate items
If objDictionary.Exists(strKey) = True Then
Debug.Print objItem.Subject
If objItem.UnRead = True Then
Debug.Print "objItem.Delete"
objItem.Delete
Else
' Replace existing without further verification
Set dictionaryItem = Session.GetItemFromID(objDictionary(strKey))
Debug.Print "dictionaryItem.Delete"
dictionaryItem.Delete
objDictionary(strKey) = objItem.EntryID
End If
Else
objDictionary.Add strKey, objItem.EntryID
End If
skipClass:
Next i
End If
Debug.Print "Done."
End Sub
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 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