展望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