finding specific appointments in agenda through excel vba - vba

I have an excel file in which i register action of employees.
This is the following design:
ID Datum Type Typedatail Metadata Regdata hours
3767 01/04/2018 SN VM 64 05/01/2018 4
3767 01/04/2018 SN NM 65 05/01/2018 4
3767 03/04/2018 SN VM 66 05/01/2018 4
3767 03/04/2018 SN NM 67 05/01/2018 4
3767 04/04/2018 SN VM 68 05/01/2018 4
3767 04/04/2018 SN NM 69 05/01/2018 4
3767 07/04/2018 CA 70 05/01/2018 8
3767 08/04/2018 CA 71 05/01/2018 8
3767 09/04/2018 CA 72 05/01/2018 8
3683 12/01/2018 OU- 73 05/01/2018 -8
I need to put them into a calender also to distribute this knowledge.
!(https://ibb.co/hQmOxR)
But at times i need to edit those. (change or delete those)
i have found the following as a base
Search Appointments in excel with VBA
This finds them eventually but this runs through ALL the appointments, which is unneeded as i know on which date the appointment is set.
Therefore i want to restrict the range but i make a fault with it, that i can not figure out.
Base find appointment
Public Function CheckAppointment(ByVal argCheckDate As Date, ByVal argTikNummer As Integer) As Boolean
Const olAppointment = 26 ' <== Added this line and your code worked.
Dim oApp As Object
Dim oNameSpace As Object
Dim oApptItem As Object
Dim oFolder As Object
Dim oMeetingoApptItem As Object
Dim oObject As Object
Dim strRestriction As String 'opmaak zoekbeperking
On Error Resume Next ' No appointment was found since you have this line and olAppointmnet wasn't defined.
Set oApp = GetObject(, "Outlook.Application")
If oApp Is Nothing Then Set oApp = CreateObject("Outlook.Application")
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oFolder = oApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar) 'oNameSpace.Session.GetDefaultFolder(9).Folders(olFolderCalendar)
CheckAppointment = False
For Each oObject In oFolder.Items
'MsgBox oObject
If (oObject.Class = olAppointment) Then ' <== This is why you need to define it first
Set oApptItem = oObject
If oApptItem.Start = argCheckDate And InStr(oApptItem.Body, argTikNummer) Then
MsgBox oApptItem.Body
CheckAppointment = True
Exit For ' <== Added this exit for loop to improve performance
End If
End If
Next oObject
Set oApp = Nothing
Set oNameSpace = Nothing
Set oApptItem = Nothing
Set oFolder = Nothing
Set oObject = Nothing
End Function
Public Sub Driver()
Dim dtCheck As Date
Dim intTikNummer As Integer
Dim sbCheck As String
Sheets("blad1").Select
Dim i As Long
i = 2
Do Until Trim(Cells(i, 1).Value) = "" 'voorlopig test omgeving. Moet worden omgevormd tot een single entry test
dtCheck = Cells(i, 2) '+ TimeValue("09:00:00")
intTikNummer = Cells(i, 1)
If CheckAppointment(dtCheck, intTikNummer) Then
MsgBox "Appointment found", vbOKOnly + vbInformation 'dummy uitkomst verslag. Moet worden vervangen door een opdracht
Else
MsgBox "Appointment not found", vbOKOnly + vbExclamation 'dummy uitkomst verslag. Moet worden vervangen door een opdracht
End If
i = i + 1
Loop
End Sub
`
Base restriction example (outlook)
Sub FindAppts()
Dim myStart As Date
Dim myEnd As Date
Dim oCalendar As Outlook.folder
Dim oItems As Outlook.items
Dim oItemsInDateRange As Outlook.items
Dim oFinalItems As Outlook.items
Dim oAppt As Outlook.AppointmentItem
Dim strRestriction As String
myStart = Date
myEnd = DateAdd("d", 30, myStart)
Debug.Print "Start:", myStart
Debug.Print "End:", myEnd
'Construct filter for the next 30-day date range
strRestriction = "[Start] >= '" &; _
Format$(myStart, "mm/dd/yyyy hh:mm AMPM") _
&; "' AND [End] <= '" &; _
Format$(myEnd, "mm/dd/yyyy hh:mm AMPM") &; "'"
'Check the restriction string
Debug.Print strRestriction
Set oCalendar = Application.session.GetDefaultFolder(olFolderCalendar)
Set oItems = oCalendar.items
oItems.IncludeRecurrences = True
oItems.Sort "[Start]"
'Restrict the Items collection for the 30-day date range
Set oItemsInDateRange = oItems.Restrict(strRestriction)
'Construct filter for Subject containing 'team'
Const PropTag As String = "http://schemas.microsoft.com/mapi/proptag/"
strRestriction = "#SQL=" &; Chr(34) &; PropTag _
&; "0x0037001E" &; Chr(34) &; " like '%team%'"
'Restrict the last set of filtered items for the subject
Set oFinalItems = oItemsInDateRange.Restrict(strRestriction)
'Sort and Debug.Print final results
oFinalItems.Sort "[Start]"
For Each oAppt In oFinalItems
Debug.Print oAppt.Start, oAppt.Subject
Next
End Sub
`
I came to the following result (through example)
Public Function CheckAppointment(ByVal argCheckDate As Date, ByVal argTikNummer As Integer) As Boolean
Const olAppointment = 26 ' <== Added this line and your code worked.
Dim oApp As Object
Dim oNameSpace As Object
Dim oApptItem As Object
Dim oFolder As Object
Dim oFolderA As Object
Dim oFolderB As Object
Dim oMeetingoApptItem As Object
Dim oObject As Object
Dim myStart, myEnd As Date
Dim strRestriction As String 'opmaak zoekbeperking
'Construct filter for day date range
myStart = Format(argCheckDate, "dd/mm/yyyy") 'argcheckdate
myEnd = DateAdd("d", 1, myStart)
myEnd = Format(myEnd, "dd/mm/yyyy") 'Argcheckdate
Debug.Print "Start:", myStart
Debug.Print "End:", myEnd
strRestriction = "[Start] = '" & myStart & "' AND [End] = '" & myEnd & "'"
On Error Resume Next ' No appointment was found since you have this line and olAppointmnet wasn't defined.
Set oApp = GetObject(, "Outlook.Application")
If oApp Is Nothing Then Set oApp = CreateObject("Outlook.Application")
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oFolder = oApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar) 'oNameSpace.Session.GetDefaultFolder(9).Folders(olFolderCalendar)
CheckAppointment = False
'Restrict the Items collection for the 30-day date range
Set oFolderA = oFolder.Restrict(strRestriction)
For Each oObject In oFolderA.Items
MsgBox oObject & " : " & oObject.Start & " : " & myStart & " - " & myEnd
If (oObject.Class = olAppointment) Then ' <== This is why you need to define it first
Set oApptItem = oObject
If oApptItem.Start = argCheckDate And InStr(oApptItem.Body, argTikNummer) Then
MsgBox oApptItem.Body
CheckAppointment = True
Exit For ' <== Added this exit for loop to improve performance
End If
End If
Next oObject
Set oApp = Nothing
Set oNameSpace = Nothing
Set oApptItem = Nothing
Set oFolder = Nothing
Set oFolderA = Nothing
Set oFolderB = Nothing
Set oObject = Nothing
End Function
I end up with an empty oApptItem yet If oApptItem.Start = argCheckDate And InStr(oApptItem.Body, argTikNummer) trigger true despite the appointments not being in the list.
The above code is meant as a base to be used to edit or delete an appointment.

