I have some coding which imports several folders worth of stored emails into Excel and it works as expected. However the coding brings back all stored emails from the folders, I would like it to return only the previous month's emails. I have some formulas in place which are dynamic and automatically update the previous months start and end date, I know I need to reference these ranges within the coding.
How would I add the date criteria to the below coding (if at all possible)?
TIA
Sub test()
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olFldr As Outlook.MAPIFolder
Dim olItem As Object
Dim olMailItem As Outlook.MailItem
Dim ws As Worksheet
Dim iRow As Long
Dim hdr As Variant
Dim iFldr As Long
Set ws = ThisWorkbook.Worksheets("EmailImport")
Set olApp = New Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
With ws
iRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Application.ScreenUpdating = False
For iFldr = 1 To 18
Select Case iFldr
Case 1
Set olFldr = olNS.Folders("test1").Folders("test1").Folders("test1")
Set olFldr = olFldr.Folders("test1a")
Case 2
Set olFldr = olNS.Folders("test1").Folders("test1").Folders("test1")
Set olFldr = olFldr.Folders("test1b")
Case Else
End Select
For Each olItem In olFldr.Items
If olItem.Class = olMail Then
Set olMailItem = olItem
With olMailItem
iRow = iRow + 1
If Not .Sender Is Nothing Then ws.Cells(iRow, "A") = .Sender
ws.Cells(iRow, "B") = .SenderEmailAddress
ws.Cells(iRow, "C") = .SenderName
ws.Cells(iRow, "D") = .Subject
ws.Cells(iRow, "E") = .ReceivedTime
ws.Cells(iRow, "F") = .Categories
ws.Cells(iRow, "G") = .TaskCompletedDate
ws.Cells(iRow, "H") = olFldr.Name
End With
End If
Next olItem
Next iFldr
With ws
hdr = Array("Sender", "SenderEmailAddress", "SenderName", "Subject", "ReceivedTime", "Categories", "TaskCompletedDate", "Folder")
.Range("A1").Resize(, UBound(hdr)) = hdr
.Columns.AutoFit
End With
End Sub
You could calculate the difference between when it was sent and when you are processing it:
Dim Difference As Long
Difference = DateDiff("d", olItem.SentOn, Now)
If Difference < 30 Then
' Do Stuff
End If
If you want a date comparison this should be possible via an equality statement but make sure the dates are converted to CDate values beforehand
You can create a restriction on the ReceivedTime property and pass it to Items.Restrict (which returns a new restricted Items collection:
([ReceivedTime] > '04/01/2021') AND ([ReceivedTime] < '04/21/2021')
Related
this is my first time posting to StackOverflow so please bare with me if I'm doing something wrong.
I am using the following macro to get a list of meetings older than 7 days but I can't figure out how to get it to show recurring meetings. Can you please point out what I'm doing wrong?
Option Explicit
Sub ListAppointments()
Dim olApp As Object
Dim olNS As Object
Dim olFolder As Object
Dim olApt As Object
Dim NextRow As Long
Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.GetDefaultFolder(9)
Worksheets("GetMeetings").Activate
Range("A1:e1").Value = Array("Organizer", "Subject", "Start", "End")
NextRow = 2
For Each olApt In olFolder.Items
If (olApt.Start >= Now - 7) Then
Cells(NextRow, "A").Value = olApt.Organizer
Cells(NextRow, "B").Value = olApt.Subject
Cells(NextRow, "C").Value = olApt.Start
Cells(NextRow, "D").Value = olApt.End
'Cells(NextRow, "E").Value = olApt.Location
NextRow = NextRow + 1
Else
End If
Next olApt
'AutoFit
Worksheets("GetMeetings").Columns.AutoFit
Set olApt = Nothing
Set olFolder = Nothing
Set olNS = Nothing
Set olApp = Nothing
Columns.AutoFit
End Sub
You can expand recurrences if you use Items.Find/FindNext or Items.Restrict and set the Items.IncludeRecurrences to true. See https://learn.microsoft.com/en-us/office/vba/api/outlook.items.includerecurrences for an example and more details.
I have two email address. The first is address1#domain.com.vn and the second is address2#domain.com.vn.
I want to copy email subject in microsoft outlook with second address address2#domain.com.vn to excel using vba. I use bellow code but it do not work.
Sub GetFromInbox()
Dim olapp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olMail As Variant
Dim Pst_Folder_Name
Dim MailboxName
'Dim date1 As Date
Dim i As Integer
Sheets("sheet1").Visible = True
Sheets("sheet1").Select
Cells.Select
Selection.ClearContents
Cells(1, 1).Value = "Date"
Set olapp = New Outlook.Application
Set olNs = olapp.GetNamespace("MAPI")
Set Fldr = olNs.ActiveExplorer.CurrentFolder.Items
MailboxName = "address2#domain.com.vn"
Pst_Folder_Name = "Inbox"
Set Fldr = Outlook.Session.Folders(MailboxName).Folders(Pst_Folder_Name)
i = 2
For Each olMail In Fldr.Items
'For Each olMail In olapp.CurrentFolder.Items
ActiveSheet.Cells(i, 1).Value = olMail.ReceivedTime
ActiveSheet.Cells(i, 3).Value = olMail.Subject
ActiveSheet.Cells(i, 4).Value = olMail.SenderName
i = i + 1
Next olMail
End Sub
try this
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 = "address2#domain.com.vn"
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
i = i + 1
Next olMail
End With
olapp.Quit
Set olapp = Nothing
End Sub
If your using ActiveExplorer.CurrentFolder then you don't need to set your email Inbox, code should run on currently displayed folder in explorer.
Example
Option Explicit
Public Sub Example()
Dim Folder As MAPIFolder
Dim CurrentExplorer As Explorer
Dim Item As Object
Dim App As Outlook.Application
Dim Items As Outlook.Items
Dim LastRow As Long, i As Long
Dim xlStarted As Boolean
Dim Book As Workbook
Dim Sht As Worksheet
Set App = Outlook.Application
Set Folder = App.ActiveExplorer.CurrentFolder
Set Items = Folder.Items
Set Book = ActiveWorkbook
Set Sht = Book.Worksheets("Sheet1")
LastRow = Sht.Range("A" & Sht.Rows.Count).End(xlUp).Row
i = LastRow + 1
For Each Item In Items
If Item.Class = olMail Then
Sht.Cells(i, 1) = Item.ReceivedTime
Sht.Cells(i, 2) = Item.SenderName
Sht.Cells(i, 3) = Item.Subject
i = i + 1
Book.Save
End If
Next
Set Item = Nothing
Set Items = Nothing
Set Folder = Nothing
Set App = Nothing
End Sub
I have this line of code I've tried to add multiple CC's in the Outlook Mail. But it only returns ;. I have found this sample at MSDN.
Dim ccMail as String
Dim ccRow as Long
Dim objMail as Object
ccRow = Cells(Rows.count, 16).End(xlUp).Row
With objMail
.Subject = Sheet1.TextBox1.Value
For k = 4 To ccRow
ccMail = ccMail & ";" & Cells(k, 1).Value
Next k
.cc = ccMail
end with
All of the CC Recipients is found in column P.
Any help?Thanks.
You used With objMail but did not specify Worksheet for Cells(k, 1).Value. This is likely to result in an error.
In addition, I presume you want to refer to ws.Cells(k, 16) instead since what you want is column P.
Here is an Example on how to loop using Do-Until Loops to get cell Values.
Option Explicit
Sub Example()
Dim olApp As Object
Dim olMail As Object
Dim olRecip As Object
Dim iRow As Long
Dim Recip As String
Dim Sht As Worksheet
iRow = 2
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(0)
Set Sht = ActiveWorkbook.Sheets("Sheet1")
With Sht
With olMail
Do Until IsEmpty(Cells(iRow, 16))
Recip = Cells(iRow, 16).Value
Set olRecip = .Recipients.Add(Recip)
olRecip.Type olCC
olRecip.Resolve
iRow = iRow + 1
Loop
.Subject = "Subject"
.Body = "Hi " & .Body
.Display
End With
End With
Set olApp = Nothing
End Sub
Do-Until loop and IsEmpty
The code below is sourced from another SO post: Excel VBA Code to retrieve e-mails from outlook.
THe purpose is to find information from Outlook e-mails and put them into Excel.
Sub test2()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olMail As Outlook.MailItem
Dim eFolder As Outlook.Folder
Dim i As Long
Dim x As Date
Dim wb As Workbook
Dim ws As Worksheet
Dim iCounter As Long
Dim lrow As Long
Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Sheet1")
wb.Activate
ws.Select
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
x = Date
For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders
Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders(eFolder.Name)
For i = olFolder.Items.Count To 1 Step -1
If TypeOf olFolder.Items(i) Is MailItem Then
Set olMail = olFolder.Items(i)
For iCounter = 2 To lrow
If InStr(olMail.SenderEmailAddress, ws.Cells(iCounter, 5).Value) > 0 Then
With ws
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("A" & lrow).Offset(1, 0).Value = olMail.Subject
.Range("A" & lrow).Offset(1, 1).Value = olMail.ReceivedTime
.Range("A" & lrow).Offset(1, 2).Value = olMail.SenderEmailAddress
End With
End If
Next iCounter
End If
Next i
Set olFolder = Nothing
Next eFolder
End Sub
WHen i debug and hover over the last few lines, it seems the code is extracting information from Outlook properly. However, the extracted data(subject of e-mail, etc) aren't populated in my worksheet. From what I can gather I've set the worksheet variable correctly, don't really know what's going on.
Thanks for all the help
Update:
Worksheet is populating now. I am trying to get the code to go through a column of e-mail addresses, and extract "time received" from the emails if the addresses match with those in my folders.
Made some changes. See if this works.
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olMail As Outlook.MailItem
Dim eFolder As Outlook.folder
Dim i As Long
Dim x As Date
Dim wb As Workbook
Dim ws As Worksheet
Dim iCounter As Long
Dim lrow As Long
Set wb = ActiveWorkbook
Set ws = wb.WorkSheets("Sheet1")
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
x = Date
'i think you want column E here, not L?
lastRow = ThisWorkbook.WorkSheets("Sheet1").Cells(Rows.Count, "L").End(xlUp).Row
For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders
Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders(eFolder.name)
For i = olFolder.Items.Count To 1 Step -1
For iCounter = 2 To lastRow
If TypeOf olFolder.Items(i) Is MailItem Then
Set olMail = olFolder.Items(i)
If InStr(olMail.SenderEmailAddress, ws.Cells(iCounter, 5).Value) > 0 Then 'qualify the cell
With ws
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("A" & lrow + 1).Value = olMail.SUBJECT
.Range("B" & lrow + 1).Value = olMail.ReceivedTime
.Range("C" & lrow + 1).Value = olMail.SenderEmailAddress
End With
End If
Next iCounter
End If
Next i
Set olFolder = Nothing
Are the emails you're looking for in your inbox or a subfolder? The code is ONLY looking in each FOLDER in the inbox, it's not looking in the actual inbox.
Try these changes:
Dim i As Long, j As Long 'Add "j as long"
'For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders
For j = 0 To olNs.GetDefaultFolder(olFolderInbox).Folders.Count ' loop through the folders, starting at 0 (which we'll call the inbox)
If j = 0 Then
Set olFolder = olNs.GetDefaultFolder(olFolderInbox)
Else
Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders(j)
End If
...rest of loop
Next ' Remove 'efolder' from here
I am using VBA in Outlook to extract mail information from items in the mainfolder and subfolder. The mainfolder failed to set(capture) the subfolder properties into it and it causes the runtime error.
The runtime error differs whenever I run. For example, sometime I received -970718969 (c6240107) and another time I received -2044460793 (86240107).
When I clicked debug, it points to this line of code:
For Each itm In subFld.Items
Here is the screenshot:
Here is the full code:
Public monthValue As Integer
Public yearValue As String
'Ensure Microsoft Excel 11.0 Object Library is ticked in tools.
Sub ExportToExcel1()
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim mainFld As Outlook.MAPIFolder
Dim subFld As Outlook.MAPIFolder
Dim itm As Object
Dim offsetRow As Long
Dim emailCount As Long
'Set the path of the excel file.
strSheet = "For fun.xlsx"
strPath = "C:\Users\xxxxxx\Desktop\xxxxx\"
strSheet = strPath & strSheet
Debug.Print strSheet
Set nms = Application.GetNamespace("MAPI")
Set mainFld = nms.PickFolder 'Open the box to select the file.
'Handle potential errors with Select Folder dialog box.
If mainFld Is Nothing Then
MsgBox "Thank you for using this service.", vbOKOnly, "Error"
Set nms = Nothing
Set mainFld = Nothing
Exit Sub
ElseIf mainFld.DefaultItemType <> olMailItem Then
MsgBox "Please select the correct folder.", vbOKOnly, "Error"
Set nms = Nothing
Set mainFld = Nothing
Exit Sub
ElseIf mainFld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Set nms = Nothing
Set mainFld = Nothing
Exit Sub
End If
mainForm.Show
'If user clicks cancel, it will exit sub.
If yearValue = "" Then
Set nms = Nothing
Set mainFld = Nothing
Exit Sub
End If
'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True 'Show my workbook.
'Check if there are any subfolders.
If mainFld.Folders.Count = 0 Then '1
'No subfolder.
For Each itm In mainFld.Items
If itm.Class <> olMail Then '2
'do nothing
Else
Set msg = itm
'Validate the month and year for the email.
If Month(msg.ReceivedTime) = monthValue And Year(msg.ReceivedTime) = yearValue Then '3
With wks
offsetRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
intRowCounter = 1 + offsetRow
Set rng = wks.Cells(intRowCounter, 1)
rng.Value = msg.ReceivedTime
Set rng = wks.Cells(intRowCounter, 2)
rng.Value = msg.SentOn
Set rng = wks.Cells(intRowCounter, 3)
rng.Value = msg.Subject
emailCount = 1 + emailCount 'Track the number of email.
Else
'Do nothing
End If '3
End If '2
Next itm
Else
'With subfolder
For Each itm In mainFld.Items
If itm.Class <> olMail Then '4
'do nothing
Else
Set msg = itm
If Month(msg.ReceivedTime) = monthValue And Year(msg.ReceivedTime) = yearValue Then '5
With wks
offsetRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
intRowCounter = 1 + offsetRow
Set rng = wks.Cells(intRowCounter, 1)
rng.Value = msg.ReceivedTime
Set rng = wks.Cells(intRowCounter, 2)
rng.Value = msg.SentOn
Set rng = wks.Cells(intRowCounter, 3)
rng.Value = msg.Subject
emailCount = 1 + emailCount
Else
'Do nothing
End If '5
End If '4
Next itm
For Each subFld In mainFld.Folders
For Each itm In subFld.Items
If itm.Class <> olMail Then '6
'do nothing
Else
Set msg = itm
If Month(msg.ReceivedTime) = monthValue And Year(msg.ReceivedTime) = yearValue Then '7
With wks
offsetRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
intRowCounter = 1 + offsetRow
Set rng = wks.Cells(intRowCounter, 1)
rng.Value = msg.ReceivedTime
Set rng = wks.Cells(intRowCounter, 2)
rng.Value = msg.SentOn
Set rng = wks.Cells(intRowCounter, 3)
rng.Value = msg.Subject
emailCount = 1 + emailCount
Else
'Do nothing
End If '7
End If '6
Next itm
Next subFld
End If '1
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set mainFld = Nothing
Set subFld = Nothing
Set itm = Nothing
'Inform the user that there are no email.
If emailCount = 0 Then
MsgBox "No emails associated with this date: " & MonthName(monthValue, True) & " " & yearValue, vbOKOnly, "No Emails"
End If
Exit Sub
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set mainFld = Nothing
Set subFld = Nothing
Set itm = Nothing
End Sub
Do you get that error immediately or only after processing a large number of items? Most likely you are opening too many items and run out of RPC channels. Is this a cached or an online Exchange profile?
Instead of looping through all items, use the Table object (MAPITable.GetTable) - if nothing else, it will be a lot faster.
EDIT: If you are using Exchange, every store object (message, folder, store) opens an RPC channel. Exchange Server limits the number of RPC channels to 255 per client (can be changed on the server). Do not use "for each" loop (it keeps all items referenced until the loop ends) and avoid multiple dot notation (because you will have implicit variables that you cannot explicitly dereference). You will also need to release all Outlook objects as soon as you are done with them.
set fldItems = mainFld.Items
For i = 1 to fldItems.Count do
set itm = fldItems.Item(i)
'do stuff
set itm = Nothing
next
As for the Table object (introduced in Outlook 2007), see http://msdn.microsoft.com/en-us/library/office/ff860769.aspx. If you need to use this in an earlier version of Outlook, you can use the MAPITable object in Redemption (I am its author); it also has a MAPITable.ExecSQL method that takes a standard SQL query and returns the ADODB.Recordset object.