|
Option
Explicit
Const
CdoE_ACCESSDENIED = 80070005
Public
Const CdoPR_EMAIL = &H39FE001E
Sub
SaveEmailsToWord()
On
Error GoTo ErrorHandler
Dim appword As Word.Application
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
Dim oNewDoc As Word.Document
Dim WordWasNotRunning As Boolean
On Error Resume Next
Set appword = GetObject(, "Word.Application")
If Err Then
Set appword = New Word.Application
WordWasNotRunning = True
End If
appword.Visible = True
Set oNewDoc = appword.Documents.Add(Template:="normal.dot")
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
oNewDoc.Range.Text = oNewDoc.Range.Text & "Subject:
" & itm.Subject
oNewDoc.Range.Text = oNewDoc.Range.Text & "Received:
" & itm.ReceivedTime
oNewDoc.Range.Text = oNewDoc.Range.Text & "From: "
& GetFromAddress(itm)
oNewDoc.Range.Text = oNewDoc.Range.Text & "Body: "
& itm.Body
On Error Resume Next
End If
Next itm
ErrorHandlerExit:
Exit Sub
ErrorHandler:
If Err.Number = 429 Then
If appword Is Nothing Then
Set appword = CreateObject("word.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
'The
next part of the code was used from Sue Mosher site: http://www.outlookcode.com/d/code/getsenderaddy.htm
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 |