Filtering a calendar is tricky and this is compounded by not turning off On Error Resume Next.
Option Explicit
Private Sub CheckAppointment_test()
' Appointment date
Dim argCheckDate As String
argCheckDate = "2018-01-05"
' Text in body of appointment
Dim argTikNummer As Long
argTikNummer = 3767
Dim result As Boolean
MsgBox CheckAppointment(argCheckDate, argTikNummer) & vbCr & " Done."
End Sub
Public Function CheckAppointment(ByVal argCheckDate As Date, ByVal argTikNummer As Integer) As Boolean
' Not required as Outlook must be referenced
' to use olFolderCalendar later
'Const olAppointment = 26
Dim oApp As Object
Dim oNameSpace As Object
Dim oApptItem As Object
Dim oFolder As Object
Dim oFolderA As Object
Dim oObject As Object
Dim myStart, myEnd As Date
Dim strRestriction As String
'Construct filter for day date range
'myStart = Format(argCheckDate, "dd/mm/yyyy") 'argcheckdate
myStart = Format(argCheckDate, "yyyy-mm-dd") 'argcheckdate
myEnd = DateAdd("d", 1, myStart)
'myEnd = Format(myEnd, "dd/mm/yyyy") 'Argcheckdate
myEnd = Format(myEnd, "yyyy-mm-dd") 'Argcheckdate
Debug.Print "Start:", myStart
Debug.Print "End:", myEnd
'strRestriction = "[Start] = '" & myStart & "' AND [End] = '" & myEnd & "'"
strRestriction = "[Start] <= '" & myEnd & "' AND [End] >= '" & myStart & "'"
Debug.Print strRestriction
' Misuse causes insurmountable problems as errors are hidden
On Error Resume Next
Set oApp = GetObject(, "Outlook.Application")
' Mandatory with On Error Resume Next to stop bypassing errors
On Error GoTo 0
' Handle error bypassed above, if any
If oApp Is Nothing Then Set oApp = CreateObject("Outlook.Application")
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetDefaultFolder(olFolderCalendar)
CheckAppointment = False
' *******
Dim oFolderItems As Object
Set oFolderItems = oFolder.items
' Strange behaviour if this is not used
oFolderItems.IncludeRecurrences = True
oFolderItems.Sort "[Start]"
' *******
'Restrict the Items collection for the specified date range
Set oFolderA = oFolderItems.Restrict(strRestriction)
'For Each oObject In oFolderA.items
For Each oObject In oFolderA
Debug.Print oObject.Subject & " : " & oObject.Start
If (oObject.Class = olAppointment) Then
Set oApptItem = oObject
Debug.Print "oApptItem.Start: " & oApptItem.Start
Debug.Print "Formatted oApptItem.Start: " & Format(oApptItem.Start, "yyyy-mm-dd")
Debug.Print "argCheckDate: " & argCheckDate
' Not true unless oApptItem.Start is formatted to match format of argCheckDate
' Should not be necessary if the filter is working correctly
'If oApptItem.Start = argCheckDate Then
Debug.Print InStr(oApptItem.body, argTikNummer)
If InStr(oApptItem.body, argTikNummer) Then
MsgBox oApptItem.Subject & vbCr & oApptItem.body
CheckAppointment = True
' Do not exit if there can be multiple appointments
'Exit For
End If
'End If
End If
Next oObject
Set oApp = Nothing
Set oNameSpace = Nothing
Set oApptItem = Nothing
Set oFolder = Nothing
Set oFolderA = Nothing
Set oObject = Nothing
End Function

