Here is my existing code- I need some help counting ONLY items in the inbox that have been marked as "completed"
Sub HowManyEmails()
Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
Dim EmailCount As Integer
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
On Error Resume Next
Set objFolder = objnSpace.Folders("Investment Central").Folders("Inbox")
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder."
Exit Sub
End If
EmailCount = objFolder.Items.Count
MsgBox "Number of emails in the folder: " & EmailCount, , "email count"
Dim dateStr As String
Dim myItems As Outlook.Items
Dim dict As Object
Dim msg As String
Set dict = CreateObject("Scripting.Dictionary")
Set myItems = objFolder.Items
myItems.SetColumns ("SentOn")
' Determine date of each message:
For Each myItem In myItems
dateStr = GetDate(myItem.SentOn)
If Not dict.Exists(dateStr) Then
dict(dateStr) = 0
End If
dict(dateStr) = CLng(dict(dateStr)) + 1
Next myItem
' Output counts per day:
msg = ""
For Each o In dict.Keys
msg = msg & o & ": " & dict(o) & " items" & vbCrLf
Next
MsgBox msg
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
End Sub
Function GetDate(dt As Date) As String
GetDate = Year(dt) & "-" & Month(dt)
End Function
Use Items.Restrict on FlagStatus = 1 (olFlagComplete).
Set myItems = objFolder.Items.Restrict("[FlagStatus] = 1")
Related
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 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
The code below does not count categories from specific day properly:
Sub HowManyEmails()
Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
Dim EmailCount As Integer
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
On Error Resume Next
Set objFolder = Session.GetFolderFromID(Application.ActiveExplorer.CurrentFolder.EntryID)
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder."
Exit Sub
End If
EmailCount = objFolder.Items.Count
MsgBox "Number of emails in the folder: " & EmailCount, , "email count"
Dim dateStr As String
Dim myItems As Outlook.Items
Dim dict As Object
Dim msg As String
Dim oDate As String
Set dict = CreateObject("Scripting.Dictionary")
oDate = InputBox("Date for count (Format D-M-YYYY")
Set myItems = objFolder.Items.Restrict("[Received] >= '" & oDate & "'")
myItems.SetColumns ("Categories")
For Each myItem In myItems
dateStr = myItem.Categories
If Not dict.Exists(dateStr) Then
dict(dateStr) = 0
End If
dict(dateStr) = CLng(dict(dateStr)) + 1
Next myItem
msg = ""
For Each o In dict.Keys
msg = msg & o & ": " & dict(o) & vbCrLf
Next
MsgBox msg
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
End Sub
When you write a date, the output is just categories and emails count which doesn't match the chosen date.
The date format, valid for someone else, is likely not valid for you.
Option Explicit
Private Sub HowManyEmails()
Dim objFolder As Folder
Dim EmailCount As Integer
Dim myItem As Object
Dim o As Variant
Dim dateStr As String
Dim myItems As items
Dim dict As Object
Dim msg As String
Dim oDate As String
On Error Resume Next
Set objFolder = ActiveExplorer.CurrentFolder
If err.number <> 0 Then
err.Clear
MsgBox "No such folder."
Exit Sub
End If
' Must closely follow an On Error Resume Next
On Error GoTo 0
EmailCount = objFolder.items.count
MsgBox "Number of emails in the folder: " & EmailCount, , "email count"
Set dict = CreateObject("Scripting.Dictionary")
' oDate = InputBox("Date for count (Format D-M-YYYY")
oDate = InputBox("Date for count (Format YYYY-m-d")
Set myItems = objFolder.items.Restrict("[Received] >= '" & oDate & "'")
' myItems.SetColumns ("Categories") ' You will find this error due to On Error GoTo 0
For Each myItem In myItems
dateStr = myItem.Categories
If Not dict.exists(dateStr) Then
dict(dateStr) = 0
End If
dict(dateStr) = CLng(dict(dateStr)) + 1
Next myItem
msg = ""
For Each o In dict.Keys
If o = "" Then
msg = msg & dict(o) & ": " & "Not categorized" & vbCrLf
Else
msg = msg & dict(o) & ": " & o & vbCrLf
End If
Next
MsgBox msg
ExitRoutine:
Set objFolder = Nothing
Set dict = Nothing
End Sub
I'm working in Outlook VBA and have constructed a For Next loop to read in the body of MailItems which are formatted like Key=Value pairs. To a point it seems to be working, but on the end of the second iteration when it reaches the "Next oitem" I get the error thrown "type mismatch". Well,there is still a third MailItem to be read in, so I don't know why I am getting this error. Any guidance would be appreciated.
Sub ReadMailItems()
Dim olapp As Outlook.Application
Dim olappns As Outlook.NameSpace
Dim oitem As Outlook.MailItem
Dim ItemsToProcess As Outlook.Items
Dim myFolder As MAPIFolder
Dim sFilter As String
Dim dailyStats As CRBHA_Stats
Dim kvPairs As Collection
Dim Item As KeyValuePair
Dim today As Date
today = Date
On Error GoTo LocalErr
'set outlook objects
Set olapp = New Outlook.Application
Set olappns = olapp.GetNamespace("MAPI")
Set myFolder = olappns.GetDefaultFolder(olFolderInbox)
'Filter or only MailItems received today
sFilter = "[ReceivedTime] >= " & AddQuotes(Format(Date, "ddddd"))
Set ItemsToProcess = Session.GetDefaultFolder(olFolderInbox).Items.Restrict(sFilter)
Set StatsCollection = New Collection
For Each oitem In ItemsToProcess
If CheckSubject(oitem.Subject) Then
Set kvPairs = GetKeyValuePairs(oitem.body)
'Iterate over the Collection and load up
'an instance of CRBHA_Stats object
Set dailyStats = New CRBHA_Stats
dailyStats.SubmissionDate = today
For Each Item In kvPairs
If LCase(Item.Key) = LCase("EmployeeID") Then
dailyStats.EmployeeID = Item.Value
ElseIf LCase(Item.Key) = LCase("Approved") Then
dailyStats.Approved = Item.Value
ElseIf LCase(Item.Key) = LCase("Declined") Then
dailyStats.Declined = Item.Value
ElseIf LCase(Item.Key) = LCase("PFA") Then
dailyStats.PFAs = Item.Value
ElseIf LCase(Item.Key) = LCase("Followups") Then
dailyStats.FollowUps = Item.Value
ElseIf LCase(Item.Key) = LCase("CRA") Then
dailyStats.CRAs = Item.Value
End If
Next Item
'Add each CRBHA_Stats object to the StatsCollection
StatsCollection.Add dailyStats
Debug.Print dailyStats.ToString
Debug.Print "_____________" & vbCrLf
End If
Next oitem '<<<<This is where it cuts out
ExitProc:
Set olapp = Nothing
Set olappns = Nothing
Set myFolder = Nothing
Set ItemsToProcess = Nothing
Set dailyStats = Nothing
Exit Sub
LocalErr:
If Err.Number <> 0 Then
Msg = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & Err.Description
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
End If
'Resume Next
End Sub
Dim oitem As Object 'not Outlook.MailItem
'....
For Each oitem In ItemsToProcess
if typename(oitem)="MailItem" then
'process the mail
'....
end if
Next oitem
'........
I Have the following code to count the number of emails in a outlook folder.
Sub HowManyEmails()
Dim objOutlook As Object,
objnSpace As Object,
objFolder As Object
Dim EmailCount As Integer
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
On Error Resume Next
Set objFolder = objnSpace.Folders("Personal Folders").Folders("Inbox").Folders("report's").Folders("Customer")
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder."
Exit Sub
End If
EmailCount = objFolder.Items.Count
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
MsgBox "Number of emails in the folder: " & EmailCount, , "email count" End Sub
I am trying to count the emails in this folder by date so i end up with a count for each day.
You might try it with this code:
Sub HowManyEmails()
Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
Dim EmailCount As Integer
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
On Error Resume Next
Set objFolder = objnSpace.Folders("Personal Folders").Folders("Inbox").Folders("report's").Folders("Customer")
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder."
Exit Sub
End If
EmailCount = objFolder.Items.Count
MsgBox "Number of emails in the folder: " & EmailCount, , "email count"
Dim dateStr As String
Dim myItems As Outlook.Items
Dim dict As Object
Dim msg As String
Set dict = CreateObject("Scripting.Dictionary")
Set myItems = objFolder.Items
myItems.SetColumns ("SentOn")
' Determine date of each message:
For Each myItem In myItems
dateStr = GetDate(myItem.SentOn)
If Not dict.Exists(dateStr) Then
dict(dateStr) = 0
End If
dict(dateStr) = CLng(dict(dateStr)) + 1
Next myItem
' Output counts per day:
msg = ""
For Each o In dict.Keys
msg = msg & o & ": " & dict(o) & " items" & vbCrLf
Next
MsgBox msg
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
End Sub
Function GetDate(dt As Date) As String
GetDate = Year(dt) & "-" & Month(dt) & "-" & Day(dt)
End Function