I am trying to create a Macro that can efficiently search a Shared Mailbox in outlook with my desired category and date the email was received.
txtCat will be the category
txtDate is where I will input the date in this format : "mm/dd/yyyy"
Private Sub CommandButton1_Click()
Dim outlookapp
Dim olns As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Object
Dim myTasks
Dim myrecipient As Outlook.Recipient
Dim dateString As Long
Dim strfilter As String
Set outlookapp = CreateObject("Outlook.Application")
Set olns = outlookapp.GetNamespace("MAPI")
Set myrecipient = olns.CreateRecipient("Cmaintenancesupport2")
myrecipient.Resolve
Dim strCat As String
'txtCat is the category
'txtDate is the date
Set Fldr = olns.GetSharedDefaultFolder(myrecipient, olFolderInbox)
strCat = UserForm1.txtCat.Text
strfilter = "[Categories] = """ & strCat & """"
dateString = CDate(UserForm1.txtDate.Text)
Set myTasks = Fldr.Items.Restrict(strfilter) 'filters the desired category in the SharedDefault Mailbox
Set myTasks = myTasks.Restrict("[ReceivedTime] = '" & Format(dateString, "DDDDD HH:NN") & "'") 'adds another filter by date
For Each olMail In myTasks
olMail.Display
Next
End Sub
i set mytasks twice as I am just restructuring this code from a previous project that works (categorized email > filter by days > search subject line) but somehow it is not showing me any results.
What should happen here is after the category filter, it should all already categorized email with the desired date.
Related
My code takes account of the date of the email versus my threshold. For example, if I set my threshold to 4/1/2020, it will put all emails from 4/1/2020 to today.
My code is slow because it starts with my oldest email. How do I start the indexing with the most recent email?
The code I found online using items.sort "CreationDate", true doesn't work because it removes the date completely.
I've simplified the code:
Sub dateextract()
Dim OutlookApp As Outlook.Application
Dim Outlooknamespace As Namespace
Dim folder As MAPIFolder
Dim subfolder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Long
Dim dates As Date
Dim time As Date
Dim sender As String
Set OutlookApp = New Outlook.Application
Set Outlooknamespace = OutlookApp.GetNamespace("MAPI")
Set folder = Outlooknamespace.GetDefaultFolder(olFolderInbox)
dates = Cells(1, 2).Value
i = 1
For Each OutlookMail In folder.Items
time = OutlookMail.ReceivedTime
If time >= dates Then
'........
Restrict and sort is the usual solution.
Sub dateextract()
' Early binding
' Reference Outlook XX.X Object Library
Dim outlookApp As Outlook.Application
Dim folder As folder
Dim outlookItem As Object
Dim i As Long
Dim dates As Date
Dim fldrItems As Items
Dim strFilter As String
Dim resItems As Items
Set outlookApp = New Outlook.Application
Set folder = Session.GetDefaultFolder(olFolderInbox)
' Unknown value and unknown format
'dates = Cells(1, 2).Value
' dates = Format("2020-01-04", "yyyy-mm-dd") '?
dates = Format("2021-01-04", "yyyy-mm-dd")
Set fldrItems = folder.Items
Debug.Print "fldrItems.Count: " & fldrItems.Count
strFilter = "[CreationTime] > '" & dates & "'"
Debug.Print strFilter
Set resItems = fldrItems.Restrict(strFilter)
Debug.Print "resItems.Count: " & resItems.Count
' Sort collections in memory, not items in folder
resItems.Sort "[CreationTime]", True
For i = 1 To resItems.Count
If resItems(i).Class = olMail Then
Set outlookItem = resItems(i)
Debug.Print i & ") " & outlookItem.CreationTime & ": " & outlookItem.Subject
End If
Next
End Sub
I'm running a macro on excel to populate a shared outlook calendar. The thing is, I have no problem to add appointments to the calendar, but when dates change I want to suppress old ones, to replace them by new events.
I have a code that is supposed to filter the items I want to suppress, but for some reason the TypeName of my Outlook events remains on "Nothing", and I can't figure out why.
Here is the test event in my calendar that needs to be suppressed.
Here is the code:
Sub SuppressOutlookEvents()
Dim olApp As Outlook.Application
Dim objAppointment As Outlook.AppointmentItem
Dim objAppointments As Outlook.MAPIFolder
Dim objNameSpace As Outlook.Namespace
Dim objProperty As Outlook.UserProperty
Dim OutlookStartTime, OutlookEndTime As Date
Dim sFilter As Variant
Worksheets("to_be_removed").Activate
OutlookStartTime = DateValue("10-15-2019")
Set olApp = CreateObject("Outlook.Application")
Set objNameSpace = olApp.GetNamespace("MAPI")
Set objAppointments = objNameSpace.GetDefaultFolder(olFolderCalendar)
sFilter = "[Start] = OutlookStartTime And [Subject] = 'Test'"
Set objAppointment = objAppointments.Items.Find(sFilter)
```
MsgBox (TypeName(objAppointment)) 'Here it displays "Nothing"
If Not TypeName(objAppointment) = "Nothing" Then
objAppointment.Delete
End If
```
Set objAppointment = Nothing
Set objAppointments = Nothing
End Sub
I don't know if the filter doesn't recognize the event or if it's for another reason...
EDIT: thanks to the answers, I finally have a working code:
Sub suppress_outlook_event(Optional row As Integer = 2)
Dim olApp As Outlook.Application
Dim objAppointments As Outlook.MAPIFolder
Dim objNameSpace As Outlook.Namespace
Dim objProperty As Outlook.UserProperty
Dim OutlookStartTime, OutlookEndTime As Date
Dim sFilter As Variant
OutlookStartTime = Format("09/19/19" & " " & "8:00 AM", "mm/dd/yyyy hh:mm AMPM")
Set olApp = CreateObject("Outlook.Application")
Set objNameSpace = olApp.GetNamespace("MAPI")
Set objAppointments = objNameSpace.GetDefaultFolder(olFolderCalendar)
o_title = "Example"
sFilter = "[Subject] = " & Chr(34) & o_title & Chr(34)
objAppointments.Items.IncludeRecurrences = True
objAppointments.Items.Sort "[Start]"
Set objAppointment = objAppointments.Items.Restrict(sFilter)
objAppointment.IncludeRecurrences = True
If Not objAppointment.Count = 0 Then
obj_count = objAppointment.Count
For i = 1 To obj_count
objAppointment(obj_count + 1 - i).Delete
Next i
End If
Set objAppointment = Nothing
Set objAppointments = Nothing
End Sub
This question should like be closed as duplicate, however I've made the required updates to your code.
Key points when using Find or Restrict with Appointments.
Make sure IncludeRecurrences Property is set to True
Ensure date/time is formatted as shown below and is parsed as a string as opposed to supplied as an actual date/datetime value.
I'm a bit skeptical on how it will handle multiple appointments with the same subject and start date (if time is not supplied or conflicting appointments exist). Past experience indicates it will just return the first one. So it may be better to use the Restrict method and iterate through the returned item collection otherwise you'll run the risk of missing an appointment.
Items.Restrict appointments in Outlook Calendar (VBA)
Sub SuppressOutlookEvents()
Dim olApp As Outlook.Application
Dim objAppointment As Outlook.AppointmentItem
Dim objAppointments As Outlook.MAPIFolder
Dim objNameSpace As Outlook.NameSpace
Dim objProperty As Outlook.UserProperty
Dim OutlookStartTime, OutlookEndTime As Date
Dim sFilter As Variant
Worksheets("to_be_removed").Activate
OutlookStartTime = Format("9-24-2019 12:30PM", "mm/dd/yyyy hh:mm AMPM")
Set olApp = CreateObject("Outlook.Application")
Set objNameSpace = olApp.GetNamespace("MAPI")
Set objAppointments = objNameSpace.GetDefaultFolder(olFolderCalendar)
sFilter = "[Start] = '" & OutlookStartTime & "' And [Subject] = 'test'"
objAppointments.Items.IncludeRecurrences = True
objAppointments.Items.Sort "[Start]"
Set objAppointment = objAppointments.Items.Find(sFilter)
MsgBox (TypeName(objAppointment)) 'Here it displays "Nothing"
If Not TypeName(objAppointment) = "Nothing" Then
objAppointment.Delete
End If
Set objAppointment = Nothing
Set objAppointments = Nothing
End Sub
I am trying to import mail data from Outlook. I'm using the code below. This code shows "Type MisMatch" error. But some of the mail is copied in the Excel sheet.
How can I import mails which have a particular subject line or mails which are received on a particular date.
Sub GetFromInbox()
Dim olapp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Outlook.MailItem
Dim Pst_Folder_Name As String, MailboxName As String
Dim i As Long
MailboxName = "xxxx#yyyyy.com"
Pst_Folder_Name = "Inbox"
Set olapp = New Outlook.Application
Set olNs = olapp.GetNamespace("MAPI")
Set Fldr = olNs.Folders(MailboxName).Folders(Pst_Folder_Name)
With Sheets("sheet1")
.Cells.ClearContents
.Cells(1, 1).Value = "Date"
i = 2
For Each olMail In Fldr.Items
'For Each olMail In olapp.CurrentFolder.Items
.Cells(i, 1).Value = olMail.ReceivedTime
.Cells(i, 3).Value = olMail.Subject
.Cells(i, 4).Value = olMail.SenderName
.Cells(i, 5).Value = olMail.Body
i = i + 1
Next olMail
End With
olapp.Quit
Set olapp = Nothing
End Sub
Use Items.Restrict Method (Outlook) to filter by Subject line or Date
Subject Example
Dim Filter As String
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & _
Chr(34) & " Like '%Bla Bla%'"
Applies a filter to the Items collection, returning a new collection containing all of the items from the original that match the filter.
This method is an alternative to using the Find method or FindNext method to iterate over specific items within a collection. The Find or FindNext methods are faster than filtering if there are a small number of items. The Restrict method is significantly faster if there is a large number of items in the collection, especially if only a few items in a large collection are expected to be found.
"Type MisMatch" error
Outlook Inbox/Folder has different type of object MailItem, AppointmentItem, ContactItem, etc So the error could be you're hitting an item that's not a MailItem.
Try
If TypeOf olMail Is Outlook.MailItem Then
So your code should look like this
Option Explicit
Sub GetFromInbox()
Dim olapp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Object
Dim Pst_Folder_Name As String, MailboxName As String
Dim i As Long
MailboxName = "xxxx#yyyyy.com"
Pst_Folder_Name = "Inbox"
Set olapp = New Outlook.Application
Set olNs = olapp.GetNamespace("MAPI")
Set Fldr = olNs.Folders(MailboxName).Folders(Pst_Folder_Name)
Dim Filter As String
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & _
Chr(34) & " Like '%bla bla %'"
With Sheets("sheet1")
.Cells.ClearContents
.Cells(1, 1).Value = "Date"
i = 2
For Each olMail In Fldr.Items.Restrict(Filter)
If TypeOf olMail Is Outlook.MailItem Then
DoEvents
.Cells(i, 1).Value = olMail.ReceivedTime
.Cells(i, 3).Value = olMail.Subject
.Cells(i, 4).Value = olMail.SenderName
.Cells(i, 5).Value = olMail.Body
End If
i = i + 1
Next olMail
End With
olapp.Quit
Set olapp = Nothing
End Sub
I am using the following For Each loop to import new Outlook mail into Excel. I am attempting to speed up the routine and am having trouble applying this filter to my existing code.
myInbox.Items.Restricted("DateValue[ReceivedTime] > "" & Format(DateValue(Now, "ddddd h:nn AMPM") & "")
Can someone with provide some pointers? Thanks in advance!
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.Namespace
Dim myInbox As Outlook.Items
Dim myitems As Outlook.Items
Dim myitem As Object
Dim Found As Boolean
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.Session.Folders.Item("test#test.com").Folders("My Folder").Items
' Need to apply filter to only pull items new than a specified date'
Found = False
For Each myitem In myInbox
'This next line is checking all items in folder which is taking too long'
If myitem.Class = olMail And myitem.ReceivedTime > Workbooks("Test.xlsm").Sheets("Sheet1").Range("C2").Value Then
'Do something'
Found = True
End If
Next myitem
Set myOlApp = Nothing
Why the obsession with DateValue?
This is wrong Format(DateValue(Now, "ddddd h:nn AMPM") and so is this "DateValue[ReceivedTime]
Even if you correct that syantax, you are trying to set a filter that is greater than current time, so you are trying to restrict your items for which are yet to be received:)
Use a variable to store a certain time (that is earlier to current date time)
Following code filters all the items received after 11/4/2017 10:25:00 PM
Sub test()
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.Items
Dim myItems As Outlook.Items
Dim myitem As Object
Dim Found As Boolean
Dim TimeCrit As Date
TimeCrit = #11/4/2017 10:25:00 PM#
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox).Items
' Need to apply filter to only pull items new than a specified date'
Set myItems = myInbox.Restrict("[ReceivedTime] >= """ & Format(TimeCrit, "ddddd h:nn AMPM") & """")
Found = False
For Each myitem In myItems
MsgBox myitem.Subject
Next myitem
Set myOlApp = Nothing
End Sub
I am trying to save all the emails, resulting out of instant text search into the hard drive folder. the below code is able to perform the search but giving me an error at selectallitems line while selecting each mail and saving them in HD. code is in excel vba;
Dim OlApp As Outlook.Application
Set OlApp = CreateObject("Outlook.Application")
Dim fldrpath As String
fldrpath = "\\mydata\EMAILS\
Check subfolder for messages and exit of none found
txtsearch = "abc#xyz.com, received:4/1/2017..4/30/2017"
OlApp.ActiveExplorer.Search txtsearch, olSearchScopeAllFolders
Dim myitem As Outlook.MailItem
Dim objitem As Object
Set myitem = OlApp.ActiveExplorer.SelectAllItems
Set objitem = myitem
objitem.SaveAs fldrpath & "test" & ".msg", olMSG
Any other alternative code to get the emails saved will also be appreciated.
Thanks in advance !! looking for a quick solution
Saving search results appears to be more easily achieved a different way.
From Outlook, not Excel.
Sub SearchForStr_Save()
Dim strSearch As String
Dim strDASLFilter As String
Dim strScope As String
Dim objItem As Object
Dim objSearch As search
Dim srchFolder As folder
Dim fldrpath As String
strSearch = "abc#xyz.com"
strDASLFilter = "urn:schemas:httpmail:textdescription LIKE '%" & strSearch & "%'"
strScope = "'Inbox'"
Set objSearch = AdvancedSearch(Scope:=strScope, filter:=strDASLFilter, SearchSubFolders:=True, Tag:="SearchFolder")
Set srchFolder = objSearch.Save(strSearch)
'fldrpath = "\\mydata\EMAILS\"
fldrpath = "h:\test\"
For Each objItem In srchFolder.Items
'Debug.Print objItem.subject
If objItem.Class = olMail Then
objItem.SaveAs fldrpath & "test" & ".msg", olMsg
End If
Next
ExitRoutine:
Set objSearch = Nothing
Set srchFolder = Nothing
End Sub