Related

Why does the Application.AdvancedSearch method fail to operate?

The below subroutine runs upon Outlook application startup with the Application level event "Startup". The sub accesses an Outlook NoteItem with a time stamp used to filter all items in the Outlook account parent folder received since the last time Outlook was closed with the Application.AdvancedSearch method. The resulting items of the search will then be processed in a separate subroutine.
The code is failing on the Application.AdvancedSearch line. I have tried changing the scope (the first field) to the inbox (see the commented out line). Either way, the operation fails.
Why is the operation failing?
Thanks for the help!
Option Explicit
Public Sub Process_New_Items()
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim dmi As MailItem
Dim timeFol As Outlook.Folder
Dim timeFilter As String
Dim lastclose As String
Dim utcdate As Date
Dim filterString As String
Dim i As Object
Dim subFol As Outlook.Folder
Dim olFol
Dim asFilter As String
Dim Scope As String
Dim SearchObject As Outlook.Search
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olFol = olNS.Folders(1)
Set dmi = olApp.CreateItem(olMailItem)
Set timeFol = olNS.GetDefaultFolder(olFolderNotes)
timeFilter = "[Subject] = 'App Close Time'"
For Each i In timeFol.Items.Restrict(timeFilter)
lastclose = i.CreationTime
Next i
utcdate = dmi.PropertyAccessor.LocalTimeToUTC(lastclose)
filterString = "#SQL=""urn:schemas:httpmail:datereceived"" >= '" & Format(utcdate, "dd mmm yyyy hh:mm") & "'"
asFilter = "urn:schemas:httpmail:datereceived >= '" & Format(utcdate, "dd mmm yyyy hh:mm") & "'"
Scope = "'" & olNS.Folders(1) & "'"
'Scope = "'Inbox', 'Sent Items', 'Tasks'"
SearchObject = olApp.AdvancedSearch(Scope, filterString, True)
For Each i In SearchObject.Results
If TypeName(i) = "MailItem" Then
Process_MailItem i
Else: End If
Next i
End Sub
The filter is "urn:schemas:httpmail:datereceived >= " & "'" & utcdate & "'"
Option Explicit
' Code in ThisOutlookSession
Public blnSearchComp As Boolean
Private Sub Application_AdvancedSearchComplete(ByVal SearchObject As Search)
' https://learn.microsoft.com/en-us/office/vba/api/outlook.application.advancedsearch
' Code should be in a class module such as ThisOutlookSession
Debug.Print "The AdvancedSearchComplete Event fired"
If SearchObject.Tag = "Process_New_Items" Then
'm_SearchComplete = True` ' Use Option Explicit.
blnSearchComp = True
End If
End Sub
Private Sub Process_New_Items()
Dim dmi As mailItem
Dim timeFol As Folder
Dim timeFilter As String
Dim lastclose As String
Dim utcdate As Date
Dim strFilter As String
Dim i As Object
Dim strScope As String
Dim SearchObject As Search
Set dmi = CreateItem(olMailItem)
Set timeFol = Session.GetDefaultFolder(olFolderNotes)
timeFilter = "[Subject] = 'App Close Time'"
For Each i In timeFol.Items.Restrict(timeFilter)
lastclose = i.CreationTime
Next i
Debug.Print lastclose
utcdate = dmi.propertyAccessor.LocalTimeToUTC(lastclose)
'strFilter = "#SQL=""urn:schemas:httpmail:datereceived"" >= '" & Format(utcdate, "dd mmm yyyy hh:mm") & "'"
strFilter = "urn:schemas:httpmail:datereceived >= " & "'" & utcdate & "'"
Debug.Print strFilter
strScope = "'" & Session.Folders(1).Folders("Inbox") & "'"
Debug.Print strScope
strScope = "'" & Session.GetDefaultFolder(olFolderInbox) & "'"
Debug.Print strScope
strScope = "'Inbox'"
Debug.Print strScope
' mailbox: to include folders at the same level as the Inbox
strScope = "'" & Session.GetDefaultFolder(olFolderInbox).Parent.folderPath & "'"
Debug.Print "strScope.: " & strScope
Set SearchObject = AdvancedSearch(Scope:=strScope, filter:=strFilter, SearchSubFolders:=True, Tag:="Process_New_Items")
' 2022-07-01 Eureka!
blnSearchComp = False
' Otherwise remains True.
' Search would work once until Outlook restarted.
While blnSearchComp = False
DoEvents
' Code should be in a class module such as ThisOutlookSession
Debug.Print "Wait a few seconds. Ctrl + Break if needed."
Wend
Debug.Print "SearchObject.results.count: " & SearchObject.results.count
For Each i In SearchObject.results
If TypeName(i) = "MailItem" Then
'Process_MailItem i
Debug.Print i.ReceivedTime, i.subject
Else: End If
Next i
End Sub

