[Resolvido]Receber e-mails com anexos atraves do Access

Olá, eu sou novo aqui no fórum. Estou com um problema, e se puderem me ajudar ficarei agradecido.

Eu gostaria de receber e-mails com anexos através do Access. Para isso eu vinculei uma tabela do Access com o Outlook, porém eu só recebo os dados das mensagens, mas não consigo receber os anexos.

O que devo fazer para recebê-los?

Tentou vincular uma listbox ao campo anexos do Outlook? Poderia tentar colocar os anexos do outlook como fonte para a listbox ou combo ou subform.

Como eu poderia fazer isso? Não sei onde ficam armazenados os anexos do Outlook.

Não sei se ajuda, mas este código salva todos os anexos dos emails recebidos(inbox), numa pasta em C:\AnexosRecebidos

Tem de habilitar a referencia VBA:
Microsoft Outlook xx.0 Object Library


Option Explicit

Sub SalvaAnexosDosEmails()
On Error GoTo SalvaAnexosDosEmails_err

Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
i = 0
' Verifica a caixa de entrada de mensagens
If Inbox.Items.Count = 0 Then
MsgBox "Não existem mensagens na sua Caixa de Entrada", vbInformation, "Erro"
Exit Sub
End If
' Verifica se os emails têm anexos
For Each Item In Inbox.Items
' Salva os anexos encontrados
For Each Atmt In Item.Attachments
FileName = "C:\AnexosRecebidos" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
Next Atmt
Next Item
If i > 0 Then
MsgBox "Encontrados " & i & " anexos." _
& vbCrLf & "Salvos na pasta C:\AnexosRecebidos" _
& vbCrLf & vbCrLf & "Sucesso.", vbInformation, "Fim!"
Else
MsgBox "Não foram encontrados anexos nos emails recebidos", vbInformation, "Fim!"
End If
SalvaAnexosDosEmails_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
SalvaAnexosDosEmails_err:
MsgBox "Ocorreu um erro inesperado." _
& vbCrLf & "Erro numero: " & Err.Number _
& vbCrLf & "Erro Descrição: " & Err.Description _
, vbCritical, "Erro!"
Resume SalvaAnexosDosEmails_exit
End Sub

JPaulo, quando excuto esse código aparece um erro de compilação.

Segue Print em anexo.

Não vejo o print mas testei aqui e funcionaou em pleno.

Habilitou a referência Microsoft Outlook xx.0 Object Library?

Habilitei sim. O erro ocorre na sintax "Atmt.SaveAsFile FileName".

Habilite neste exemplo a referencia Microsoft Outlook xx.0 Object Library


http://dl.dropbox.com/u/771097/filipe.rar

JPaulo, ocorre o mesmo erro. Eu observei que o meu Outlook está configurado como POP e não MAPI. Esse código está utilizando o MAPI. Teria como utilizar a configuração POP?

Filipe, conseguiu resolver essa questão? Vou passar o tópico a Resolvido. Se necessário, reabra-o.

Caro JP porventur tem algum exemplo contendo os objetos InBox e etc.. para rebeer e-mails atraves do access?

Eu gostaria de reabrir este tópico já que estou com o mesmo problema que teve o Filipe e não consigo resolvé-lo.
O erro é o mesmo. ver código a vermelho.
saudações
di

Sub SalvaAnexosDosEmails()
On Error GoTo SalvaAnexosDosEmails_err

Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
i = 0
' Verifica a caixa de entrada de mensagens
If Inbox.Items.Count = 0 Then
MsgBox "Não existem mensagens na sua Caixa de Entrada", vbInformation, "Erro"
Exit Sub
End If
' Verifica se os emails têm anexos
For Each Item In Inbox.Items
' Salva os anexos encontrados
For Each Atmt In Item.Attachments
FileName = "C:\AnexosRecebidos" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
Next Atmt
Next Item
If i > 0 Then
MsgBox "Encontrados " & i & " anexos." _
& vbCrLf & "Salvos na pasta C:\AnexosRecebidos" _
& vbCrLf & vbCrLf & "Sucesso.", vbInformation, "Fim!"
Else
MsgBox "Não foram encontrados anexos nos emails recebidos", vbInformation, "Fim!"
End If
SalvaAnexosDosEmails_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
SalvaAnexosDosEmails_err:
MsgBox "Ocorreu um erro inesperado." _
& vbCrLf & "Erro numero: " & Err.Number _
& vbCrLf & "Erro Descrição: " & Err.Description _
, vbCritical, "Erro!"
Resume SalvaAnexosDosEmails_exit
End Sub

Sub SalvaAnexosDosEmails()
On Error GoTo SalvaAnexosDosEmails_err

Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Outlook.Attachment
'Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
i = 0
' Verifica a caixa de entrada de mensagens
If Inbox.Items.Count = 0 Then
MsgBox "Não existem mensagens na sua Caixa de Entrada", vbInformation, "Erro"
Exit Sub
End If
' Verifica se os emails têm anexos
For Each Item In Inbox.Items
' Salva os anexos encontrados
For Each Atmt In Item.Attachments
FileName = "D:\anexos\" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
Next Atmt
Next Item
If i > 0 Then
MsgBox "Encontrados " & i & " anexos." _
& vbCrLf & "Salvos na pasta D:\anexos\" _
& vbCrLf & vbCrLf & "Sucesso.", vbInformation, "Fim!"
Else
MsgBox "Não foram encontrados anexos nos emails recebidos", vbInformation, "Fim!"
End If
SalvaAnexosDosEmails_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
SalvaAnexosDosEmails_err:
MsgBox "Ocorreu um erro inesperado." _
& vbCrLf & "Erro numero: " & Err.Number _
& vbCrLf & "Erro Descrição: " & Err.Description _
, vbCritical, "Erro!"
Resume SalvaAnexosDosEmails_exit
End Sub

JPaulo como faço para receber as informações desse codigo que voce postou para que ele pegue tambem os campos "CC e Cco" por favor precisando muito disso fico no aguardo.

se poder ja postar o codigo completo com a alteração agradeço muito obrigado.

.AddNew
       !Titulo = Mailobject.Subject
       !De = Mailobject.SenderName
       !Para = Mailobject.To
       !DataEnvio = Mailobject.SentOn