Eu busquei na internet uma solução para esse problema, e ninguém parece ter proposto uma solução ainda. Aqui está o que eu fiz:
O problema: Contas de Email do Outlook do tipo IMAP não baixam o Corpo e os Anexos quando chegam pela primeira vez. Especialistas do Outlook em todos os lugares dirão que você pode ajustar isso nas Configurações Avançadas do Outlook, mas, eles estão errados, isso não terá efeito.
Solução 1: Mude para o POP3. Do ponto de vista da programação, isso resolve o problema, mas minha opinião é que, se você não pode fazer isso com o IMAP, você está fazendo errado, certo?
Solução 2: Note que isso é força bruta, mas faz o trabalho. Em ThisOutlookSession:
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim objOutlook As Object
Dim objNameSpace As Object
Set objOutlook = Outlook.Application
Set objNameSpace = objOutlook.GetNamespace("MAPI")
'I am using this code on my gmail
Set Items = objNameSpace.Folders("[email protected]").Folders("Inbox").Items
End Sub
Private Sub Items_ItemAdd(ByVal objItem As Object)
Dim objExcel As Object
Dim objMsg As Object
Dim Atmt As Outlook.Attachment
Dim Atmts As Outlook.Attachments
Dim objFSO As Object
Dim objFile As Object
Dim strFilePath As String
Dim strBody As String
On Error GoTo ErrorHandler
If TypeName(objItem) = "MailItem" Then
Set objMsg = objItem
If objMsg.DownloadState <> 1 Then
objMsg.Display
objMsg.Close (1)
Set objMsg = Nothing
DoEvents
Sleep (1000) 'Need a pause or the loop runs to fast and kills Outlook
RetryMailEvent objItem
Else
strBody = objMsg.Body
Set Atmts = objMsg.Attachments
For Each Atmt In Atmts
If Right$(Atmt.FileName, 3) = "txt" Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
strFilePath = "C:\temp\" & Format(objItem.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
Atmt.SaveAsFile strFilePath
Set objFile = objFSO.OpenTextFile(strFilePath, 1)
strBody = strBody & "[Attatchment] " & objFile.ReadAll & " [/Attatchment]"
objFile.Close
Kill strFilePath
End If
Next Atmt
'Any additional Code you want to run goes here
End If
End If
ProgramExit:
Set objMsg = Nothing
Set objExcel = Nothing
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Em um módulo separado:
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub RetryMailEvent(ByVal objItem As Object)
Dim objExcel As Object
Dim objMsg As Object
Dim Atmt As Outlook.Attachment
Dim Atmts As Outlook.Attachments
Dim objFSO As Object
Dim objFile As Object
Dim strFilePath As String
Dim strBody As String
On Error GoTo ErrorHandler
If TypeName(objItem) = "MailItem" Then
Set objMsg = objItem
If objMsg.DownloadState <> 1 Then
Set objMsg = Nothing
DoEvents
Sleep (1000) 'Need a pause or the loop runs to fast and kills Outlook
RetryMailEvent objItem
Else
strBody = objMsg.Body
Set Atmts = objMsg.Attachments
For Each Atmt In Atmts
If Right$(Atmt.FileName, 3) = "txt" Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
strFilePath = "C:\temp\" & Format(objItem.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
Atmt.SaveAsFile strFilePath
Set objFile = objFSO.OpenTextFile(strFilePath, 1)
strBody = strBody & "[Attatchment] " & objFile.ReadAll & " [/Attatchment]"
objFile.Close
Kill strFilePath
End If
Next Atmt
'Any additional Code you want to run goes here
End If
End If
ProgramExit:
Set objMsg = Nothing
Set objExcel = Nothing
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Observação: tornei-me um usuário do StackExchange apenas para compartilhar essas descobertas com você. Eu gosto disso, por favor, vá em frente e ligue outras almas com problemas semelhantes para aqui:).