Format a date variable to display time only in Outlook Calendar

I am trying to show the start time and end time.
In the end time, I don't want the date, as I am trying to show availability.
It shows under the print window "25/06/2021 14:45:34 25/06/2021 16:05:00".
I want to remove the middle date. I tried masks, but just erroring.
Also when the dialog box shows, I want to copy the content to clipboard.
Dim CalFolder As Outlook.Folder
Dim nameFolder
Dim strKeyword As String
Dim strResults As String
' Run this macro
Sub SearchinSharedCalendars()
Dim objPane As Outlook.NavigationPane
Dim objModule As Outlook.CalendarModule
Dim objGroup As Outlook.NavigationGroup
Dim objNavFolder As Outlook.NavigationFolder
Dim objCalendar As Folder
Dim objFolder As Folder
Dim i As Integer
Dim g As Integer
On Error Resume Next
Set objCalendar = Session.GetDefaultFolder(olFolderCalendar)
Set Application.ActiveExplorer.CurrentFolder = objCalendar
DoEvents
strKeyword = InputBox("Search subject and body", "Search Shared Calendars")
Set objPane = Application.ActiveExplorer.NavigationPane
Set objModule = objPane.Modules.GetNavigationModule(olModuleCalendar)
With objModule.NavigationGroups
For g = 1 To .Count
Set objGroup = .Item(g)
For i = 1 To objGroup.NavigationFolders.Count
Set objNavFolder = objGroup.NavigationFolders.Item(i)
If objNavFolder.IsSelected = True Then
Set CalFolder = objNavFolder.Folder
Set nameFolder = objNavFolder
Dim NS As Outlook.NameSpace
Dim objOwner As Outlook.Recipient
Set NS = Application.GetNamespace("MAPI")
Set objOwner = NS.CreateRecipient(nameFolder)
objOwner.Resolve
If objOwner.Resolved Then
Set CalFolder = NS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
End If
SearchSharedCalendar
txtSearchResults = strResults & vbCrLf & txtSearchResults
End If
Next i
Next g
End With
MsgBox txtSearchResults
Set objPane = Nothing
Set objModule = Nothing
Set objGroup = Nothing
Set objNavFolder = Nothing
Set objCalendar = Nothing
Set objFolder = Nothing
End Sub
Private Sub SearchSharedCalendar()
Dim CalItems As Outlook.Items
Dim ResItems As Outlook.Items
Dim oFinalItems As Outlook.Items
Dim sFilter As String
Dim iNumRestricted As Integer
Dim itm As Object
Dim strAppt As String
Dim endAppt As String
Dim dStart1 As Date, dStart2 As Date
Set CalItems = CalFolder.Items
If CalFolder = printCal Then
Exit Sub
End If
' Sort all of the appointments based on the start time
CalItems.Sort "[Start]"
' body key word doesn't work if including recurring
CalItems.IncludeRecurrences = True
On Error Resume Next
' if you arent search subfolders, you only need parent name
strName = CalFolder.Parent.Name & " - " & CalFolder.Name
' set dates
dStart1 = Date
dStart2 = Date + 30
' fileer by date first
sFilter = "[Start] >= '" & dStart1 & "'" & " And [Start] < '" & dStart2 & "'"
Debug.Print sFilter
'Restrict the Items collection for the 30-day date range
Set ResItems = CalItems.Restrict(sFilter)
' Filter the results by keyword
' filter for Subject containing strKeyword '0x0037001E
' body is 0x1000001f
Const PropTag As String = "http://schemas.microsoft.com/mapi/proptag/"
sFilter = "#SQL=(" & Chr(34) & PropTag _
& "0x0037001E" & Chr(34) & " like '%" & strKeyword & "%' OR " & Chr(34) & PropTag _
& "0x1000001f" & Chr(34) & " like '%" & strKeyword & "%')"
Debug.Print sFilter
'Restrict the last set of filtered items for the subject
Set oFinalItems = ResItems.Restrict(sFilter)
'Sort and collect final results
oFinalItems.Sort "[Start]"
iNumRestricted = 0
For Each oAppt In oFinalItems
If oAppt.Start >= dStart1 And oAppt.Start <= dStart2 Then
iNumRestricted = iNumRestricted + 1
strAppt = oAppt.Start & " " & endAppt
endAppt = oAppt.End
End If
Next
strResults = iNumRestricted & " matching Appointment found in " & vbCrLf & strAppt & " " & endAppt
Set itm = Nothing
Set newAppt = Nothing
Set ResItems = Nothing
Set CalItems = Nothing
Set CalFolder = Nothing
End Sub
First of all, there is no need to iterate over all items in the collection:
For Each oAppt In oFinalItems
Instead, you can apply a filter by using the Restrict or Find/FindNext methods of the Items class as you did that earlier in the code.
To format the dates values you need to use the Format function available in VBA:
strAppt = oAppt.Start & " " & Format(endAppt, "hh:mm:ss")

