Я искал в Интернете решение этой проблемы, и никто, кажется, еще не предложил решение. Вот что я придумала:
Проблема. Учетные записи электронной почты Outlook типа IMAP не загружают свои текстовые сообщения и вложения при первом поступлении. Эксперты Outlook повсюду скажут вам, что вы можете изменить это в расширенных настройках Outlook, но они ошибаются, что не будут иметь никакого эффекта.
Решение 1. Переключитесь на POP3. С точки зрения программирования это решает проблему, но я считаю, что если вы не можете сделать это с IMAP, то вы делаете это неправильно, верно?
Решение 2. Обратите внимание, что это грубая сила, но она выполняет свою работу.
В 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
В отдельном модуле:
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
Примечание. Я стал пользователем StackExchange, чтобы поделиться с вами этими результатами. Мне нравится, пожалуйста, иди сюда и свяжи другие беспокойные души с подобными проблемами здесь :).
