展望VBA保存附件保存错误的附件

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