Want to work with us? We're on the lookout for a UX/UI Designer and Digital Project Manager.

We're hiring

Extract all emails Inbox and Sent Mail Folder Outlook Script VBA

Web Bureau

17 September 2013 by Web Bureau

 Please ensure "Microsoft Scripting Runtime" is enabled as a reference and you have write permissions on the folder for the .txt file. Tested in outlook 2007.

Sub GetALLEmailAddresses()

Dim objFolder As MAPIFolder
Dim strEmail As String
Dim strEmails As String
Dim objDic As Object
Dim objItem As Object
Dim objFSO As Object
Dim objTF As Object

Set objDic = CreateObject("scripting.dictionary")
Set objFSO = CreateObject("scripting.filesystemobject")
Set objTF = objFSO.CreateTextFile("C:\emailsInbox.csv", 2)
Set objFolder = Application.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox)
For Each objItem In objFolder.Items
If objItem.Class = olMail Then
strEmail = objItem.SenderEmailAddress
If Not objDic.Exists(strEmail) Then
objTF.WriteLine strEmail
objDic.Add strEmail, ""
End If
End If

Dim objItem2 As Object
Dim objFSO2 As Object
Dim objTF2 As Object
Dim objFolder2 As MAPIFolder
Dim objDic2 As Object

Set objFSO2 = CreateObject("scripting.filesystemobject")
Set objTF2 = objFSO2.CreateTextFile("C:\emailsSent.csv", 2)

Dim email_addresses As String
Dim i As Integer, j As Integer
Set myOlApp = CreateObject("Outlook.Application")
Set SentItems = myOlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderSentMail)
For i = 1 To SentItems.Items.Count
If TypeName(SentItems.Items(i)) = "MailItem" Then
For j = 1 To SentItems.Items.Item(i).Recipients.Count
email_addresses = SentItems.Items.Item(i).Recipients(j).Address
objTF2.WriteLine email_addresses
End If
Set SentItems = Nothing
Set myOlApp = Nothing

End Sub

End Sub

Grow your businessStart a project with us today.