VBA Code in Outlook to get unread emails

J

Jacki

New Member
Joined
Jul 27, 2014
Messages
17
I am working on some VBA code in MS Outlook that sends emails to an excel spreadsheet and am stuck trying to workout how to send only the unread emails. I hope someone can help! Many thanks in advance!

Here is the code I have so far:

Const MACRO_NAME = "Export Outlook Email to Excel"

Sub ExportMain()
ExportToExcel "filepathofexcelspreadsheet", "filepathofemailsubfolder"
MsgBox "Process complete.", vbInformation + vbOKOnly, MACRO_NAME
End Sub
Sub ExportToExcel(strFilename As String, strFolderPath As String)
Dim olkMsg As Object
Dim olkFld As Object
Dim excApp As Object
Dim excWkb As Object
Dim excWks As Object
Dim intRow As Integer
Dim intVersion As Integer

If strFilename <> "" Then
If strFolderPath <> "" Then
Set olkFld = OpenOutlookFolder(strFolderPath)
If TypeName(olkFld) <> "Nothing" Then
intVersion = GetOutlookVersion()
Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Add()
Set excWks = excWkb.ActiveSheet

'Write Excel Column Headers
With excWks
.Cells(1, 1) = "Subject"
.Cells(1, 2) = "Message"
.Cells(1, 3) = "Received"
.Cells(1, 4) = "Sender"

End With
intRow = 2
For Each olkMsg In olkFld.Items
'Only export messages, not receipts or appointment requests, etc.
If olkMsg.Class = olMail Then
'Add a row for each field in the message you want to export
excWks.Cells(intRow, 1) = olkMsg.Subject
excWks.Cells(intRow, 2) = olkMsg.Body
excWks.Cells(intRow, 3) = olkMsg.ReceivedTime
excWks.Cells(intRow, 4) = GetSMTPAddress(olkMsg, intVersion)
intRow = intRow + 1
Range("A1:D1000").WrapText = False
End If
Next
Set olkMsg = Nothing
excWkb.SaveAs strFilename
excWkb.Close
Else
MsgBox "The folder '" & strFolderPath & "' does not exist in Outlook.", vbCritical + vbOKOnly, MACRO_NAME
End If
Else
MsgBox "The folder path was empty.", vbCritical + vbOKOnly, MACRO_NAME
End If
Else
MsgBox "The filename was empty.", vbCritical + vbOKOnly, MACRO_NAME
End If

Set olkMsg = Nothing
Set olkFld = Nothing
Set excWks = Nothing
Set excWkb = Nothing
Set excApp = Nothing
End Sub

Public Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
Dim arrFolders As Variant
Dim varFolder As Variant
Dim 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

Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
Dim olkSnd As Outlook.AddressEntry
Dim olkEnt As Object

On Error Resume Next
Select Case intOutlookVersion
Case Is < 14
If Item.SenderEmailType = "EX" Then
GetSMTPAddress = SMTPEX(Item)
Else
GetSMTPAddress = Item.SenderEmailAddress
End If
Case Else
Set olkSnd = Item.Sender
If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
Set olkEnt = olkSnd.GetExchangeUser
GetSMTPAddress = olkEnt.PrimarySmtpAddress
Else
GetSMTPAddress = Item.SenderEmailAddress
End If
End Select
On Error GoTo 0
Set olkPrp = Nothing
Set olkSnd = Nothing
Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
Dim arrVer As Variant
arrVer = Split(Outlook.Version, ".")
GetOutlookVersion = arrVer(0)
End Function

Function SMTPEX(olkMsg As Outlook.MailItem) As String
Dim olkPA As Outlook.PropertyAccessor
On Error Resume Next
Set olkPA = olkMsg.PropertyAccessor
SMTPEX = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
On Error GoTo 0
Set olkPA = Nothing
End Function
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
Sort by date Sort by votes
Untested

Code: 
Const MACRO_NAME = "Export Outlook Email to Excel"


Sub ExportMain()
ExportToExcel "filepathofexcelspreadsheet", "filepathofemailsubfolder"
MsgBox "Process complete.", vbInformation + vbOKOnly, MACRO_NAME
End Sub
Sub ExportToExcel(strFilename As String, strFolderPath As String)
Dim olkMsg As Object
Dim olkFld As Object
Dim excApp As Object
Dim excWkb As Object
Dim excWks As Object
Dim intRow As Integer
Dim intVersion As Integer


If strFilename <> "" Then
If strFolderPath <> "" Then
Set olkFld = OpenOutlookFolder(strFolderPath)
If TypeName(olkFld) <> "Nothing" Then
intVersion = GetOutlookVersion()
Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Add()
Set excWks = excWkb.ActiveSheet


'Write Excel Column Headers
With excWks
.Cells(1, 1) = "Subject"
.Cells(1, 2) = "Message"
.Cells(1, 3) = "Received"
.Cells(1, 4) = "Sender"


