Skip to content

Instantly share code, notes, and snippets.

@hervenivon
Last active October 13, 2015 08:37
Show Gist options
  • Save hervenivon/44a22750817a00d1801d to your computer and use it in GitHub Desktop.
Save hervenivon/44a22750817a00d1801d to your computer and use it in GitHub Desktop.
Outlook VBA for email addresses extraction. To place in 'ThisOutlookSession'
'this procedure is largely inspired by a comment from Bujez on Novembre 2010 on this thread:
'http://omaralzabir.com/get_email_address_of_all_users_from_all_mails_in_outlook_folder/
'Rewright needs to be done to make it recursive but it works as is with Outlook 2013
Sub EmailExport()
'Requires reference to Microsoft Scripting Runtime
'Tools –> References –> check “Microsoft Scripting Runtime”
Dim outApp As New Outlook.Application
Dim mpf As Outlook.MAPIFolder
Dim mpfSubFolder As Outlook.MAPIFolder
Dim flds As Outlook.Folders
Dim mpfSubFolder1 As Outlook.MAPIFolder
Dim flds1 As Outlook.Folders
Dim mpfSubFolder2 As Outlook.MAPIFolder
Dim flds2 As Outlook.Folders
Dim mpfSubFolder3 As Outlook.MAPIFolder
Dim flds3 As Outlook.Folders
Dim strTmp As String
Dim strTmpType As String
Dim strExtract As String
Dim strSeparator As String
Dim i As Long
Dim BufferSize As Long
Dim FileFullPath As String
BufferSize = 5000
i = 0
FileFullPath = "C:export.txt"
strSeparator = "|"
strExtract = "Sender" + strSeparator _
+ "SentOn" + strSeparator _
+ "Subject" + strSeparator _
+ "Recipient type" + strSeparator _
+ "Recipient" _
+ vbCrLf
bool = WriteTextToFileWithBuffer(FileFullPath, strExtract, BufferSize, i, True, True)
'https://msdn.microsoft.com/FR-FR/library/office/ff869030.aspx
Set mpf = Application.GetNamespace("Mapi").PickFolder
Set flds = mpf.Folders
Set mpfSubFolder = flds.GetFirst
Do While Not mpfSubFolder Is Nothing
For Each objItem In mpfSubFolder.Items
If objItem.Class = olMail Then
For Each Recipient In objItem.Recipients
strTmpType = GetRecipientTypeAsString(Recipient.Type)
strTmp = objItem.SenderEmailAddress + strSeparator _
+ CStr(objItem.SentOn) + strSeparator _
+ objItem.Subject + strSeparator _
+ strTmpType + strSeparator _
+ Recipient.Address
strExtract = strExtract + strTmp + vbCrLf
i = i + 1
bool = WriteTextToFileWithBuffer(FileFullPath, strExtract, BufferSize, i, False, False)
Next Recipient
End If
Next
Set flds1 = mpfSubFolder.Folders
Set mpfSubFolder1 = flds1.GetFirst
Do While Not mpfSubFolder1 Is Nothing
For Each objItem1 In mpfSubFolder1.Items
If objItem1.Class = olMail Then
For Each Recipient1 In objItem1.Recipients
strTmpType = GetRecipientTypeAsString(Recipient1.Type)
strTmp = objItem1.SenderEmailAddress + strSeparator _
+ CStr(objItem1.SentOn) + strSeparator _
+ objItem1.Subject + strSeparator _
+ strTmpType + strSeparator _
+ Recipient1.Address
strExtract = strExtract + strTmp + vbCrLf
i = i + 1
bool = WriteTextToFileWithBuffer(FileFullPath, strExtract, BufferSize, i, False, False)
Next Recipient1
End If
Next
Set flds2 = mpfSubFolder1.Folders
Set mpfSubFolder2 = flds2.GetFirst
Do While Not mpfSubFolder2 Is Nothing
For Each objItem2 In mpfSubFolder2.Items
If objItem2.Class = olMail Then
For Each Recipient2 In objItem2.Recipients
strTmpType = GetRecipientTypeAsString(Recipient2.Type)
strTmp = objItem2.SenderEmailAddress + strSeparator _
+ CStr(objItem2.SentOn) + strSeparator _
+ objItem2.Subject + strSeparator _
+ strTmpType + strSeparator _
+ Recipient2.Address
strExtract = strExtract + strTmp + vbCrLf
i = i + 1
bool = WriteTextToFileWithBuffer(FileFullPath, strExtract, BufferSize, i, False, False)
Next Recipient2
End If
Next
Set flds3 = mpfSubFolder2.Folders
Set mpfSubFolder3 = flds3.GetFirst
Do While Not mpfSubFolder3 Is Nothing
For Each objItem3 In mpfSubFolder3.Items
If objItem3.Class = olMail Then
For Each Recipient3 In objItem3.Recipients
strTmpType = GetRecipientTypeAsString(Recipient3.Type)
strTmp = objItem3.SenderEmailAddress + strSeparator _
+ CStr(objItem3.SentOn) + strSeparator _
+ objItem3.Subject + strSeparator _
+ strTmpType + strSeparator _
+ Recipient3.Address
strExtract = strExtract + strTmp + vbCrLf
i = i + 1
bool = WriteTextToFileWithBuffer(FileFullPath, strExtract, BufferSize, i, False, False)
Next Recipient3
End If
Next
Set mpfSubFolder3 = flds3.GetNext
Loop
Set mpfSubFolder2 = flds2.GetNext
Loop
Set mpfSubFolder1 = flds1.GetNext
Loop
Set mpfSubFolder = flds.GetNext
Loop
bool = WriteTextToFileWithBuffer(FileFullPath, strExtract, BufferSize, i, True, False)
End Sub
Private Function WriteTextToFileWithBuffer(FileFullPath As String, _
ByRef sText As String, _
BufferSize As Long, _
ByRef BufferPosition As Long, _
Optional Flush As Boolean = False, _
Optional Overwrite As Boolean = False) As Boolean
If Flush Or BufferPosition >= BufferSize Then
WriteTextToFileWithBuffer = SaveTextToFile(FileFullPath, sText, Overwrite)
sText = ""
BufferPosition = 0
End If
End Function
Public Function GetRecipientTypeAsString(RecipientType As Long) As String
Select Case RecipientType
Case olBCC
GetRecipientTypeAsString = "BCC"
Case olCC
GetRecipientTypeAsString = "CC"
Case olOriginator
GetRecipientTypeAsString = "FROM"
Case olTo
GetRecipientTypeAsString = "TO"
Case Else
GetRecipientTypeAsString = "unknown"
End Select
End Function
'this is a function from http://www.freevbcode.com/ShowCode.Asp, it saves the files to a text file
Public Function SaveTextToFile(FileFullPath As String, sText As String, Optional Overwrite As Boolean = False) As Boolean
'Purpose: Save Text to a file
'Parameters:
'– FileFullPath – Directory/FileName to save file to
'– sText – Text to write to file
'– Overwrite (optional): If true, if the file exists, it
'is overwritten. If false,
'contents are appended to file
'if the file exists
'Returns: True if successful, false otherwise
'Example:
'SaveTextToFile “C:My DocumentsMyFile.txt”, “Hello There”
On Error GoTo ErrorHandler
Dim iFileNumber As Integer
iFileNumber = FreeFile
If Overwrite Then
Open FileFullPath For Output As #iFileNumber
Else
Open FileFullPath For Append As #iFileNumber
End If
Print #iFileNumber, sText
SaveTextToFile = True
ErrorHandler:
Close #iFileNumber
End Function
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment