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传递 - 没有必要重新找到＆＃34;消息只是为了保存附件。

未经测试但是这样：

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

Outlook VBA保存附件正在保存错误的附件

1 个答案: