I found the following code below:
Im using outlook 2003, i wish to export all content of an email and properties just like the outlook export action. My email accounts are either POP or IMAP.
How can I amend the following code to do the job?!
Sub Command0_Click()
Set nms = Application.GetNamespace("MAPI")
strFolder = ""
Set fld = nms.Folders("Personal Folders").Folders(strFolder)
'Pick up path to Access database directory from Access SysCmd function
Set appAccess = CreateObject("Access.Application")
strAccessPath = appAccess.SysCmd(9)
'Get DAO version from DBEngine
strDBEngine = appAccess.Application.DBEngine.Version
'MsgBox "DBEngine version: " & strDBEngine
appAccess.Quit
If strDBEngine = "3.51" Then
'Office 97 DAO version
Set dbe = CreateObject("DAO.DBEngine.35")
strDBName = strAccessPath & "db1.mdb"
ElseIf strDBEngine = "3.6" Then
'Office 2000 DAO version
Set dbe = CreateObject("DAO.DBEngine.36")
strDBName = strAccessPath & "db1.mdb"
Else
MsgBox "Unknown Office version; canceling"
Exit Sub
End If
'MsgBox "DBName: " & strDBName
Set wks = dbe.Workspaces(0)
Set dbs = wks.OpenDatabase("C:\Documents and Settings\warren\My Documents\DB")
'Open Access table containing contact data
Set rst = dbs.OpenRecordset("Table1")
'Set up reference to Outlook folder of items to export
Set itms = fld.Items
ItemCount = itms.Count
If ItemCount = 0 Then
MsgBox "No communication requests to export"
Exit Sub
Else
MsgBox ItemCount & " Communication requests to export"
End If
'Set up reference to Outlook folder of items to export
Set itms = fld.Items
ItemCount = itms.Count
If ItemCount = 0 Then
MsgBox "No Communication requests to export"
Exit Sub
Else
MsgBox ItemCount & " Communication requests to export"
End If
For Each itm In itms
rst.AddNew
'Custom Outlook properties
rst.Datecircular = itm.Senton
rst.Subject = itm.Subject
rst.circular = itm.HTMLBody
rst.Update
Next
rst.Close
MsgBox "All communication requests exported!"
MsgBox "Quit Access"
appAccess.Quit
End Sub
