Sub ExportToExcelV2()
Dim appExcel As Excel.Application
Dim appOutlook As Outlook.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.Namespace
Dim FolderSelected As Outlook.MAPIFolder
Dim varSender As String
Dim itm As Object
Dim lngColIndex As Long
On Error GoTo ErrHandler
Set appExcel = Application 'CreateObject("Excel.Application")
Set appOutlook = GetObject(, "Outlook.Application")
appExcel.Application.Visible = True
Set wkb = ThisWorkbook
Set wks = wkb.Sheets(1)
appExcel.GoTo wks.Cells(1)
Set nms = appOutlook.GetNamespace("MAPI")
Do
'Stop
Set FolderSelected = nms.PickFolder
'Handle potential errors with Select Folder dialog box.
If FolderSelected Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
GoTo JumpExit
ElseIf FolderSelected.DefaultItemType <> olMailItem Then
MsgBox "These are not Mail Items", vbOKOnly, "Error"
GoTo JumpExit
ElseIf FolderSelected.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
GoTo JumpExit
End If
'Copy field items in mail folder.
intRowCounter = 1
lngColIndex = 1
wks.Cells(intRowCounter, lngColIndex).Resize(, 5).Value = Array("To", "From", "Subject", "Body", "Received")
intRowCounter = wks.Cells(wks.Rows.Count, 1).End(xlUp).Row
For Each itm In FolderSelected.Items
intColumnCounter = 1
If TypeOf itm Is MailItem Then
Set msg = itm
intRowCounter = intRowCounter + 1: Set rng = wks.Cells(intRowCounter, intColumnCounter): rng.Value = msg.To
'============================================================
varSender = ResolveDisplayNameToSMTP(msg.SenderEmailAddress, appOutlook)
If varSender = vbNullString Then varSender = msg.SenderEmailAddress
'============================================================
wks.Cells(intRowCounter, 2).Resize(, 4).Value = Array(varSender, RemoveREFW(msg.Subject), Left(msg.Body, 2000), msg.ReceivedTime)
varSender = vbNullString
End If 'TypeOf
Next itm
Loop
JumpExit:
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set FolderSelected = Nothing
Set itm = Nothing
Exit Sub
ErrHandler:
If Err.Number = 1004 Then
MsgBox strSheet & " doesn't exist", vbOKOnly, "Error"
Else
MsgBox Err.Number & "; Description: " & Err.Description & vbCrLf & msg.ReceivedTime & vbCrLf & msg.Subject, vbOKOnly, "Error"
End If
Err.Clear: On Error GoTo 0: On Error GoTo -1
GoTo JumpExit
End Sub
Function ResolveDisplayNameToSMTP(sFromName, objApp As Object)
Dim oRecip As Recipient
Dim oEU As ExchangeUser
Dim oEDL As ExchangeDistributionList
Set oRecip = objApp.Session.CreateRecipient(sFromName)
oRecip.Resolve
If oRecip.Resolved Then
Select Case oRecip.AddressEntry.AddressEntryUserType
Case OlAddressEntryUserType.olExchangeUserAddressEntry, OlAddressEntryUserType.olOutlookContactAddressEntry
Set oEU = oRecip.AddressEntry.GetExchangeUser
If Not (oEU Is Nothing) Then
ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
Set oEDL = oRecip.AddressEntry.GetExchangeDistributionList
If Not (oEDL Is Nothing) Then
ResolveDisplayNameToSMTP = oEDL.PrimarySmtpAddress
End If
End Select
End If
End Function
Private Function RemoveREFW(str As String) As String
If Left$(UCase(str), 3) = "RE:" Or Left$(UCase(str), 3) = "FW:" Then
str = Trim$(Mid$(str, 4))
ElseIf Left(UCase(str), 4) = "FWD:" Then
str = Trim$(Mid$(str, 5))
End If
RemoveREFW = Trim$(Replace$(Replace$(Replace$(str, "RE:", "", , , vbTextCompare), "FW:", "", , , vbTextCompare), "FWD:", "", , , vbTextCompare))
End Function
