Search for appointments by Date/Time to extract subject and description - vba

I'm trying to find an appointment on or after a specific date (for this program today was chosen) in the current session of a single workstation.
I then want to extract the Subject line from the appointment and the Description and display them in a message box (for future error checking).
If possible I also want to count how many appointments are in a single day.
I'm having trouble setting the object as well as binding "i" to the correct item in Outlook's array. I say "Outlook's array" because in the base code I have oItems.Item(i) where i is an Item from some appointment in my calender at the designated number.
Maybe it would be better to use something else besides Item?
Or better yet find an item's location in the array that is relevant to the date that I'm restricting the search to?
Below is the old code before Dmitry's link.
Private Sub FindAppt()
Dim oItems As Items
Dim oItemOriginal As AppointmentItem
Dim Subject As String
Dim Descript As String
Set oItems = Outlook.Application.Session.GetDefaultFolder(olFolderCalendar).Items
If oItems >= Format(Date, "mmmm dd yyyy") Then
Set oItemOriginal = oItems.Item(i)
End If
With oItemOriginal
Subject = .Subject
Descript = .FormDescription
End With
MsgBox (Subject & Description)
End Sub
New code. With the new approach should I be breaking up these array binding and array extraction pieces into separate "Subs"?
Sub FindAppt()
Dim myNameSpace As Outlook.NameSpace
Dim tdystart As Date
Dim tdyend As Date
Dim myAppointments As Outlook.Items
Dim currentAppointment As Outlook.AppointmentItem
Dim SubjectArray(50) As Variant
Dim i As Integer
Dim DescArray(50) As Variant
Dim Excl As Excel.Application
Set myNameSpace = Application.GetNamespace("MAPI")
'This line is Bonus, if you're just looking to start your search for today's_
date.
tdystart = VBA.Format(Now, "Short Date")
'This input works which means a user form with combo boxes will work or user input_
will work as long as user input conforms to VBA date formats.
'tdystart = "04/01/2014"
'This line is Bonus, if you're just looking for the day after and after_
appointments.
tdyend = VBA.Format(Now + 1, "Short Date")
'tdyend = VBA.Format(tdystart + 5, "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"
MsgBox currentAppointment.Subject & " " & currentAppointment.FormDescription
While currentAppointment = True
For i = 0 To 50
SubjectArray(i) = currentAppointment.Subject
DescArray(i) = currentAppointment.FormDescription
ReDim Preserve SubjectArray(1 To Count + 1)
ReDim Preserve DescArray(1 To Count + 1)
Next i
Wend
Set currentAppointment = myAppointments.FindNext
Wend
End Sub
Private Sub Timecard()
Set Excl = Excel.Application
Dim i As Integer
Dim SubjectArray(byRef 50, byValue) As Variant
Dim DecArray (byRef,byvalue)
With Excl
.fPath = ("C:\FilePathName\Book1.xlsx")
Excl.Open
End With
For i = 0 To 50
Excl.Application.Activesheet.Range(i, 0) = SubjectArray(i)
Excl.Application.Activesheet.Range(i, 1) = DecArray(i)
Next
End Property
End Sub

I am not sure what the line "If oItems >= Format(Date, "mmmm dd yyyy") Then" is supposed to do: you are comparing an Items object with a string.
See http://msdn.microsoft.com/en-us/library/office/ff866969(v=office.15).aspx for an example on how to retrieve items in a particular time range.

Related

Export Outlook-Calendar with recurring meetings with VBA Macro

I created a VBA-macro to send my Outlook-calendar from my Work-account to my private Mail to import the appointments to my private calendar.
Now i realised that only the first appointment of a recurring appointment is exported.
Only if i use this configuration, all appointments are exported:
CalendarDetail = olFreeBusyOnly
Is there a way to export all appointments including the recurrences, but using "olFreeBusyAndSubject" or "olFullDetails" as setting?
I used this code:
Sub CalenderExport()
Dim ol As Outlook.Application
Dim cal As Folder
Dim exporter As CalendarSharing
Dim FirstDayInMonth, LastDayInMonth As Variant
Dim dtmDate As Date
Dim mi As MailItem
dtmDate = Date
FirstDayInMonth = DateSerial(Year(Date), Month(Date), 0)
LastDayInMonth = DateSerial(Year(Date), Month(Date) + 1, 0)
Set ol = Application
Set cal = ol.Session.GetDefaultFolder(olFolderCalendar)
Set exporter = cal.GetCalendarExporter
With exporter
.CalendarDetail = olFullDetails
.IncludeAttachments = False
.IncludePrivateDetails = False
.RestrictToWorkingHours = False
.IncludeWholeCalendar = False
.StartDate = FirstDayInMonth
.EndDate = LastDayInMonth
Set mi = .ForwardAsICal(olCalendarMailFormatEventList)
End With
With mi
.Body = "Kalenderexport"
.To = "my_mail#live.de"
.Subject = Date & " " & Time & " Calendar"
.Send
End With
End Sub
And this site for reference:
https://learn.microsoft.com/de-de/office/vba/api/outlook.calendarsharing.calendardetail
Thanks in advance
The code looks good, I don't see anything suspicious.
But to make sure that everything is exported correctly you may try to get all items for a specific date range by using the Find/FindNext or Restrict methods of the Items class. So, try to run the following code sample and then compare the results:
Sub DemoFindNext()
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"
MsgBox currentAppointment.Subject
Set currentAppointment = myAppointments.FindNext
Wend
End Sub

