Solved

Import Outlook 2007 Messages to Access 2007/SQL table including file attachments

Posted on 2009-07-15
6
560 Views
Last Modified: 2013-11-28
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
0
Comment
Question by:MarkStones
  • 4
  • 2
6 Comments
 
LVL 19

Expert Comment

by:darbid73
Comment Utility
I do not know how you are getting your email object but below is one way which is getting the currently selected email.

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.




Dim out_Exp As Outlook.Explorer

Dim out_Sel As Outlook.Selection

Dim out_mail As Outlook.MailItem

Dim out_att As Outlook.Attachment
 
 

'get the active explorer

Set out_Exp = Outlook.ActiveExplorer
 

'get a collection of what is selected use this to make sure only one email is selected

Set out_Sel = out_Exp.Selection
 
 

Set out_mail = out_Sel.Item(1)
 

For Each out_att In out_mail.Attachments
 

    Debug.Print out_att.DisplayName
 
 

out_att.SaveAsFile "C:\" & out_att.DisplayName
 
 

Next out_att
 

'delete the email.

out_mail.Delete

Open in new window

0
 
LVL 31

Expert Comment

by:Helen_Feddema
Comment Utility
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

Open in new window

0
 
LVL 31

Accepted Solution

by:
Helen_Feddema earned 500 total points
Comment Utility
Sorry, that was the SaveAttachments function -- maybe you can use that too.  Here is the LoadAttachments function.
Public Function LoadAttachments()
 

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

Open in new window

0
6 Surprising Benefits of Threat Intelligence

All sorts of threat intelligence is available on the web. Intelligence you can learn from, and use to anticipate and prepare for future attacks.

 
LVL 31

Expert Comment

by:Helen_Feddema
Comment Utility
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
0
 
LVL 19

Expert Comment

by:darbid73
Comment Utility
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.
0
 
LVL 31

Expert Comment

by:Helen_Feddema
Comment Utility
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/
0

Featured Post

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

Introduction When developing Access applications, often we need to know whether an object exists.  This article presents a quick and reliable routine to determine if an object exists without that object being opened. If you wanted to inspect/ite…
I originally created this report in Crystal Reports 2008 where there is an option to underlay sections. I initially came across the problem in Access Reports where I was unable to run my border lines down through the entire page as I was using the P…
In Microsoft Access, learn how to use Dlookup and other domain aggregate functions and one method of specifying a string value within a string. Specify the first argument, which is the expression to be returned: Specify the second argument, which …
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…

772 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

9 Experts available now in Live!

Get 1:1 Help Now