Save outlook email to access database

[jrb]

I have a database which holds info such as sender, date, subject, etc., but instead of copying all that information by hand from an e-mail, is there a way to do it programmatically?

Can somebody point me in the right direction? A website maybe?

[gcomyn]

Here is a module that I use to do that, as well as save the emails and attachments to a directory tree set up like the folder tree in outlook. You can either take the saving part out, or not, as you wish.


Option Compare Database
Option Explicit

Public Sub Save_To_Access()
Dim j As Long
Dim n As Long
Dim StrSubject As String
Dim StrName As String
Dim StrFile As String
Dim StrWho As String
Dim StrReceived As String
Dim StrSavePath As String
Dim StrFolder As String
Dim StrFolderPath As String
Dim StrSaveFolder As String
Dim Prompt As String
Dim Title As String
Dim iNameSpace As NameSpace
Dim myOlApp As Outlook.Application
Dim SubFolder As MAPIFolder
Dim mItem As MailItem
Dim ChosenFolder As Object
Dim Folders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection
Dim i As Long
Dim y As Long
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strAttachments As String
Dim olAtt As Outlook.Attachment
Dim bolProcess As Boolean


Set db = CurrentDb
Set rs = db.OpenRecordset("tblEmails")

Set myOlApp = Outlook.Application
Set iNameSpace = myOlApp.GetNamespace("MAPI")
Set ChosenFolder = iNameSpace.GetDefaultFolder(olFolderInbox).Parent
If ChosenFolder Is Nothing Then
GoTo ExitSub
End If

StrSavePath = "C:\Stan\Outlook\"
If StrSavePath = "" Then
GoTo ExitSub
End If
If Not Right(StrSavePath, 1) = "\" Then
StrSavePath = StrSavePath & "\"
End If

Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)

