Outlook VBA for email addresses extraction. To place in 'ThisOutlookSession'

ThisOutlookSession.vba

'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