Get email from Outlook to Excel specified by received date

I am creating a macro to get email by subject and received date in our team shared box.
I use for loop to check all email in mailbox but it takes forever because my statement checks 1000+ mails.
How can I get email by specific date? Let's say I need email 12/1/2017 to 12/30/2017.
The key is using Restrict method but I don't know how I can use it.
Sub GetFromOutlook()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Dim olShareName As Outlook.Recipient
Set olShareName = OutlookNamespace.CreateRecipient("sharemailbox#example.ca")
Set Folder = OutlookNamespace.GetSharedDefaultFolder(olShareName, olFolderInbox).Folders("sharebox subfolder").Folders("sharebox subfolder2")
i = 1
For Each OutlookMail In Folder.Items
If ((Range("From_Date").Value <= OutlookMail.ReceivedTime) And _
(OutlookMail.ReceivedTime <= Range("To_Date").Value)) And _
OutlookMail.Sender = "sender#example.com" Then
Range("eMail_subject").Offset(i, 0).Value = OutlookMail.Subject
Range("eMail_date").Offset(i, 0).Value = OutlookMail.ReceivedTime
i = i + 1
End If
Next OutlookMail
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
End Sub
I assume the code I have to fix is:
<For Each OutlookMail In Folder.Items>
How can I make statement using Restrict Method?
You could probably use the GetTable instead of a loop which has to process each email (or item) one by one.
GetTable will allow you to apply a filter on the content of the folder which should operate much faster.
For more details and an example, you can check the MSDN article on the Folder.GetTable Method for Outlook.
And for the specific filter that you are trying to apply, I would try:
"([ReceivedTime]>=12/1/17) AND ([ReceivedTime]<=12/30/17)"
You can create a collection of items restricted by date like this.
Option Explicit
Private Sub EmailInTimePeriod()
Dim oOlInb As Folder
Dim oOlItm As Object
Dim oOlResults As Object
Dim i As Long
Dim sFilterLower As String
Dim sFilterUpper As String
Dim sFilter As String
Dim dStart As Date
Dim dEnd As Date
Set oOlInb = Session.GetDefaultFolder(olFolderInbox)
' https://msdn.microsoft.com/en-us/library/office/ff869597.aspx
' 12/1/2017 to 12/30/2017
'dStart = "2017/12/01"
'dEnd = "2017/12/30"
' 1/12/2018 to 1/15/2018
dStart = "2018/01/12"
dEnd = "2018/01/16"
' Lower Bound of the range
sFilterLower = "[ReceivedTime]>'" & Format(dStart, "DDDDD HH:NN") & "'"
Debug.Print vbCr & "sFilterLower: " & sFilterLower
' *** temporary demo lines
' Restrict the items in the folder
Set oOlResults = oOlInb.Items.Restrict(sFilterLower)
Debug.Print oOlResults.count & " items."
If oOlResults.count > 0 Then
For i = 1 To oOlResults.count
Set oOlItm = oOlResults(i)
Debug.Print oOlItm.ReceivedTime & " - " & oOlItm.subject
Next i
End If
' *** temporary demo lines
' Upper Bound of the range
sFilterUpper = "[ReceivedTime]<'" & Format(dEnd, "DDDDD HH:NN") & "'"
Debug.Print vbCr & "sFilterUpper: " & sFilterUpper
' *** temporary demo lines
' Restrict the Lower Bound result
Set oOlResults = oOlResults.Restrict(sFilterUpper)
Debug.Print oOlResults.count & " items."
If oOlResults.count > 0 Then
For i = 1 To oOlResults.count
Set oOlItm = oOlResults(i)
Debug.Print oOlItm.ReceivedTime & " - " & oOlItm.subject
Next i
End If
' *** temporary demo lines
' combine the filters
sFilter = sFilterLower & " AND " & sFilterUpper
Debug.Print vbCr & "sFilter: " & sFilter
Set oOlResults = oOlInb.Items.Restrict(sFilter)
Debug.Print oOlResults.count & " items."
If oOlResults.count > 0 Then
For i = 1 To oOlResults.count
Set oOlItm = oOlResults(i)
Debug.Print oOlItm.ReceivedTime & " - " & oOlItm.subject
Next i
End If
ExitRoutine:
Set oOlInb = Nothing
Set oOlResults = Nothing
Set oOlItm = Nothing
Debug.Print "Done."
End Sub
Note the code is set up to be used in Outlook.

