• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

VBA MAcro Outlook export email + Sender name

GDGDGD

New Member
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!

>>> use code - tags <<<
Code:
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
 
Back
Top