Retrieve Outlook email count from sent folder of the last month (through word VBA)

I've been trying to filter my outlook sent folder in Word to get the count of the total emails from last month.
' Connect to outlook
Dim outlook As Object
Dim NumEmails As Long
Dim name_space As Object
Dim SentFolder As MAPIFolder
Dim criterion As String
Set outlook = CreateObject("Outlook.Application")
Set name_space = outlook.GetNamespace("MAPI")
On Error Resume Next
Set SentFolder = name_space.GetDefaultFolder(olFolderSentMail)
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder."
Exit Sub
End If
If Month(Date) = 1 And Day(Date) < 27 Then
' It's January but we're reporting Decemember
criterion = ""
ElseIf Day(Date) > 27 Then
' It's the end of the month; pull this month's data
criterion = ""
Else
' It's not the end of the month; pull last month's data
criterion = ""
End If
Is what I got so far, but I'm stuck what to put as my criterion variable and how to utilize it for filtering the folder.
Any help will be appreciated.
With date code from one of multiple possible sites you can filter like this:
Option Explicit
Private Sub ItemsByMonth()
Dim myStart As Date
Dim myEnd As Date
Dim outlook As Object
Dim name_space As Object
Dim SentFolder As Object
Dim oItems As Items
Dim oitem As Object
Dim strRestriction As String
Dim oResItems As Items
Set outlook = CreateObject("Outlook.Application")
Set name_space = outlook.GetNamespace("MAPI")
' http://www.anysitesupport.com/vba-time-and-date-functions/
If Day(Date) < 27 Then
'Last day of previous month
myEnd = DateSerial(Year(Date), Month(Date), 0)
Else
'Last day of month
myEnd = DateSerial(Year(Date), Month(Date) + 1, 0)
End If
' First day of the myEnd month
myStart = DateSerial(Year(myEnd), Month(myEnd), 1)
Set SentFolder = name_space.GetDefaultFolder(olFolderSentMail)
Set oItems = SentFolder.Items
strRestriction = "[SentOn] <= '" & myEnd & "' AND [SentOn] >= '" & myStart & "'"
Set oResItems = oItems.Restrict(strRestriction)
Debug.Print oResItems.count
ExitRoutine:
Set outlook = Nothing
Set name_space = Nothing
Set SentFolder = Nothing
Set oItems = Nothing
Set oResItems = Nothing
End Sub

Find emails in inbox from a specific date and move them to a new folder

