Outlook VBA Save Attachment保存错误附件

Question

我已经为此挣扎了相当一段时间了，我不明白我做错了什么。

我有一个脚本，将循环在一个文件夹中的电子邮件。然后它检查邮件主题的前6个字符。如果它匹配，它必须调用一个子，将附件保存到一个特定的文件夹，唯一的事情是，文件名每次更改取决于电子邮件的主题。如果文件夹中只有1封电子邮件，一切都可以正常工作，但一旦有超过1封电子邮件，它每次都会保存最后一封电子邮件附件，但文件名正确。所以，例如，如果你看下面的代码，它会保存附件从ElseIf strLeft = "APPPE2" Then每次指定的文件名，如report1.txt…非常感谢你的帮助。

Function LoopThroughFolder()
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders.GetFirst ' folders of your current account
Set objFolder = objFolder.Folders("Inbox").Folders("PPB")
For Each Item In objFolder.Items
    If TypeName(Item) = "MailItem" Then
        ' ... do stuff here ...
        Set Msg = Item
        Dim strSubject As String
        strSubject = Item.Subject
        Dim strLeft As String
        strLeft = Left(strSubject, 6)
        If strLeft = "APP DA" Then
            Call SaveAttachments1
        ElseIf strLeft = "APPGR1" Then
            Call SaveAttachments2
        ElseIf strLeft = "APPPE2" Then
            Call SaveAttachments3
        End If
    End If
Next
End Function
Public Sub SaveAttachments1()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile1 As String
Dim strFolderpath As String
Dim strDeletedFiles As String
    Set objOL = CreateObject("Outlook.Application")
    Set objSelection = objOL.ActiveExplorer.Selection
    strFolderpath = "P:database"
    For Each objMsg In objSelection
    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
    If lngCount > 0 Then
    For i = lngCount To 1 Step -1
    strFile1 = "report.txt"
    MsgBox (strFile1)

    strFile1 = strFolderpath & strFile1
    MsgBox (strFile1)
    objAttachments.Item(i).SaveAsFile strFile1
    Next i
    End If
    Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
Public Sub SaveAttachments2()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile2 As String
Dim strFolderpath As String
Dim strDeletedFiles As String
    On Error Resume Next
    Set objOL = CreateObject("Outlook.Application")
    Set objSelection = objOL.ActiveExplorer.Selection
    strFolderpath = "P:database"
    For Each objMsg In objSelection
    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
    If lngCount > 0 Then
    For i = lngCount To 1 Step -1
    strFile2 = "report2.txt"
    MsgBox (strFile2)
    strFile2 = strFolderpath & strFile2
    MsgBox (strFile2)
    objAttachments.Item(i).SaveAsFile strFile2
    Next i
    End If
    Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
Public Sub SaveAttachments3()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile3 As String
Dim strFolderpath As String
Dim strDeletedFiles As String
    On Error Resume Next
    Set objOL = CreateObject("Outlook.Application")
    Set objSelection = objOL.ActiveExplorer.Selection
    strFolderpath = "P:database"
    For Each objMsg In objSelection
    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
    If lngCount > 0 Then       
    For i = lngCount To 1 Step -1
    strFile3 = "report3.txt"
    strFile3 = strFolderpath & strFile3
    objAttachments.Item(i).SaveAsFile strFile3
    Next i
    End If
    Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

Answer 1

每个SaveAttachments子节点都应该有一个objMsg参数，该参数应该从LoopThroughFolder传递-没有必要"重新找到"消息只是为了保存附件。

未经测试，但像这样:

Function LoopThroughFolder()
    Dim objNS As Outlook.NameSpace, Item, Msg As Outlook.MailItem
    Dim objFolder As Outlook.MAPIFolder
    Set objNS = GetNamespace("MAPI")
    Set objFolder = objNS.Folders.GetFirst ' folders of your current account
    Set objFolder = objFolder.Folders("Inbox").Folders("PPB")
    For Each Item In objFolder.Items
        If TypeName(Item) = "MailItem" Then
            ' ... do stuff here ...
            Set Msg = Item
            Dim strSubject As String
            strSubject = Msg.Subject
            Dim strLeft As String
            strLeft = Left(strSubject, 6)
            If strLeft = "APP DA" Then
                SaveAttachments1 Msg
            ElseIf strLeft = "APPGR1" Then
                SaveAttachments2 Msg
            ElseIf strLeft = "APPPE2" Then
                SaveAttachments3 Msg
            End If
        End If
    Next
End Function
Public Sub SaveAttachments1(objMsg As Outlook.MailItem)
    Dim objAttachments As Outlook.Attachments
    Dim i As Long
    Dim lngCount As Long
    Dim strFolderpath As String
    strFolderpath = "P:database"
    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
    If lngCount > 0 Then
    For i = lngCount To 1 Step -1
        objAttachments.Item(i).SaveAsFile strFolderpath & "report.txt"
    Next i
    End If
End Sub