none
VBA Macro Outlook export email + Sender name RRS feed

  • Question

  • Hi, i have a working macro which exports all emails from an inbox and all sub folders. I want to also add the Sender Name.

    Here is the piece of the code
    Would be thankful forever if someone tells me where to add the info so it exports emails with sender name.
    Thank you!


    Dim oitem As Outlook.MailItem
    Dim justitem As Object

    Sub EmailAddress_subfolder()

    msgred = MsgBox("Please note: depending on how many Emails are in your folders, this might take some time to run. " + vbCrLf + "Are you sure you want to continue ?", vbQuestion + vbYesNo, "TheTechieGuy.com - Export Address:")
    If msgred = 7 Then
    Exit Sub
    End If

    'create the folder if it doesnt exists:
    Dim fso, ttxtfile, txtfile, WheretosaveFolder
    Dim objFolders As Object
    Set objFolders = CreateObject("WScript.Shell").SpecialFolders
    Set fso = CreateObject("Scripting.FileSystemObject")
    'MsgBox objFolders("mydocuments")
    ttxtfile = objFolders("mydocuments")

    If fso.FolderExists(ttxtfile & "\EmailAddressExport") = False Then
    Set txtfile = fso.CreateFolder(ttxtfile & "\EmailAddressExport")
    End If
    Set txtfile = Nothing

    If fso.FileExists(ttxtfile & "\EmailAddressExport\Outputfile.txt") = False Then
    Set txtfile = fso.CreateTextFile(ttxtfile & "\EmailAddressExport\Outputfile.txt")
    Else
    fso.DeleteFile (ttxtfile & "\EmailAddressExport\Outputfile.txt")
    Set txtfile = fso.CreateTextFile(ttxtfile & "\EmailAddressExport\Outputfile.txt")
    End If
    Set txtfile = Nothing
    Set fso = Nothing


    Dim mycounter As Integer
    Dim olapp As Outlook.Application
    Dim olappns As Outlook.NameSpace
    Dim oinbox As Outlook.Folder
    Dim oFolder As Outlook.MAPIFolder
    Set olapp = New Outlook.Application
    Set olappns = olapp.GetNamespace("MAPI")
    Set oinbox = olappns.GetDefaultFolder(olFolderInbox)
    Set oinbox = olappns.PickFolder
    If TypeName(oinbox) = "Nothing" Then
    MsgBox "Please select the Folder you would like to export", vbInformation, "TheTechieguy.com - Export Address:"
    Exit Sub
    End If
    If oinbox = "Calendar" Then
    MsgBox "Note: do not select Calendar folders", vbCritical, "TheTechieguy.com - Export Address:"
    Exit Sub
    End If
    If oinbox = "Contacts" Then
    MsgBox "Note: do not select Contact folder", vbCritical, "TheTechieguy.com - Export Address:"
    Exit Sub
    End If

    Dim myccounter As Integer
    Dim InboxMsg As Object
    Dim Inbox As Outlook.Folder

    'For Each oitem In oinbox.Items
    For Each InboxMsg In oinbox.Items

    If InboxMsg.Class = olMail Then 'if it is a mail item

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set txtfile = fso_OpenTextFile(ttxtfile & "\EmailAddressExport\Outputfile.txt", 8)
    txtfile.Write (InboxMsg.SenderEmailAddress) & vbCrLf
    txtfile.Close
    Set fso = Nothing
    'MsgBox "Mail Subject -> " & oitem.Subject
    'MsgBox "Sender Email Address -> " & oitem.SenderEmailAddress
    'MsgBox "Sender Name -> " & oitem.SenderName
    'MsgBox "Mail Body -> " & oitem.Body
    'MsgBox "Recived Date -> " & oitem.ReceivedTime
    'MsgBox oinbox.Name
    'MsgBox oinbox.FolderPath
    End If
    Next

    For Each oFolder In oinbox.Folders
    Call subfolders_go(oFolder)
    Next


    MsgBox "Exported Emails are all done !" + vbCrLf + "File is located in My Documents" + vbCrLf + "in a folder called: EmailAddressExport", vbInformation, "TheTechieguy.com - Export Address:"

    End Sub
    Private Sub subfolders_go(oParent As Outlook.Folder)
    Dim oFolder1 As Outlook.MAPIFolder
    'For Each oitem In oParent.Items
    'If oitem.Class = olMail Then
    Dim InboxMsg As Object
    Dim Inbox As Outlook.Folder

    'For Each oitem In oinbox.Items
    For Each InboxMsg In oParent.Items
    If InboxMsg.Class = olMail Then 'if it is a mail item
    Dim objFolders As Object
    Set objFolders = CreateObject("WScript.Shell").SpecialFolders
    Set fso = CreateObject("Scripting.FileSystemObject")
    ttxtfile = objFolders("mydocuments")

    Set txtfile = fso_OpenTextFile(ttxtfile & "\EmailAddressExport\Outputfile.txt", 8)
    txtfile.Write (InboxMsg.SenderEmailAddress) & vbCrLf
    txtfile.Close
    Set fso = Nothing
    'MsgBox "Mail Subject -> " & oitem.Subject
    'MsgBox "Sender Email Address -> " & oitem.SenderEmailAddress
    'MsgBox "Sender Name -> " & oitem.SenderName
    'MsgBox "Mail Body -> " & oitem.Body
    'MsgBox "Recived Date -> " & oitem.ReceivedTime
    'MsgBox oParent.Name
    'MsgBox oParent.FolderPath
    End If
    Next
    If (oParent.Folders.Count > 0) Then
    For Each oFolder1 In oParent.Folders
    Call subfolders_go(oFolder1)
    Next
    End If

    End Sub

    Friday, December 6, 2019 10:29 AM