End With
intRow = 2
For Each olkMsg In olkFld.Items
[B][COLOR=#ff0000]If olkMsg.UnRead = True Then[/COLOR][/B]
'Only export messages, not receipts or appointment requests, etc.
If olkMsg.Class = olMail Then
'Add a row for each field in the message you want to export
excWks.Cells(intRow, 1) = olkMsg.Subject
excWks.Cells(intRow, 2) = olkMsg.Body
excWks.Cells(intRow, 3) = olkMsg.ReceivedTime
excWks.Cells(intRow, 4) = GetSMTPAddress(olkMsg, intVersion)
intRow = intRow + 1
Range("A1:D1000").WrapText = False
End If
[COLOR=#ff0000][B]End If[/B][/COLOR]
Next




Set olkMsg = Nothing
excWkb.SaveAs strFilename
excWkb.Close
Else
MsgBox "The folder '" & strFolderPath & "' does not exist in Outlook.", vbCritical + vbOKOnly, MACRO_NAME
End If
Else
MsgBox "The folder path was empty.", vbCritical + vbOKOnly, MACRO_NAME
End If
Else
MsgBox "The filename was empty.", vbCritical + vbOKOnly, MACRO_NAME
End If


Set olkMsg = Nothing
Set olkFld = Nothing
Set excWks = Nothing
Set excWkb = Nothing
Set excApp = Nothing
End Sub


Public Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
Dim arrFolders As Variant
Dim varFolder As Variant
Dim 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


Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
Dim olkSnd As Outlook.AddressEntry
Dim olkEnt As Object


On Error Resume Next
Select Case intOutlookVersion
Case Is < 14
If Item.SenderEmailType = "EX" Then
GetSMTPAddress = SMTPEX(Item)
Else
GetSMTPAddress = Item.SenderEmailAddress
End If
Case Else
Set olkSnd = Item.Sender
If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
Set olkEnt = olkSnd.GetExchangeUser
GetSMTPAddress = olkEnt.PrimarySmtpAddress
Else
GetSMTPAddress = Item.SenderEmailAddress
End If
End Select
On Error GoTo 0
Set olkPrp = Nothing
Set olkSnd = Nothing
Set olkEnt = Nothing
End Function


Function GetOutlookVersion() As Integer
Dim arrVer As Variant
arrVer = Split(Outlook.Version, ".")
GetOutlookVersion = arrVer(0)
End Function


Function SMTPEX(olkMsg As Outlook.MailItem) As String
Dim olkPA As Outlook.PropertyAccessor
On Error Resume Next
Set olkPA = olkMsg.PropertyAccessor
SMTPEX = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
On Error GoTo 0
Set olkPA = Nothing
End Function
 
Last edited:
Upvote 0
The above said code is not working "filepathofemailsubfolder" . Folder does not exist in Outlook
 
Upvote 0
What is the path your using?

The OP looks like they maybe replaced part of the code with placeholder text, I did not create the code but it looks like you need to pass in the folder path.

VBA Code: 
Sub ExportMain()
ExportToExcel "filepathofexcelspreadsheet", "filepathofemailsubfolder"
MsgBox "Process complete.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

filepathofemailsubfolder should be replaced with the actual path to the folder your looking to get data from.....i believe
 
Upvote 0
Coding4Fun said:
What is the path your using?

The OP looks like they maybe replaced part of the code with placeholder text, I did not create the code but it looks like you need to pass in the folder path.

VBA Code: 
Sub ExportMain()
ExportToExcel "filepathofexcelspreadsheet", "filepathofemailsubfolder"
MsgBox "Process complete.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

filepathofemailsubfolder should be replaced with the actual path to the folder your looking to get data from.....i believe
Click to expand...
Hello,
Okay... so I am feeling really dumb, but what is the syntax of the mail subfolder?
If I pick a simple subfolder (called DCA), I have tried:
DCA
\DCA
DCA\
\DCA\
Inbox\DCA
\Inbox\DCA
Inbox\DCA\

No joy... totally a nuub question I fear.... but I am stuck.
Thanks in advance
 
Upvote 0
Post the code your trying to use. The below will loop through your mailbox and spit out the "FolderPath's"

docs.microsoft.com

Folders object (Outlook)

Office VBA reference topic
docs.microsoft.com
docs.microsoft.com

MAPIFolder Object

docs.microsoft.com
docs.microsoft.com

NameSpace Object

docs.microsoft.com

VBA Code: 
Sub GetEmail()

Dim OutApp As Outlook.Application
Dim Namespace As Outlook.Namespace
Dim Mfolder As Outlook.MAPIFolder
Dim myMail As Outlook.Items

Dim Folder As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim UserFolder As Outlook.MAPIFolder

Set OutApp = New Outlook.Application
Set Namespace = OutApp.GetNamespace("MAPI")

On Error Resume Next
For Each Folder In Namespace.Folders
MsgBox Folder.FolderPath
    For Each SubFolder In Folder.Folders
    MsgBox SubFolder.FolderPath
        For Each UserFolder In SubFolder.Folders
        MsgBox UserFolder.FolderPath
            
        Next UserFolder
    Next SubFolder
Next Folder
On Error GoTo 0

End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Question Question
Reverse Engineer Outlook Macro since New Outlook does not allow Macros
Replies
1
Views
380
John_w
J
C
  • Solved
With 'Set StrVal=ActiveCell.Address' and ‘Dim StrVal As String’ I get 'Object required' error With ‘Dim StrVal As Range’, a ‘Type Mismatch’ error
Replies
7
Views
487
MARK858
MARK858
J
  • Question Question
VBA code not running the 2nd time
Replies
1
Views
896
Jacki
J
J
  • Locked
  • Question Question
VBA Macro not running the 2nd time
Replies
1
Views
638
Fluff
Fluff
B
  • Question Question
Code Not sending email when worksheet range is changed
Replies
2
Views
771
MARK858
MARK858

Forum statistics

Threads
1,224,822
Messages
6,181,164
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top