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.
Related
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
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")
I auto export email details from Outlook to Excel every time a new mail is received. Emails are exported correctly into Excel.
I want to refine the code such that only mails with a specific subject is exported into Excel.
Code used is as follows:
Public WithEvents objMails As Outlook.Items
Private Sub Application_Startup()
Set objMails = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub objMails_ItemAdd(ByVal Item As Object)
Dim objMail As Outlook.MailItem
Dim strExcelFile As String
Dim objExcelApp As Excel.Application
Dim objExcelWorkBook As Excel.Workbook
Dim objExcelWorkSheet As Excel.Worksheet
Dim nNextEmptyRow As Integer
Dim strColumnB As String
Dim strColumnC As String
Dim strColumnD As String
Dim strColumnE As String
Dim strColumnF As String
If Item.Class = olMail Then
Set objMail = Item
End If
'Specify the Excel file which you want to auto export the email list
'You can change it as per your case
strExcelFile = "C:\Users\pddamoda\Desktop\abc.xlsx"
'Get Access to the Excel file
On Error Resume Next
Set objExcelApp = GetObject(, "Excel.Application")
If Error <> 0 Then
Set objExcelApp = CreateObject("Excel.Application")
End If
Set objExcelWorkBook = objExcelApp.Workbooks.Open(strExcelFile)
Set objExcelWorkSheet = objExcelWorkBook.Sheets("Sheet1")
'Get the next empty row in the Excel worksheet
nNextEmptyRow = objExcelWorkSheet.Range("B" & objExcelWorkSheet.Rows.Count).End(xlUp).Row + 1
'Specify the corresponding values in the different columns
strColumnB = objMail.SenderName
strColumnC = objMail.SenderEmailAddress
strColumnD = objMail.Subject
strColumnE = objMail.ReceivedTime
strColumnF = objMail.Body
'Add the vaules into the columns
objExcelWorkSheet.Range("A" & nNextEmptyRow) = nNextEmptyRow - 1
objExcelWorkSheet.Range("B" & nNextEmptyRow) = strColumnB
objExcelWorkSheet.Range("C" & nNextEmptyRow) = strColumnC
objExcelWorkSheet.Range("D" & nNextEmptyRow) = strColumnD
objExcelWorkSheet.Range("E" & nNextEmptyRow) = strColumnE
objExcelWorkSheet.Range("F" & nNextEmptyRow) = strColumnF
'Fit the columns from A to E
objExcelWorkSheet.Columns("A:F").AutoFit
'Save the changes and close the Excel file
objExcelWorkBook.Close SaveChanges:=True
End Sub
Below is an example of using Item.Restrict, Restrict is better when you have large search range. You can read this post for more information: Find an email starting with specific subject using VBA
sub exampleFilter()
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 eFilter As String
Set myOlApp = GetObject(, "Outlook.Application")
Set objNamespace = myOlApp.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)
Dim emailSubject As String
emailSubject = "The Subject You like to Filter"
eFilter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & _
Chr(34) & " = '" + emailSubject + "'"
Set filteredItems = objFolder.Items.Restrict(eFilter)
If filteredItems.Count = 0 Then
debug.print "No Email with that subject found"
Else
For Each itm In filteredItems
Debug.Print itm.Subject
Next
End If
If filteredItems.Count <> 0 Then
Debug.Print "Found " & filteredItems.Count & " items."
End If
End Sub
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
a server sends me emails with a link file in each email.
Do you knwow if it exists a VBA code which opens each email, download each link file in a local directory, and move the email in another directory (as done) ?
Thanks a lot for your reply.
Christophe
If you want to download emails from Outlook, you can try this script.
Option Explicit On
Const fPath As String = "C:\Users\your_path_here\" 'The path to save the messages
Sub Download_Outlook_Mail_To_Excel()
Dim olApp As Object
Dim olFolder As Object
Dim olNS As Object
Dim xlBook As Workbook
Dim xlSheet As Worksheet
Dim NextRow As Long
Dim i As Long
Dim olItem As Object
Set xlBook = Workbooks.Add
Set xlSheet = xlBook.Sheets(1)
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err() <> 0 Then
Set olApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
With xlSheet
.Cells(1, 1) = "Sender"
.Cells(1, 2) = "Subject"
.Cells(1, 3) = "Date"
'.Cells(1, 4) = "Size"
.Cells(1, 5) = "EmailID"
.Cells(1, 6) = "Body"
CreateFolders fPath
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.PickFolder
For Each olItem In olFolder.Items
NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
If olItem.Class = 43 Then
.Cells(NextRow, 1) = olItem.Sender
.Cells(NextRow, 2) = olItem.Subject
.Cells(NextRow, 3) = olItem.SentOn
'.Cells(NextRow, 4) =
.Cells(NextRow, 5) = SaveMessage(olItem)
'.Cells(NextRow, 6) = olItem.Body 'Are you sure?
End If
Next olItem
End With
MsgBox "Outlook Mails Extracted to Excel"
lbl_Exit:
Set olApp = Nothing
Set olFolder = Nothing
Set olItem = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
Exit Sub
End Sub
Function SaveMessage(olItem As Object) As String
Dim Fname As String
Fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) &
Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.sendername & " - " & olItem.Subject
Fname = Replace(Fname, Chr(58) & Chr(41), "")
Fname = Replace(Fname, Chr(58) & Chr(40), "")
Fname = Replace(Fname, Chr(34), "-")
Fname = Replace(Fname, Chr(42), "-")
Fname = Replace(Fname, Chr(47), "-")
Fname = Replace(Fname, Chr(58), "-")
Fname = Replace(Fname, Chr(60), "-")
Fname = Replace(Fname, Chr(62), "-")
Fname = Replace(Fname, Chr(63), "-")
Fname = Replace(Fname, Chr(124), "-")
SaveMessage = SaveUnique(olItem, fPath, Fname)
lbl_Exit:
Exit Function
End Function
Private Function SaveUnique(oItem As Object,
strPath As String,
strFileName As String) As String
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName)
Do While FileExists(strPath & strFileName & ".msg") = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
oItem.SaveAs strPath & strFileName & ".msg"
SaveUnique = strPath & strFileName & ".msg"
lbl_Exit:
Exit Function
End Function
Private Sub CreateFolders(strPath As String)
Dim strTempPath As String
Dim iPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For iPath = 1 To UBound(vPath)
strPath = strPath & vPath(iPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next iPath
End Sub
Private Function FolderExists(ByVal PathName As String) As Boolean
Dim nAttr As Long
On Error GoTo NoFolder
nAttr = GetAttr(PathName)
If (nAttr And vbDirectory) = vbDirectory Then
FolderExists = True
End If
NoFolder:
End Function
Private Function FileExists(filespec) As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function
Now, let's say you want to download emails and save each individual text files, run this script.
Public Sub ProcessInbox()
Dim oOutlook As Outlook.Application
Dim oNs As Outlook.NameSpace
Dim oFldr As Outlook.MAPIFolder
Dim oAttachments As Outlook.Attachments
Dim oAttachment As Outlook.Attachment
Dim iMsgCount As Integer
Dim oMessage As Outlook.MailItem
Dim iCtr As Long, iAttachCnt As Long
Dim sFileNames As String
Dim aFileNames() As String
'get reference to inbox
Set oOutlook = New Outlook.Application
Set oNs = oOutlook.GetNamespace("MAPI")
Set oFldr = oNs.GetDefaultFolder(olFolderInbox)
Debug.Print "Total Items: "; oFldr.Items.Count
Debug.Print "Total Unread items = " & oFldr.UnReadItemCount
For Each oMessage In oFldr.Items
With oMessage
'basic info about message
Debug.Print.To
Debug.Print.CC
Debug.Print.Subject
Debug.Print.Body
If .UnRead Then
Debug.Print "Message has not been read"
Else
Debug.Print "Message has been read"
End If
iMsgCount = iMsgCount + 1
'save message as text file
.SaveAs "C:\message" & iMsgCount & ".txt", olTXT
'reference and save all attachments
With oMessage.Attachments
iAttachCnt = .Count
If iAttachCnt > 0 Then
For iCtr = 1 To iAttachCnt
.Item(iCtr).SaveAsFile "C:\Users\your_path_here\" & .Item(iCtr).FileName
Next iCtr
End If
End With
End With
DoEvents
Next oMessage
Set oAttachment = Nothing
Set oAttachments = Nothing
Set oMessage = Nothing
Set oFldr = Nothing
Set oNs = Nothing
Set oOutlook = Nothing
End Sub
You can read all about these techniques, and many, many, many more things, in my book.
https://www.amazon.com/Automating-Business-Processes-Reducing-Increasing-ebook/dp/B01DJJKVZC/ref=sr_1_1?ie=UTF8&qid=1468466759&sr=8-1&keywords=ryan+shuell