VBA Access - Lendo E-mails do Outlook do Access

Você tem e-mails que gostaria de ver inseridos automaticamente no seu banco de dados ou apenas visualizar o seu conteúdo?

 

O seguinte trecho de código é um exemplo de como fazer isso. Funciona com o Outlook 97, 98 e 2000. Lembre-se de adicionar a referência do MS Outlook para o seu banco de dados ou projeto antes de executar este código.

 

Public Sub ImportOutlookItems()     Dim Olapp As Outlook.Application     Dim Olmapi As Outlook.NameSpace     Dim Olfolder As Outlook.MAPIFolder     Dim OlAccept As Outlook.MAPIFolder     Dim OlDecline As Outlook.MAPIFolder     Dim OlFailed As Outlook.MAPIFolder     Dim OlMail As Object 'Have to late bind as appointments e.t.c screw it up     Dim OlItems As Outlook.Items     Dim OlRecips As Outlook.Recipients     Dim OlRecip As Outlook.Recipient     Dim Rst As DAO.Recordset

    Set Rst = CurrentDb.OpenRecordset("tbl_Temp") ' Abre a tabela table tbl_temp

' Cria uma conexão com o Outlook.     Set Olapp = CreateObject("Outlook.Application")     Set Olmapi = Olapp.GetNamespace("MAPI")

'Abre a pasta Inbox.     Set Olfolder = Olmapi.GetDefaultFolder(olFolderInbox)     Set OlItems = Olfolder.Items

' Configura as pastas que estão configuradas como repositórios de mensagens.

    Set OlAccept = Olfolder.folders("Accept")     Set OlDecline = OLfolder.Folders("Decline")     Set OlFailed = Olfolder.Folders("Failed")

    Do Until OlItems.Count = 0 ' Set up a loop to run till the inbox is empty (otherwise it skips some)     Set OlItems = OLfolder.Items 'Reset the olitems object otherwise new incoming mails and moving mails get missed     For Each OlMail In OlItems

    If OlMail.UnRead = True Then 'For each mail in the collection check the subject line and process accordingly         Let OlMail.UnRead = False 'Marca o e-mail como lido.

        Rst.AddNew

        Let Rst!Name = OlMail.SenderName

        If InStr(1, OlMail.Subject, "Accept") > 0 Then             Let Rst!status = "Attending"             Let Rst!datesent = OlMail.ReceivedTime

            OlMail.Move OlAccept

        ElseIf InStr(1, OlMail.Subject, "Decline") > 0 Then             Let Rst!datesent = OlMail.ReceivedTime             Let Rst!status = "Decline"

            OlMail.Move OlDecline

        Else             Let Rst!datesent = OlMail.ReceivedTime             Let Rst!status = "Failed"

            OlMail.Move OlFailed         End If

        Rst.Update     End If     Next     Loop     MsgBox "Nova mensage foi checada. Por favor check a tabela tbl_temp para mais detalhes", vbOKOnly

End Sub

 

André Luiz Bernardes

Blog Office VBA Blog Excel Blog Access