|
Option
Explicit
Const
CdoE_ACCESSDENIED = 80070005
Public
Const CdoPR_EMAIL = &H39FE001E
Sub
SaveEmailsToExcel()
On
Error GoTo ErrorHandler
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strRange As String
Dim strSheet As String
Dim strbook As Workbook
Dim lngASCII As Long
Dim strASCII As String
Dim strTemplatePath As String
Dim i As Integer
Dim lngCount As Long
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
'Pick up Template path from the Word Options dialog
strTemplatePath = "D:\"
'Debug.Print "Documents folder: " &
strTemplatePath
strSheet = "export.xls"
strSheet = strTemplatePath & strSheet
Debug.Print "Excel workbook: " & strSheet
i = 1
lngASCII = 64
Set appExcel = GetObject(, "Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.cells(1, 1) = "Subject"
wks.cells(1, 2) = "Received"
wks.cells(1, 3) = "From"
wks.cells(1, 4) = "Body"
wks.Activate
appExcel.Application.Visible = True
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
If fld Is Nothing Then
GoTo ErrorHandlerExit
End If
If fld.DefaultItemType <> olMailItem Then
MsgBox "Folder does not contain messages"
GoTo ErrorHandlerExit
End If
lngCount = fld.Items.Count
If lngCount = 0 Then
MsgBox "No Messages to export"
GoTo ErrorHandlerExit
Else
Debug.Print lngCount & " Messages to export"
End If
For Each itm In fld.Items
If itm.Class = olMail Then
i = i + 1
lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set rng = wks.Range(strRange)
If itm.Subject <> "" Then rng.Value =
itm.Subject
lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set rng = wks.Range(strRange)
If itm.ReceivedTime <> "" Then rng.Value =
itm.ReceivedTime
lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set rng = wks.Range(strRange)
If GetFromAddress(itm) <> "" Then rng.Value =
GetFromAddress(itm)
lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set rng = wks.Range(strRange)
If itm.Body <> "" Then rng.Value = itm.Body
On Error Resume Next
'The next line illustrates the syntax for referencing
'a custom Outlook field
'If itm.UserProperties("CustomField") <>
"" Then
' rng.Value = itm.UserProperties("CustomField")
'End If
lngASCII = 64
End If
Next itm
ErrorHandlerExit:
Exit Sub
ErrorHandler:
If Err.Number = 429 Then
If appExcel Is Nothing Then
Set appExcel = CreateObject("Excel.Application")
Resume Next
End If
Else
MsgBox "Error No: " & Err.Number & ";
Description: "
Resume ErrorHandlerExit
End If
End
Sub
Sub
ShowAddresses()
Dim obj As Object
Set obj = GetCurrentItem()
If obj.Class = olMail Then
MsgBox "Email address is: " & GetFromAddress(obj)
End If
Set obj = Nothing
End
Sub
Function
GetFromAddress(objMsg As Outlook.MailItem)
Dim objSession As MAPI.Session
Dim objCDOMsg As MAPI.Message
Dim strEntryID As String
Dim strStoreID As String
Dim strAddress As String
Dim straddress1 As String
' start CDO session
Set objSession = CreateObject("MAPI.Session")
objSession.Logon , , False, False
' pass message to CDO
strEntryID = objMsg.EntryID
strStoreID = objMsg.Parent.StoreID
Set objCDOMsg = objSession.GetMessage(strEntryID, strStoreID)
' get sender address
On Error Resume Next
strAddress = objCDOMsg.Sender.Address
If Err = CdoE_ACCESSDENIED Then
'handle possible security patch error
MsgBox "The Outlook E-mail and CDO Security Patches are
" & _
"apparently installed on this machine. " & _
"You must response Yes to the prompt about " & _
"accessing e-mail addresses if you want to " & _
"get the From address.", vbExclamation, _
"GetFromAddress"
End If
GetFromAddress = strAddress
On Error GoTo 0
Set objCDOMsg = Nothing
objSession.Logoff
Set objSession = Nothing
End
Function
|
