MarkStones
asked on
Import Outlook 2007 Messages to Access 2007/SQL table including file attachments
Hi
I'm trying to find a way of importing email messages along with their file attachments to a access 2007 table or MS SQL linked table (preffered) then delete the messages from the outlook folder.
I've managed to link the outlook folder to access and view messages via a form but as yet been unable to do find the atachments or successfully automate the import of the outlook data to either a local table or linked sql table.
Any help would be appreciated
thanks
Mark
I'm trying to find a way of importing email messages along with their file attachments to a access 2007 table or MS SQL linked table (preffered) then delete the messages from the outlook folder.
I've managed to link the outlook folder to access and view messages via a form but as yet been unable to do find the atachments or successfully automate the import of the outlook data to either a local table or linked sql table.
Any help would be appreciated
thanks
Mark
Here is some code that loads saved attachments to an Attachments-type field in an Access 2007 database.
Public Function SaveAttachments()
On Error GoTo ErrorHandler
Set appWord = GetObject(, "Word.Application")
strDefaultDocsPath = appWord.Options.DefaultFilePath(wdDocumentsPath) & "\"
strDocsPath = GetProperty("OutputDocsPath", strDefaultDocsPath)
Debug.Print "Output docs path: " & strDocsPath
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(strDocsPath)
Set dbs = CurrentDb
Set rstTable = dbs.OpenRecordset("tblContacts")
Do While Not rstTable.EOF
'Create recordset of attachments for this record
Set rstAttachments = _
rstTable.Fields("File").Value
With rstAttachments
Do While Not .EOF
strFileAndPath = strDocsPath _
& .Fields("FileName")
'Save this attachment to a file in the Output
'Docs folder
Debug.Print "Saving " & strFileAndPath _
& " to " & strDocsPath & " folder"
'Turn off error handler to prevent errors if
'the file already exists in the folder.
On Error Resume Next
.Fields("FileData").SaveToFile strFileAndPath
.MoveNext
Loop
.Close
End With
rstTable.MoveNext
Loop
rstTable.Close
strPrompt = "All new attachments saved to " _
& strDocsPath & " folder"
strTitle = "Done!"
MsgBox strPrompt, vbOKOnly + vbInformation, strTitle
ErrorHandlerExit:
Exit Function
ErrorHandler:
If Err = 429 Then
'Word is not running; open Word with CreateObject
Set appWord = CreateObject("Word.Application")
Resume Next
Else
MsgBox "Error No: " & Err.Number & "; Description: " _
& Err.Description
Resume ErrorHandlerExit
End If
End Function
On Error GoTo ErrorHandler
Set appWord = GetObject(, "Word.Application")
strDefaultDocsPath = appWord.Options.DefaultFilePath(wdDocumentsPath) & "\"
strDocsPath = GetProperty("InputDocsPath", strDefaultDocsPath)
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(strDocsPath)
Set dbs = CurrentDb
Set rstTable = dbs.OpenRecordset("tblContacts", dbOpenDynaset)
For Each fil In fld.Files
strFile = fil.Name
Debug.Print "File name: " & strFile
Debug.Print "File type: " & fil.Type
'Check whether file name starts with 'Contact ID'
If Left(strFile, 10) = "Contact ID" Then
'Extract Contact ID from file name, using Mid and
'InStr to start at the beginning of the number and
'end before the space following the number,
'if there is one
strTest = Mid(String:=strFile, Start:=12, Length:=3)
intSpace = InStr(strTest, " ")
If intSpace > 0 Then
lngContactID = CLng(Mid(String:=strTest, _
Start:=1, Length:=intSpace - 1))
Else
lngContactID = CLng(strTest)
End If
strSearch = "[ContactID] = " & lngContactID
Debug.Print "Search string: " & strSearch
strFileAndPath = strDocsPath & strFile
'Search for matching Contact ID in table
rstTable.MoveFirst
rstTable.FindFirst strSearch
If rstTable.NoMatch = True Then
strTitle = "Can't find contact"
strPrompt = "Contact ID " & lngContactID _
& " not found in table; can't add attachment"
GoTo NextDoc
Else
rstTable.Edit
'Create recordset of attachments for this record
Set rstAttachments = _
rstTable.Fields("File").Value
'Turn off error handler to prevent errors if the
'code attempts to add the same file twice; in this
'case the Attachments recordset won't be updated
On Error Resume Next
With rstAttachments
.AddNew
.Fields("FileData").LoadFromFile _
(strFileAndPath)
.Update
.Close
End With
rstTable.Update
Debug.Print "Added " & strFileAndPath _
& " as attachment to Contact ID " _
& lngContactID; "'s record"
End If
End If
NextDoc:
Next fil
'Open Contacts form to see the attachments
'that have been loaded
DoCmd.OpenForm FormName:="frmContacts"
ErrorHandlerExit:
Exit Function
ErrorHandler:
If Err = 429 Then
'Word is not running; open Word with CreateObject
Set appWord = CreateObject("Word.Application")
Resume Next
Else
MsgBox "Error No: " & Err.Number & "; Description: " _
& Err.Description
Resume ErrorHandlerExit
End If
End Function
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Both of these functions are from my Access Archon article #188, Working with the New Access 2007 Attachments field. I tried to attach a zip with the article and sample database, but the .accdb file was rejected. Here is a link for downloading the zip: http://www.helenfeddema.com/Files/accarch188.zip
At the risk of getting a little bit off topic - Hello Helen - You saved me when learning how to automate Word from Access. You have some great tutorials on this on your website. Thank you Thank you.
darbid73 -- you might be interested in my new ebook, Working with Word, which is all about moving data from Access to Word. Here is a link for it: http://shop.office-watch.com/aww/
Once you have an email you need to use the Attachments collection to loop through all of the attachments to the email.
In my example it loops though the attachments and saves each attachment of the email to C drive.
In this part you could do anything you like including saving it to an open record set or what ever you like.
Open in new window