Solved

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

Posted on 2009-07-15
6
561 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
ID: 24858356
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
ID: 24868819
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
ID: 24868837
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
Ransomware-A Revenue Bonanza for Service Providers

Ransomware – malware that gets on your customers’ computers, encrypts their data, and extorts a hefty ransom for the decryption keys – is a surging new threat.  The purpose of this eBook is to educate the reader about ransomware attacks.

 
LVL 31

Expert Comment

by:Helen_Feddema
ID: 24868888
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
ID: 24876441
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
ID: 24879041
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

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

QuickBooks® has a great invoice interface that we were happy with for a while but that changed in 2001 through no fault of Intuit®. Our industry's unit names are dictated by RUS: the Rural Utilities Services division of USDA. Contracts contain un…
In a multiple monitor setup, if you don't want to use AutoCenter to position your popup forms, you have a problem: where will they appear?  Sometimes you may have an additional problem: where the devil did they go?  If you last had a popup form open…
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
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 …

867 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

18 Experts available now in Live!

Get 1:1 Help Now