☰

Outlook - 奇怪的项目。附件错误

tag-icon • tag-icon email microsoft-outlook microsoft-outlook-2010 vba
Outlook - 奇怪的项目。附件错误

我有以下代码，用于保存电子邮件中附加的特定 Excel 文件。该代码与规则相结合，当收到具有特定主题的电子邮件时会触发此脚本。代码已触发，但出现了我最近看到的最奇怪的错误：itm.Attachments.Count 似乎为零，显然文件未保存！但是...如果我在“For each...”行上设置断点并将 itm.Attachments.Count 添加到监视窗口，它会显示为零。如果我仅添加 itm，然后浏览到 Attachments 属性，然后到 Count 属性，它会显示 1 的 Count（正如它应该的那样），并且代码执行正常。我花了半天时间试图了解发生了什么，但我无法弄清楚。

在 Windows 7 x64 上的 Outlook 2010 x64 和 Windows 7 x86 上的 Outlook 2010 x86 上的行为相同。在信任中心启用了宏。我附上了一些带有代码和规则设置的屏幕截图，以及一段显示监视窗口奇怪现象的电影。

该脚本是前段时间编写的，在几台电脑上运行良好，并且基于此处的步骤：iterrors.com/outlook-automatically-save-an-outlook-attachment-to-disk/。有什么想法吗？

阿德里安

规则屏幕在此处：https://drive.google.com/file/d/0Bw-aVIPSg4hsRFgxdzFtd3l1SkE/view?usp=sharing

1分钟影片请点击此处：https://drive.google.com/file/d/0Bw-aVIPSg4hsZERQWUJHLXd4bjA/view?usp=sharing

Public Sub Kona(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
    saveFolder = "C:\test"
    For Each objAtt In itm.Attachments
        If InStr(objAtt.DisplayName, "Kona Preferred Fixed Price Matrix (ALL)") Then
            objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
        End If
        Set objAtt = Nothing
    Next
End Sub

答案1

我在网上搜索了这个问题的解决方案，但似乎还没有人提出解决方案。以下是我的想法：

问题：IMAP 类型的 Outlook 电子邮件帐户在首次收到邮件时不会下载正文和附件。各地的 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("[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

在单独的模块中：

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 用户只是为了与您分享这些发现。如果您喜欢它，请继续并将其他遇到类似问题的困扰灵魂链接到这里 :)。

相关内容