|
Option
Explicit
Const
CdoE_ACCESSDENIED = 80070005
Public
Const CdoPR_EMAIL = &H39FE001E
Sub
SaveEmailsToAccess()
On
Error GoTo ErrorHandler
Dim appaccess As Access.Application
Dim dbs As Database
Dim rst As Recordset
Dim i As Integer
Dim lngCount As Long
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
On Error Resume Next
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
Set dbs = OpenDatabase("D:\database.mdb")
Set rst = dbs.OpenRecordset("mails2access")
rst.AddNew
rst!Subject = itm.Subject
rst!Received = itm.ReceivedTime
rst!From = GetFromAddress(itm)
rst!Body
= itm.Body
'rst2.customfield = itm.UserProperties("Custom Field
Name")
rst.Update
rst.Close
On Error Resume Next
End If
Next itm
ErrorHandlerExit:
Exit Sub
ErrorHandler:
If Err.Number = 429 Then
If appaccess Is Nothing Then
Set appaccess = CreateObject("Access.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 |