Copy found emails 4 times

I have macro that searches for a subject and if found copy the email in another folder. My problem is that it copies the email 4 times instead of only once. If i have 10 emails in the original folder "Left Ones" then, after search and copy i will have 40 emails in the folder "TO BE REMOVED" . Any help is welcomed, thank you.
Sub Search_Inbox()
Dim myOlApp As New Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim filteredItems As Outlook.Items
Dim itm As Object
Dim Found As Boolean
Dim strFilter As String
Dim subject_to_find As String
Dim myDestFolder As Outlook.Folder
subject_to_find = "something"
Set objNamespace = myOlApp.GetNamespace("MAPI")
Set objFolder = OpenOutlookFolder("\\Mailbox - ME\Inbox\Left Ones")
strFilter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%" & subject_to_find & "%'"
Set filteredItems = objFolder.Items.Restrict(strFilter)
If filteredItems.Count = 0 Then
Debug.Print "No emails found"
Found = False
Else
Found = True
For Each itm In filteredItems
If itm.Class = olMail Then
Debug.Print itm.Subject
Debug.Print itm.ReceivedTime
End If
Set myDestFolder = Session.Folders("Mailbox - ME").Folders("TO BE REMOVED")
For i = filteredItems.Count To 1 Step -1
Dim myCopiedItem As Object
Set myCopiedItem = filteredItems(i).Copy
myCopiedItem.Move myDestFolder
Next i
Next itm
End If
'If the subject isn't found:
If Not Found Then
'NoResults.Show
Else
Debug.Print "Found " & filteredItems.Count & " items."
End If
Set myOlApp = Nothing
End Sub
After
Else
Found = True
add the line
Debug.Print filteredItems.Count
This is to check the number of items found. This way, you can definitely see if VBA actually finds 40 emails (for whatever reason), or if it just copies it 4 times later on.
Also try Changing
Next i
to
i = i + 1
Edit:
Cut the
Next itm
and move it to the end of this block:
For Each itm In filteredItems
If itm.Class = olMail Then
Debug.Print itm.Subject
Debug.Print itm.ReceivedTime
End If
Next itm 'move it here
For future searchers here is the working code to find all the emails with a given subject in a subfolder - Inbox\Left Ones - and copy them in another subfolder - Inbox\TO BE REMOVED - ( note that it will leave out the undelivered notification ) :
Sub Search_Inbox_Subfolder_Left_Ones()
Dim objFolder As Outlook.MAPIFolder
Dim filteredItems As Outlook.Items
Dim itm As Object
Dim Found As Boolean
Dim strFilter As String
Dim subject_to_find As String
Dim myDestFolder As Outlook.Folder
Dim myCopiedItem As Object
subject_to_find = "something to find"
Set objFolder = OpenOutlookFolder("\\Mailbox - ME\Inbox\Left Ones")
strFilter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%" & subject_to_find & "%'"
Set filteredItems = objFolder.Items.Restrict(strFilter)
If filteredItems.Count = 0 Then
Debug.Print "No emails found"
Found = False
Else
Found = True
Set myDestFolder = Session.Folders("Mailbox - ME").Folders("TO BE REMOVED")
For i = filteredItems.Count To 1 Step -1
If filteredItems(i).Class = olMail Then
Set myCopiedItem = filteredItems(i).Copy
myCopiedItem.Move myDestFolder
End If
Next i
End If
'If the subject isn't found:
If Not Found Then
'NoResults.Show
Else
Debug.Print "Found " & filteredItems.Count & " items."
End If
Set myOlApp = Nothing
End Sub
Private Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
Dim arrFolders As Variant, _
varFolder As Variant, _
bolBeyondRoot As Boolean
On Error Resume Next
If strFolderPath = "" Then
Set OpenOutlookFolder = Nothing
Else
Do While Left(strFolderPath, 1) = "\"
strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
Loop
arrFolders = Split(strFolderPath, "\")
For Each varFolder In arrFolders
Select Case bolBeyondRoot
Case False
Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
bolBeyondRoot = True
Case True
Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
End Select
If Err.Number <> 0 Then
Set OpenOutlookFolder = Nothing
Exit For
End If
Next
End If
On Error GoTo 0
End Function

Get the date of reply

The answer to Is there any way to get the date time on the “you replied to this message on [xxx]”? describes a solution with the property PR_LAST_VERB_EXECUTION_TIME.
If that property is absent in the list of properties, can I find the date or the message-answer another way?
There is only property PR_LAST_VERB_EXECUTED in the window "get prop" of the program "outlookSpy".
Sub Extracting()
Dim myolApp As Outlook.Application
Dim myNamespace As Outlook.NameSpace
Dim myFolder, ssBox As Outlook.Folder
Dim sch As Outlook.Search
Dim rsts As Outlook.Results
Dim sDate, eDate, strS, strF, DatiRe As String
Dim i As Integer
Set myolApp = GetObject(, "Outlook.Application")
Set myNamespace = myolApp.GetNamespace("MAPI")
Set mySheet = xlApp.Worksheets("Ëèñò1")
sDate = Format(Date, "dd.mm.yyyy")
eDate = Format(Date, "dd.mm.yyyy")
i = 1
While i <= myNamespace.Folders.Count
If myNamespace.Folders.Item(i).Name = "mmm#mail.ru" Then
Set myFolder = myNamespace.GetFolderFromID(myNamespace.Folders.Item(i).EntryID, myNamespace.Folders.Item(i).StoreID)
i = myNamespace.Folders.Count
End If
i = i + 1
Wend
blnSearchComp = False
Set ssBox = myFolder.Folders("Inbox")
strS = "'" & ssBox.FolderPath & "'"
strF = "urn:schemas:httpmail:datereceived >= '" & sDate & " 0:00' AND urn:schemas:httpmail:datereceived <= '" & eDate & " 23:59'"
Set sch = myolApp.AdvancedSearch(strS, strF, False, "aaa")
While blnSearchComp = False
DoEvents
Wend
Set ssBox = myFolder.Folders("Outbox")
Set rsts = sch.Results
For i = 1 To rsts.Count
Debug.Print rsts.Item(i).SenderName
DatiRe = GetDaTiAnswer(rsts.Item(i).ConversationIndex, rsts.Item(i).ConversationTopic, ssBox.FolderPath)
Set NextRow = mySheet.Range("A" & mySheet.Rows.Count).End(-4162).Offset(1)
NextRow.Resize(, 4).Value = Array(rsts.Item(i).SenderEmailAddress, rsts.Item(i).ReceivedTime, DatiRe, rsts.Item(i).Subject)
Next
End Sub
Function GetDaTiAnswer(ByVal iConvIndex, iConvTopic, parP As String) As String
Dim oApp As Outlook.Application
Dim oSch As Outlook.Search
Dim oRes As Outlook.Results
Dim parC As String
Dim j As Integer
blnSearchComp = False
Set oApp = GetObject(, "Outlook.Application")
parC = "http://schemas.microsoft.com/mapi/proptag/0x0070001F = '" & iConvTopic & "'"
Set oSch = oApp.AdvancedSearch("'" & parP & "'", parC, False, "aaa")
While blnSearchComp = False
DoEvents
Wend
Set oRes = oSch.Results
For j = 1 To oRes.Count
Debug.Print oRes.Item(j).SenderName
If Left(oRes.Item(j).ConversationIndex, Len(oRes.Item(j).ConversationIndex) - 10) = iConvIndex Then
GetDaTiAnswer = oRes.Item(j).SentOn
End If
Next
End Function
According to http://msdn.microsoft.com/en-us/library/office/aa172005(v=office.11).aspx you should be able to access the PR_CLIENT_SUBMIT_TIME which is the MailItem.SentOn property.
So if you find the item in the sent items, that's the property to look for.