My goal is to:
Search the inbox for emails from a specific date
Create a subfolder named as the specific date
Move the emails to the subfolder
The closest VBA code I found is supposed to ask the user the date range then export the info to Excel.
I don't want to export anything to Excel, but I thought the code could be a good place to start to find the emails. It isn't finding anything within that range.
Here is the code as of now:
Const FILE_NAME = "C:\Users\tboulay\Desktop\Outlook Date Results.xlsx"
Const MACRO_NAME = "Date/Time Search"
Private datBeg As Date, datEnd As Date, timBeg As Date, timEnd As Date
Private excApp As Object, excWkb As Object, excWks As Object, lngRow
Public Sub BeginSearch()
Dim strRng As String, arrTmp As Variant, arrDat As Variant, arrTim As Variant
strRng = InputBox("Enter the date/time range to search in the form Date1 to Date2 from Time1 to Time2", MACRO_NAME, "6/1/2018 to 6/2/2018 from 12:00am to 12:00am")
If strRng = "" Then
MsgBox "Search cancelled.", vbInformation + vbOKOnly, MACRO_NAME
Else
arrTmp = Split(strRng, " from ")
arrDat = Split(arrTmp(0), " to ")
arrTim = Split(arrTmp(1), " to ")
datBeg = arrDat(0)
datEnd = arrDat(1)
timBeg = arrTim(0)
timEnd = arrTim(1)
If IsDate(datBeg) And IsDate(datEnd) And IsDate(timBeg) And IsDate(timEnd) Then
Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Add
Set excWks = excWkb.Worksheets(1)
excWks.Cells(1, 1) = "Folder"
excWks.Cells(1, 2) = "Received"
excWks.Cells(1, 3) = "Sender"
excWks.Cells(1, 4) = "Subject"
lngRow = 2
SearchSub Application.ActiveExplorer.CurrentFolder
excWks.Columns("A:D").AutoFit
excWkb.SaveAs FILE_NAME
excWkb.Close False
Set excWks = Nothing
Set excWkb = Nothing
Set excApp = Nothing
MsgBox "Search complete.", vbInformation + vbOKOnly, MACRO_NAME
Else
MsgBox "The dates/times you entered are invalid or not in the right format. Please try again.", vbCritical + vbOKOnly, MACRO_NAME
End If
End If
End Sub
Private Sub SearchSub(olkFol As Outlook.MAPIFolder)
Dim olkHit As Outlook.Items, olkItm As Object, olkSub As Outlook.MAPIFolder, datTim As Date
'If the current folder contains messages, then search it
If olkFol.DefaultItemType = olMailItem Then
Set olkHit = olkFol.Items.Restrict("[ReceivedTime] >= '" & Format(datBeg, "ddddd h:nn AMPM") & "' AND [ReceivedTime] <= '" & Format(datEnd, "ddddd h:nn AMPM") & "'")
For Each olkItm In olkHit
If olkItm.Class = olMail Then
datTim = Format(olkItm.ReceivedTime, "h:n:s")
If datTim >= timBeg And datTim <= timEnd Then
excWks.Cells(lngRow, 1) = olkFol.FolderPath
excWks.Cells(lngRow, 2) = olkItm.ReceivedTime
excWks.Cells(lngRow, 3) = olkItm.SenderName
excWks.Cells(lngRow, 4) = olkItm.Subject
lngRow = lngRow + 1
End If
End If
DoEvents
Next
Set olkHit = Nothing
Set olkItm = Nothing
End If
'Search the subfolders
For Each olkSub In olkFol.Folders
SearchSub olkSub
DoEvents
Next
Set olkSub = Nothing
End Sub
For example, I search the range "6/8/2018 to 6/9/2018 from 12:00am to 12:00am", which I have 3 emails in that date range, however it isn't finding anything.
Below is the code I ended up using to get the task done. I am still working on making it run faster, but this gets the job done (slower).
It will move the previous workday's emails from a secondary inbox into a newly created subfolder with the date and day.
Sub Move_Yesterdays_Emails()
'***Creates a new folder named yesterdays date under the inbox***
Dim myNameSpace As Outlook.NameSpace
Dim strMailboxName As String
Dim myFolder As Outlook.Folder
Dim myNewFolder As Outlook.Folder
Dim xDay As String
Dim XDate As Date
Dim thatDay As String
strMailboxName = "Deductions Backup"
If Weekday(Now()) = vbMonday Then
XDate = Date - 3
Else
XDate = Date - 1
End If
thatDay = WeekdayName(Weekday(XDate))
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder = Session.Folders(strMailboxName)
Set myFolder = myFolder.Folders("Inbox")
Set myNewFolder = myFolder.Folders.Add(XDate & " " & thatDay)
'***Finds all emails in the inbox from yesterday and moves them to the created folder***
Dim Inbox As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim Item As Object
Dim Filter As String
Dim i As Long
Filter = "[ReceivedTime] >= '" & _
CStr(XDate) & _
" 12:00AM' AND [ReceivedTime] < '" & _
CStr(XDate + 1) & " 12:00AM'"
Debug.Print Filter
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder = Session.Folders(strMailboxName)
Set Inbox = myFolder.Folders("Inbox")
Set Items = Inbox.Items.Restrict(Filter)
Items.Sort "[ReceivedTime]"
For i = Items.Count To 1 Step -1
DoEvents
If TypeOf Items(i) Is MailItem Then
Debug.Print Items(i)
Set Item = Items(i)
Item.Move myNewFolder
End If
Next
End Sub

Outlook find Email in inbox by string (part of body)

