Outlook VBA Speichern Anhang speichert falschen Anhang

Question

Ich habe seit einiger Zeit damit zu kämpfen, ich verstehe nicht, was ich falsch mache.

Ich habe ein Skript, das E-Mails in einem Ordner durchläuft. Dann überprüft es die ersten 6 Zeichen des Betreffs der E-Mail. Wenn es übereinstimmt, muss ein Sub aufgerufen werden, das den Anhang in einem bestimmten Ordner speichert. Der einzige Unterschied besteht darin, dass sich der Dateiname jedes Mal ändert, abhängig vom Betreff der E-Mail. Alles funktioniert gut, wenn nur eine E-Mail im Ordner vorhanden ist. Sobald jedoch mehr als eine E-Mail vorhanden ist, wird der letzte E-Mail-Anhang immer mit dem korrekten Dateinamen gespeichert. Wenn Sie sich zum Beispiel den darunter liegenden Code ansehen, wird der Anhang von ElseIf strLeft = "APPPE2" Then jedesmal mit den angegebenen Dateinamen gespeichert, zB report1.txt ... Hilfe wird sehr geschätzt.

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

Jeder Ihrer SaveAttachments U-Boote sollten einen objMsg Parameter haben, die von LoopThroughFolder weitergegeben werden sollte - es gibt keine Notwendigkeit, „wieder finden“ die Nachricht nur die Anhänge zu speichern.

Ungeprüfte aber so etwas wie dies:

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