bolProcess = False
For i = 1 To Folders.Count
StrFolder = StripIllegalChar(Folders(i))
Debug.Print StrFolder
If InStr(1, StrFolder, "Inbox") = 0 And _
InStr(1, StrFolder, "Calendar") = 0 And _
InStr(1, StrFolder, "Contacts") = 0 And _
InStr(1, StrFolder, "Conversation History") = 0 And _
InStr(1, StrFolder, "Deleted Items") = 0 And _
InStr(1, StrFolder, "Drafts") = 0 And _
InStr(1, StrFolder, "Journal") = 0 And _
InStr(1, StrFolder, "Notes") = 0 And _
InStr(1, StrFolder, "Outbox") = 0 And _
InStr(1, StrFolder, "RSS Feeds") = 0 And _
InStr(1, StrFolder, "Tasks") = 0 Then
n = InStr(3, StrFolder, "\") + 1
StrFolder = Mid(StrFolder, n, 256)
StrFolderPath = StrSavePath & StrFolder & "\"
StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
If Dir(StrFolderPath, vbDirectory) = "" Then
Call CreateSubDirectories(StrFolderPath)
End If
'If InStr(1, StrFolder, "Read") = 1 Then Stop
Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next
For j = SubFolder.Items.Count To 1 Step -1
Set mItem = SubFolder.Items(j)
bolProcess = CDate(mItem.SentOn) < DateAdd("d", -20, Date) ' checks the sent date to see if it was 20 days ago or more, if so, then process
If Not bolProcess Then bolProcess = InStr(1, StrFolder, "Read") = 1 'My own folder... I want all emails in these folders to be extracted, no matter the date. This can be removed if you do not have a "Read" folder
If bolProcess Then
StrReceived = ArrangedDate(mItem.ReceivedTime)
StrSubject = mItem.Subject
StrName = StripIllegalChar(StrSubject)
StrWho = mItem.SenderName
Debug.Print j & " - " & StrSubject
With rs
.AddNew
!FolderName = StripIllegalChar(Folders(i))
!Subject = StrSubject
!To = mItem.To
!From = StrWho
!BCC = mItem.BCC
!CC = mItem.CC
!Body = mItem.Body
!HTMLBody = mItem.HTMLBody
!Attachments = mItem.Attachments.Count
!CreationTime = mItem.CreationTime
!EntryID = mItem.EntryID
!ReceivedTime = mItem.ReceivedTime
!AlternateRecipientAllowed = mItem.AlternateRecipientAllowed
If mItem.Attachments.Count > 0 Then
If InStr(1, mItem.Body, "This message has been archived.") > 0 Then
strAttachments = "Attachments have been Archived."
Else
For y = 1 To mItem.Attachments.Count
Set olAtt = mItem.Attachments(y)
If Len(strAttachments) = 0 Then
strAttachments = olAtt.FileName
Else
strAttachments = strAttachments & ", " & olAtt.FileName
End If
olAtt.SaveAsFile Left(StrSaveFolder & StrWho & " - " & StrReceived & " - " & StrName, 200) & " - " & olAtt.FileName
Next y
End If
!Attachments_Names = strAttachments
strAttachments = ""
End If
!AutoForwarded = mItem.AutoForwarded
!AutoResolvedWinner = mItem.AutoResolvedWinner
!BillingInformation = mItem.BillingInformation
!Categories = mItem.Categories
!Companies = mItem.Companies
!ConversationIndex = mItem.ConversationIndex
!ConversationTopic = mItem.ConversationTopic
!DeferredDeliveryTime = mItem.DeferredDeliveryTime
!DeleteAfterSubmit = mItem.DeleteAfterSubmit
!ExpiryTime = mItem.ExpiryTime
!FlagRequest = mItem.FlagRequest
!InternetCodepage = mItem.InternetCodepage
!IsConflict = mItem.IsConflict
!IsMarkedAsTask = mItem.IsMarkedAsTask
!LastModificationTime = mItem.LastModificationTime
!MessageClass = mItem.MessageClass
!Mileage = mItem.Mileage
!NoAging = mItem.NoAging
!OriginatorDeliveryReportRequested = mItem.OriginatorDeliveryReportRequested
!OutlookInternalVersion = mItem.OutlookInternalVersion
!OutlookVersion = mItem.OutlookVersion
!ReadReceiptRequested = mItem.ReadReceiptRequested
!ReceivedByEntryID = mItem.ReceivedByEntryID
!ReceivedByName = mItem.ReceivedByName
!ReceivedOnBehalfOfEntryID = mItem.ReceivedOnBehalfOfEntryID
!ReceivedOnBehalfOfName = mItem.ReceivedOnBehalfOfName
!ReceivedTime = mItem.ReceivedTime
!RecipientReassignmentProhibited = mItem.RecipientReassignmentProhibited
!ReminderOverrideDefault = mItem.ReminderOverrideDefault
!ReminderPlaySound = mItem.ReminderPlaySound
!ReminderSet = mItem.ReminderSet
!ReminderSoundFile = mItem.ReminderSoundFile
!ReminderTime = mItem.ReminderTime
!ReplyRecipientNames = mItem.ReplyRecipientNames
!Saved = mItem.Saved
!SenderEmailAddress = mItem.SenderEmailAddress
!SenderEmailType = mItem.SenderEmailType
!SenderName = mItem.SenderName
!Sent = mItem.Sent
!SentOn = mItem.SentOn
!SentOnBehalfOfName = mItem.SentOnBehalfOfName
!Size = mItem.Size
!Submitted = mItem.Submitted
!TaskCompletedDate = mItem.TaskCompletedDate
!TaskDueDate = mItem.TaskDueDate
!TaskStartDate = mItem.TaskStartDate
!TaskSubject = mItem.TaskSubject
!ToDoTaskOrdinal = mItem.ToDoTaskOrdinal
!UnRead = mItem.UnRead
!VotingOptions = mItem.VotingOptions
!VotingResponse = mItem.VotingResponse
!DateEntered = Date
.Update
End With
StrFile = StrSaveFolder & StrWho & " - " & StrReceived & " - " & StrName & ".msg"
StrFile = Left(StrFile, 256)
mItem.SaveAs StrFile, olMSG
mItem.Delete
Else
Exit For
End If
Next j
End If
On Error GoTo 0
Next i
ExitSub:
End Sub


Function StripIllegalChar(StrInput)

Dim RegX As Object

Set RegX = CreateObject("vbscript.regexp")

RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
RegX.IgnoreCase = True
RegX.Global = True

StripIllegalChar = RegX.Replace(StrInput, "")

ExitFunction:

Set RegX = Nothing

End Function


Function ArrangedDate(StrDateInput)
Dim StrFullDate As String
Dim StrFullTime As String
Dim StrAMPM As String
Dim StrTime As String
Dim StrYear As String
Dim StrMonthDay As String
Dim StrMonth As String
Dim StrDay As String
Dim StrDate As String
Dim StrDateTime As String
Dim RegX As Object

Set RegX = CreateObject("vbscript.regexp")

If Not Left(StrDateInput, 2) = "10" And _
Not Left(StrDateInput, 2) = "11" And _
Not Left(StrDateInput, 2) = "12" Then
StrDateInput = "0" & StrDateInput
End If

StrFullDate = Left(StrDateInput, 10)

If Right(StrFullDate, 1) = " " Then
StrFullDate = Left(StrDateInput, 9)
End If

StrFullTime = Replace(StrDateInput, StrFullDate & " ", "")

If Len(StrFullTime) = 10 Then
StrFullTime = "0" & StrFullTime
End If

StrAMPM = Right(StrFullTime, 2)
StrTime = StrAMPM & "-" & Left(StrFullTime, 8)
StrYear = Right(StrFullDate, 4)
StrMonthDay = Replace(StrFullDate, "/" & StrYear, "")
StrMonth = Left(StrMonthDay, 2)
StrDay = Right(StrMonthDay, Len(StrMonthDay) - 3)
If Len(StrDay) = 1 Then
StrDay = "0" & StrDay
End If
StrDate = StrYear & "-" & StrMonth & "-" & StrDay
StrDateTime = StrDate & "_" & StrTime
RegX.Pattern = "[\:\/\ ]"
RegX.IgnoreCase = True
RegX.Global = True

ArrangedDate = RegX.Replace(StrDateTime, "-")

ExitFunction:

Set RegX = Nothing

End Function

Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As MAPIFolder)