I simply want to select all mail in my inbox that contain (in Body) a certain string. I thought Find would be a good Approach. Rather to make a for..each on all items in inbox...
However my command does (see below) not work. It brings "invalid condition"
Set Msg = Inbox.Items.Find("abc")
2 Questions:
1. How to fill in the desired condition?
2. What is result of that find? A single email or a collection I need to put in a variant or so
The Find method locates and returns a Microsoft Outlook item object that satisfies the given Filter. See Filtering Items Using Query Keywords for more information about possible query strings. After the Find method runs, the FindNext method finds and returns the next Outlook item in the specified collection. For example:
Sub DemoFindNext()
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
Set currentAppointment = myAppointments.Find("[Start] >= """ & tdystart & """ and [Start] <= """ & tdyend & """")
While TypeName(currentAppointment) <> "Nothing"
MsgBox currentAppointment.Subject
Set currentAppointment = myAppointments.FindNext
Wend
End Sub

Check e-mails in specific time frame

I need to check items in a folder in a specific time frame.
My code goes through all the mails in the specified folder, but the folder has thousands of mails, so it takes forever.
How do I check the mails only from, for example, 3/16/2015 12:00PM to 3/16/2015 2:00PM?
This is what I have:
Sub ExportToExcel()
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim workbookFile As String
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
'Folder path and file name of an existing Excel workbook
workbookFile = "C:\Users\OutlookItems.xls"
'Select export folder
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
'Handle potential errors with Select Folder dialog box.
If fld Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub
End If
' Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
Set wkb = appExcel.Workbooks.Open(workbookFile)
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
Set rng = wks.Range("A1")
'Copy field items in mail folder.
For Each itm In fld.Items
If itm.Class = Outlook.OlObjectClass.olMail Then
Set msg = itm
If InStr(msg.Subject, "Error in WU_Send") > 0 And DateDiff("h", msg.SentOn, Now) <= 2 Then
rng.Offset(0, 4).Value = msg.Body
Set rng = rng.Offset(1, 0)
End If
End If
Next
End Sub
The problem lies in this part:
For Each itm In fld.Items
If itm.Class = Outlook.OlObjectClass.olMail Then
Set msg = itm
If InStr(msg.Subject, "Error in WU_Send") > 0 And DateDiff("h", msg.SentOn, Now) <= 2 Then
How do I look at e-mails between specified hours?
You need to use the Find/FindNext or Restrict methods of the Items class instead of iterating through all items in the folder. For example:
Sub DemoFindNext()
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
Set currentAppointment = myAppointments.Find("[Start] >= """ & tdystart & """ and [Start] <= """ & tdyend & """")
While TypeName(currentAppointment) <> "Nothing"
MsgBox currentAppointment.Subject
Set currentAppointment = myAppointments.FindNext
Wend
End Sub
See the following articles for more information and sample code:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
Also you may find the AdvancedSearch method of the Application class helpful. The key benefits of using the AdvancedSearch method are listed below:
The search is performed in another thread. You don’t need to run another thread manually since the AdvancedSearch method runs it automatically in the background.
Possibility to search for any item types: mail, appointment, calendar, notes etc. in any location, i.e. beyond the scope of a certain folder. The Restrict and Find/FindNext methods can be applied to a particular Items collection (see the Items property of the Folder class in Outlook).
Full support for DASL queries (custom properties can be used for searching too). You can read more about this in the Filtering article in MSDN. To improve the search performance, Instant Search keywords can be used if Instant Search is enabled for the store (see the IsInstantSearchEnabled property of the Store class).
You can stop the search process at any moment using the Stop method of the Search class.
You could just change the line to:
If InStr(msg.Subject, "Error in WU_Send") > 0 And msg.SentOn > "03/16/2015 12:00 PM" AND msg.SentOn < "03/16/2015 2:00 PM" Then
This specifies the time period.
Option Explicit
Sub RestrictTimePeriod()
Dim nms As Namespace
Dim fld As folder ' Subsequent to 2003 otherwise MAPIFolder
Dim msg As MailItem
Dim filterCriteria As String
Dim filterItems As Items
Dim i As Long
Dim start
Dim dif
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
If Not fld Is Nothing Then
start = Now
Debug.Print start
' http://www.jpsoftwaretech.com/use-filters-to-speed-up-outlook-macros/
filterCriteria = "[ReceivedTime] > " & QuoteWrap("2015-03-16 12:00 PM") & _
" And [ReceivedTime] < " & QuoteWrap("2015-03-17 2:00 PM")
Set filterItems = fld.Items.Restrict(filterCriteria)
For i = filterItems.count To 1 Step -1
Set msg = filterItems.Item(i)
Debug.Print msg.Subject
Next
End If
ExitRoutine:
Set nms = Nothing
Set msg = Nothing
Set filterItems = Nothing
Debug.Print Now
dif = (Now - start) * 86400
Debug.Print dif
Debug.Print "Done."
End Sub
Function QuoteWrap(stringToWrap As String, _
Optional charToUse As Long = 39) As String
' http://www.jpsoftwaretech.com/use-filters-to-speed-up-outlook-macros/
' use 34 for double quotes, 39 for apostrophe
QuoteWrap = Chr(charToUse) & stringToWrap & Chr(charToUse)
End Function