[AccessD] Outlook Automation

Rocky - here it is again. 

This works to retrieve mail messages if you put them in a subfolder of Inbox (in my case 'Customer Inquiries'.)

--------------------------------------------------------------------------------

Public Function ProcessMailMessagesInFolder()
'Adapted by K Pelletti from code from Helen Feddema 3-28-2002
Dim strerrormsg As String
On Error GoTo Err_Handler
   
   Dim appOutlook As New Outlook.Application

   Dim nms As Outlook.NameSpace
   Dim fld As Outlook.MAPIFolder
   Dim myfld As Outlook.MAPIFolder

   Dim itm As Object
   Dim msg As Outlook.MailItem
   Dim strMessage As String
   Dim dbs As DAO.Database
   Dim rst As DAO.Recordset
   Dim strsql As String
   Dim prj As Object
   Dim lngItemCount As Long
   Dim IntFolderNo As Integer
   Dim IntTotalNoFoldersInInbox As Integer
   Dim IntNoMailItems As Integer
   Dim BoolFolderFound As Boolean
   BoolFolderFound = False
    
    Set nms = appOutlook.GetNamespace("MAPI")
    Set fld = nms.GetDefaultFolder(olFolderInbox)
    IntFolderNo = 0
    IntTotalNoFoldersInInbox = 0
    IntNoMailItems = 0
    IntTotalNoFoldersInInbox = fld.Folders.Count
    
    Do Until IntFolderNo = IntTotalNoFoldersInInbox    
        IntFolderNo = IntFolderNo + 1
        Set myfld = fld.Folders(IntFolderNo)
        If myfld.Name = "Customer Inquiries" Then            'Rocky - put your subfolder Outlook name here
            BoolFolderFound = True
            IntNoMailItems = myfld.Items.Count
'            MsgBox ("No messages is: " & IntNoMailItems)
            Exit Do
        End If
    Loop
   
    If BoolFolderFound = False Then
        MsgBox ("Unable to find the Customer Inquiries Folder in Outlook." & vbCrLf & vbCrLf & "(The folder should be a subfolder of inbox.)"), , "Hudsons Database"
        GoTo Normal_exit
    End If
   
    If myfld Is Nothing Then
       GoTo Err_Handler
    End If
    
    If myfld.DefaultItemType <> olMailItem Then
       MsgBox "Folder does not contain mail messages; Exiting", , "Importing Mail"
       GoTo Normal_exit
    End If
    
    lngItemCount = myfld.Items.Count
    
    If lngItemCount = 0 Then
        MsgBox ("There are no mail messages in the Customer Inquiries folder."), , "Hudsons Database"
       GoTo Normal_exit
    End If
   
   'Process items in selected folder
   strsql = "DELETE * FROM tblOutlookMail"
   DoCmd.SetWarnings False
   DoCmd.RunSQL strsql
   Set dbs = CurrentDb
   Set rst = dbs.OpenRecordset("tblOutlookMail")
   
   For Each itm In myfld.Items
      If itm.Class = olMail Then
         Set msg = itm
         With rst
            .AddNew
            !Subject = msg.Subject
            !Body = msg.Body
            !CC = msg.CC
            !BCC = msg.BCC
            !Sent = msg.SentOn
            !FromName = msg.SenderName
            .Update
         End With
      End If
   Next itm
   rst.Close
   
   Set prj = Application.CurrentProject

   If prj.AllForms("frmOutlookMail").IsLoaded = True Then
      Forms("frmOutlookMail").Requery
   Else
      DoCmd.OpenForm "frmOutlookMail", , , , , acDialog
   End If

 
Normal_exit:
  '  MsgBox ("No of new mail messages: " & IntNoMailItems), , "Mail Import"
    Exit Function
Err_Handler:
    MsgBox "Error: [" & Err.Number & "]  " & IIf(Len(strerrormsg) > 0, strerrormsg, Err.Description), vbCritical, "Error Message"
    hCursor = CursorID
    RetVal = SetCursor(hCursor)
    Resume Normal_exit

End Function
  Kath