Dim SubFolder As MAPIFolder

Folders.Add Fld.FolderPath
EntryID.Add Fld.EntryID
StoreID.Add Fld.StoreID
For Each SubFolder In Fld.Folders
GetFolder Folders, EntryID, StoreID, SubFolder
Next SubFolder

ExitSub:

Set SubFolder = Nothing

End Sub


Function BrowseForFolder(Optional OpenAt As String) As String
Dim ShellApp As Object

Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0

Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then
BrowseForFolder = ""
End If
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then
BrowseForFolder = ""
End If
Case Else
BrowseForFolder = ""
End Select

ExitFunction:

Set ShellApp = Nothing

End Function

Function CreateSubDirectories(fullPath As String)
Dim str As String
Dim strarray As Variant
Dim i As Long
Dim basePath As String
Dim newPath As String
' add trailing slash
str = fullPath
If Right$(str, 1) <> "\" Then
str = str & "\"
End If
' split string into array
strarray = Split(str, "\")
basePath = strarray(0) & "\"
' loop through array and create progressively
' lower level folders
For i = 1 To UBound(strarray) - 1
If Len(newPath) = 0 Then
newPath = basePath & newPath & strarray(i) & "\"
Else
newPath = newPath & strarray(i) & "\"
End If
If Not FileOrDirExists(newPath) Then
MkDir newPath
End If
Next i
End Function

Function FileOrDirExists(PathName As String) As Boolean
'Macro Purpose: Function returns TRUE if the specified file
' or folder exists, false if not.
'PathName : Supports Windows mapped drives or UNC
' : Supports Macintosh paths
'File usage : Provide full file path and extension
'Folder usage : Provide full folder path
' Accepts with/without trailing "\" (Windows)
' Accepts with/without trailing ":" (Macintosh)

Dim iTemp As Integer

'Ignore errors to allow for error evaluation
On Error Resume Next
iTemp = GetAttr(PathName)

'Check if error exists and set response appropriately
Select Case Err.Number
Case Is = 0
FileOrDirExists = True
Case Else
FileOrDirExists = False
End Select

'Resume error checking
On Error GoTo 0
End Function

GComyn
:sleuth:

[jrb]

Thanks for the code I will give it a go