Hi,
I am pretty new to VBA and I am working on a VBA script that will allow me to count the number of emails in my sent items folder with an external email address (so basically emails sent out that are not to people within my company).
I have googled and googled and cannot find anything, is there anyone that can help me.
Thanks in Advance
I am not sure where Excel comes into this but the following should point the way. Change your company domain as appropriate. If there are many items in the sent folder this could take a while to run
Code:Sub CountSent()
Dim olFolder As Folder
Dim olItem As Object
Dim lngCount As Long: lngCount = 0
Set olFolder = Session.GetDefaultFolder(olFolderSentMail)
For Each olItem In olFolder.items
If TypeName(olItem) = "MailItem" Then
If Not olItem.Recipients(1).Address Like "*@yourcompanydomain.com" Then
lngCount = lngCount + 1
End If
End If
DoEvents
Next olItem
MsgBox lngCount & " items sent"
lbl_Exit:
Set olFolder = Nothing
Set olItem = Nothing
Exit Sub
End Sub
Thank you, I was having trouble trying to read number of items from sent items, so this helps a lot. I really appreciate your help! So my aim is to run a macro that I can run daily that will send me an excel file with 2 columns, Date and Count of emails (from sent items). I actually want it to count emails that have been sent to external email address (so emails not sent to people within my organization). Is this doable?
The code is essentially the same. You will need a two column worksheet with a header row i.e. Sheet1 of C:\Path\Email Log.xlsx (change the path as required)
The Date will be column 1. The count will be column 2.
Change yourdomain.com to your company domain name in order to exclude internal messages.
Change the date switches "dd/mm/yyyy" to suit local requirements
The macro counts the messages sent on the current day, so in practice you would run the macro after the last mail of the day in order to correctly record the count.
The message box is optional.
Code:Sub CountSent()
' Graham Mayor - https://www.gmayor.com - Last updated - 24 Sep 2019
Const strWB As String = "C:\Path\Email Log.xlsx"
Const strSheet As String = "Sheet1"
Dim strDate As String
Dim strValues As String
Dim olFolder As Folder
Dim olItem As Object
Dim lngItem As Long
Dim lngCount As Long: lngCount = 0
Set olFolder = Session.GetDefaultFolder(olFolderSentMail)
For lngItem = olFolder.items.Count To 1 Step -1
Set olItem = olFolder.items(lngItem)
If TypeName(olItem) = "MailItem" Then 'count only e-mails
If CDate(Format(olItem.SentOn, "dd/mm/yyyy")) = CDate(Format(Date, "dd/mm/yyyy")) Then 'test for today's messages
If Not olItem.Recipients(1).Address Like "*@yourdomain.com" Then 'ignore internal messages
strDate = Format(olItem.SentOn, "dd/mm/yyyy")
lngCount = lngCount + 1
End If
Else
Exit For
End If
End If
DoEvents
Next lngItem
strValues = strDate & "', '" & CStr(lngCount)
WriteToWorksheet strWorkbook:=strWB, strRange:="Sheet1", strValues:=strValues
lbl_Exit:
MsgBox lngCount & " items sent"
Set olFolder = Nothing
Set olItem = Nothing
Exit Sub
End Sub
Private Function WriteToWorksheet(strWorkbook As String, strRange As String, strValues As String)
Dim ConnectionString As String
Dim strSQL As String
Dim CN As Object
ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & "Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
strSQL = "INSERT INTO [" & strRange & "$] VALUES('" & strValues & "')"
Set CN = CreateObject("ADODB.Connection")
Call CN.Open(ConnectionString)
Call CN.Execute(strSQL, , 1 Or 128)
CN.Close
lbl_Exit:
Set CN = Nothing
Exit Function
End Function
Graham, this is perfect thank you so much. This is exactly what I need, however I tested this and it was including an internal email I sent as part of the count. I am wondering if this is the issue...when i click on Outlook Properties of a user, there are more than 1 email addresses showing in the Email Addresses box? I sent myself an email with the other email addresses listed to see if i get those and i do, so i am wondering if that is the issue?
If that is the case, is there a way to list all the email addresses to exclude?
The add-in should ignore any e-mail address that looks like *@yourdomain.com" did the e-mail address you sent to have such a domain name?
Ok so I found out that my the internal email address is actually something else other than what is shown, so i added that in to exclude and it worked! yay!!
I am now working on trying to see if i can update this excel file which has been password protected. I know there is a way to unprotect and protect a file within the VBA code in excel, but I am trying to see if i can do it via Outlook. Graham, thanks for your help :-)
Avoid clumsy coding:
Don't bother with 'protection' in Excel.
To retrieve yesterday's outmails to external addresses:
Have a look also here: http://www.snb-vba.eu/VBA_Outlook_external_en.html#L_5Code:Sub M_uit()
For Each it In Createobject("Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(5).Items.Restrict("[Senton]>'" & Date - 1 & "' and [Senton]<'" & Date & "'")
If Right(it.Recipients(1).Address, 10) <> "@mycompany" Then y = y + 1
Next
sheet1.cells(Rows.Count, 1).End(xlup).offset(1).resize(, 2) = Array(Date - 1, y)
End Sub
Hi Graham, sorry for the delay, I was on vacation. So this is what I was needing, to capture the day before. Where in the coding that you previously provided should I place this? I am still playing around with it and am having trouble.
Graham, so i used your coding below to grab yesterdays date and i added a "-1" below but it didn't work?
Code:If CDate(Format(olItem.SentOn, "dd/mm/yyyy")) = CDate(Format(Date-1, "dd/mm/yyyy")) Then 'test for today's messages
You cannot use ADODB to write to a password protected workbook that isn't open in Excel, so one solution would be to open it e.g. as follows. As it is then open you could write directly to it, but you can still use ADODB as it is likely to be faster. If the workbook isn't already open, the process will open it with the indicated passwords. You will of course need to change those as appropriate.Quote:
Originally Posted by vhrame
Code:Private Function WriteToWorksheet(strWorkbook As String, _
strRange As String, strValues As String)
Dim ConnectionString As String
Dim strSQL As String
Dim CN As Object
Dim xlApp As Object
Dim xlWB As Object
Dim vWB As Variant
Dim bXLStarted As Boolean, bOpen As Boolean
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
bXLStarted = True
End If
vWB = Split(strWorkbook, "\")
For Each xlWB In xlApp.workbooks
If xlWB.Name = vWB(UBound(vWB)) Then
bOpen = True
Exit For
End If
Next xlWB
If Not bOpen Then
Set xlWB = xlApp.workbooks.Open(fileName:=strWorkbook, _
Password:="abc123", WriteResPassword:="abc123", IgnoreReadOnlyRecommended:=True)
End If
On Error GoTo 0
ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
strSQL = "INSERT INTO [" & strRange & "$] VALUES('" & strValues & "')"
Set CN = CreateObject("ADODB.Connection")
Call CN.Open(ConnectionString)
Call CN.Execute(strSQL, , 1 Or 128)
CN.Close
If bOpen = False Then
xlWB.Close 1
Else
xlWB.Save
End If
If bXLStarted = True Then xlApp.Quit
lbl_Exit:
Set CN = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Exit Function
End Function
Thank you Graham! That works!
Graham, in the below coding, how would I be able to get yesterdays dated emails?
Code:If CDate(Format(olItem.SentOn, "dd/mm/yyyy")) = CDate(Format(Date, "dd/mm/yyyy")) Then 'test for today's messages
Change
toCode:CDate(Format(Date, "dd/mm/yyyy"))
Code:CDate(Format(Date - 1, "dd/mm/yyyy"))
I tried this and it returned a 0 and I do have external emails i sent out yesterday. I was reading online and it mentioned that using FORMAT turns it into a string, so they suggest doing the subtraction first and then doing the format? is that correct?
Date is a date and Date - 1 is also a date. Format turns the result into a string then CDate turns it back into a date so that it can be compared with Item.SentOn.
As you live in the States it might be relevant to use a US format date switches in place of "dd/mm/yyyy" so that the regional values don't screw things up.
I also tried that and no luck...
Graham, I had a work colleague look into this and this is the coding that worked:
I truly appreciate your help and thank you for everything you have helped me with.Code:If CDate(Format(olItem.SentOn, "mm/dd/yyyy")) <= CDate(Format(Date - 1, "mm/dd/yyyy")) Then
If CDate(Format(olItem.SentOn, "mm/dd/yyyy")) = CDate(Format(Date - 1, "mm/dd/yyyy")) Then
strDate = Format(olItem.SentOn, "mm/dd/yyyy")
Ok I promise this is my last question....how can I run this outlook vba to run on a task scheduler mon-fri?
Hi, me again....
How can I insert the computers username into the excel file above?