I have scoured the internet for a solution to this problem, and no one seems to have proposed a solution, yet. Here's what I've come up with:
The Problem:
IMAP-Type Outlook Email Accounts do not download their Body and Attachments when they first arrive. Outlook experts everywhere will tell you you can adjust this in the Outlook Advanced Settings, but, they are wrong, that will have no effect.
Solution 1:
Switch to POP3. From a programming standpoint, this solves the problem, but my opinion is that if you can't do it with IMAP, then you're doing it wrong, right?
Solution 2:
Note that this is brute force, but it gets the job done.
In 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("mathern29@gmail.com").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
In a separate module:
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
Note: I became a StackExchange user just to share these findings with you. I you like it, please go forth and link other troubled souls with similar problems to here :).
