Srs,
Anteriormente peguei um banco aqui no Forum que extrai informações do e-mail e salva em uma tabela no access(impmail.accdb).
Esse banco atende perfeitamente o que preciso.
Gostaria de alterar o código(abaixo) para pegar as informações de uma PST e não da Caixa de entrada.
Private Function ScanInbox(SubjectLine As String)
Dim TempRst As Recordset
Dim OlApp As Outlook.Application
Dim Inbox As Outlook.MAPIFolder
Dim InboxItems As Outlook.Items
Dim Mailobject As Object
Set OlApp = CreateObject("Outlook.Application")
Set Inbox = OlApp.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox)
Set TempRst = CurrentDb.OpenRecordset("tbl_OutlookTemp")
If SubjectLine <> "" Then
Set InboxItems = Inbox.Items.Restrict("[Subject] = """ & SubjectLine & """")
Else
Set InboxItems = Inbox.Items
End If
For Each Mailobject In InboxItems
With TempRst
On Error Resume Next
.AddNew
!Subject = Mailobject.Subject
!From = Mailobject.SenderName
!To = Mailobject.To
!BOdy = Mailobject.BOdy
!DateSent = Mailobject.SentOn
!Categories = Mailobject.Categories
.Update
'Mailobject.Read = True
End With
Next
Set OlApp = Nothing
Set Inbox = Nothing
Set InboxItems = Nothing
Set Mailobject = Nothing
Set TempRst = Nothing
End Function
obrigado
Anteriormente peguei um banco aqui no Forum que extrai informações do e-mail e salva em uma tabela no access(impmail.accdb).
Esse banco atende perfeitamente o que preciso.
Gostaria de alterar o código(abaixo) para pegar as informações de uma PST e não da Caixa de entrada.
Private Function ScanInbox(SubjectLine As String)
Dim TempRst As Recordset
Dim OlApp As Outlook.Application
Dim Inbox As Outlook.MAPIFolder
Dim InboxItems As Outlook.Items
Dim Mailobject As Object
Set OlApp = CreateObject("Outlook.Application")
Set Inbox = OlApp.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox)
Set TempRst = CurrentDb.OpenRecordset("tbl_OutlookTemp")
If SubjectLine <> "" Then
Set InboxItems = Inbox.Items.Restrict("[Subject] = """ & SubjectLine & """")
Else
Set InboxItems = Inbox.Items
End If
For Each Mailobject In InboxItems
With TempRst
On Error Resume Next
.AddNew
!Subject = Mailobject.Subject
!From = Mailobject.SenderName
!To = Mailobject.To
!BOdy = Mailobject.BOdy
!DateSent = Mailobject.SentOn
!Categories = Mailobject.Categories
.Update
'Mailobject.Read = True
End With
Next
Set OlApp = Nothing
Set Inbox = Nothing
Set InboxItems = Nothing
Set Mailobject = Nothing
Set TempRst = Nothing
End Function
obrigado