Email subjectline to access tables 1

[ianclegg]

Hi

Can anyone help??

I have a need to automate saving the email subject line to a field in an access table

Thanks in anticipation


Ian Clegg

 

[TomCologne]

Try something like this:

'''''''''''''''''''''''''''''''''''''''''''''''
'' Import email messages from Outlook to table
''
'' tblEmail:
''
'' EntryID: Text; Primary Key
'' To: Memo, Required = False, AllowZeroLength = True
'' From: Text
'' ReceivedTime: Date/Time
'' Subject: Memo, Required = False, AllowZeroLength = True
'' Message: Memo, Required = False, AllowZeroLength = True
'' AttachmentCount: Number
''
'' Note: The OL EntryID changes when mail is moved to another folder!
''
'' References:
''
'' Microsoft DAO 3.6 Object Library,
'' Microsoft Outlook 9.0 Object Library
''
'''''''''''''''''''''''''''''''''''''''''''''''

Sub OlEmail()
On Error GoTo Err_OlEmail

Dim molApp As Outlook.Application
Dim molNameSpace As Outlook.NameSpace
Dim molMAPI As Outlook.MAPIFolder
Dim molItems As Outlook.Items
Dim molMail As Outlook.MailItem

Dim rst As DAO.Recordset ', rstErr As DAO.Recordset
Dim i As Integer, iCount As Integer
      
   Set rst = CurrentDb.OpenRecordset("tblEmail")
      Set molApp = CreateObject("Outlook.Application")
   Set molNameSpace = molApp.GetNamespace("MAPI")
   Set molMAPI = molNameSpace.GetDefaultFolder(olFolderInbox)
   Set molItems = molMAPI.Items
   
   iCount = molItems.Count
   
      For i = 1 To iCount
      
            If TypeName(molItems(i)) = "MailItem" Then
            
               Set molMail = molItems(i)
                             
               rst.AddNew

               rst!EntryID = molMail.EntryID
               rst!To = molMail.To
               rst!From = molMail.SenderName
               rst!Subject = molMail.Subject
               rst!Message = molMail.Body
               rst!Received = molMail.ReceivedTime
               rst!AttachmentCount = molMail.Attachments.Count

               rst.Update
                               
            End If
            
      Next i
      
      
Exit_OlEmail:

    MsgBox "Import finished"
    
   rst.Close

   Set rst = Nothing
   Set molApp = Nothing
   Set molNameSpace = Nothing
   Set molMAPI = Nothing
   Set molItems = Nothing
   
   Exit Sub
   
Err_OlEmail:

    '' Err.Number 3022:
    '' The changes you requested to the table were not successful because
    '' they would create duplicate values in the index, primary key, or relationship.
    '' Change the data in the field or fields that contain duplicate data,
    '' remove the index, or redefine the index to permit duplicate entries and try again.
    
     If Err.Number = 3022 Then
     
       Resume Next
       
     Else
     
       If MsgBox(Err.Number & vbCrLf & vbCrLf & Err.Description & vbCrLf & vbCrLf _
            & "Click OK to continue, Cancel to exit " _
             , vbOKCancel, "Procedure Error: OlEmail") = vbCancel Then

          Resume Exit_OlEmail

       Else
       
           Resume Next
           
       End If
       
     End If
      
End Sub

This procedure will only import mails in the "Inbox" folder, subfolders are not included.


TomCologne

 

[ianclegg]

Thanks for that, the code worked first time . Excellent !!!!
Regards


Ian Clegg