2017-02-23 34 views
1

我有這段代碼可以保存我的Outlook中選定項目(郵件)的附件。Outlook掃描特定文件夾並保存電子郵件中的所有附件

我想設置特定的文件夾(定義它),Outlook將自動掃描該文件夾中的所有電子郵件並保存附件。

任何想法應該如何擴展這段代碼才能以這種方式工作?

Public Sub SaveAttachments() 

Dim objOL As Outlook.Application 
Dim objMsg As Outlook.MailItem 
Dim objAttachments As Outlook.Attachments 
Dim objItems As Outlook.Items 
Dim objSelection As Outlook.Selection 
Dim i As Long 
Dim lngCount As Long 
Dim strFile As String 
Dim strFolderpath As String 
Dim strDeletedFiles As String 

strFolderpath = "C:\Users\gpyko\Desktop\Pentaho project\HDPS RAPORTY" 
Set objOL = CreateObject("Outlook.Application") 
Set objSelection = objOL.ActiveExplorer.Selection 
strFolderpath = strFolderpath & "\Attachments\" 

For Each objMsg In objSelection 

    Set objAttachments = objMsg.Attachments 
    lngCount = objAttachments.Count 
    strDeletedFiles = "" 

    If lngCount > 0 Then 

    For i = lngCount To 1 Step -1 

     strFile = objAttachments.Item(i).FileName 
     strFile = strFolderpath & strFile 
     objAttachments.Item(i).SaveAsFile strFile 
     objAttachments.Item(i).Delete 

     If objMsg.BodyFormat <> olFormatHTML Then 

      strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">" 
     Else 
      strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _ 
      strFile & "'>" & strFile & "</a>" 
     End If 

    Next i 

     If objMsg.BodyFormat <> olFormatHTML Then 

      objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body 
     Else 
      objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody 
     End If 
     objMsg.Save 

    End If 

Next 

ExitSub: 
Set objAttachments = Nothing 
Set objMsg = Nothing 
Set objSelection = Nothing 
Set objOL = Nothing 
End Sub 
+0

你從哪裏運行代碼? Excel或Outlook? – 0m3r

+0

從現在的Outlook,但可能我會從Excel結合其他VBA腳本運行它 –

回答

2

Dim SubFolder As Outlook.MAPIFolder替換您objSelection然後使用 For Each objMsg In SubFolder.Items

你也不必創建Outlook對象,如果您從Outlook CreateObject("Outlook.Application")運行代碼

確保更新您的文件夾名稱

Set SubFolder = olNs.GetDefaultFolder(olFolderInbox).Folders("Folder Name")

Option Explicit 
Public Sub SaveAttachments() 
    Dim olNs As Outlook.NameSpace 
    Dim objMsg As Outlook.MailItem 
    Dim objAttachments As Outlook.Attachments 
    Dim objItems As Outlook.Items 
    Dim SubFolder As Outlook.MAPIFolder 
    Dim i As Long 
    Dim lngCount As Long 
    Dim strFile As String 
    Dim strFolderpath As String 
    Dim strDeletedFiles As String 

    strFolderpath = "C:\Users\gpyko\Desktop\Pentaho project\HDPS RAPORTY" 

    Set olNs = Application.GetNamespace("MAPI") 

    Set SubFolder = olNs.GetDefaultFolder(olFolderInbox).Folders("Folder Name") 

    strFolderpath = strFolderpath & "\Attachments\" 


    For Each objMsg In SubFolder.Items 
     Set objAttachments = objMsg.Attachments 
     lngCount = objAttachments.Count 
     strDeletedFiles = "" 

     If lngCount > 0 Then 

      For i = lngCount To 1 Step -1 

      strFile = objAttachments.Item(i).FileName 
      strFile = strFolderpath & strFile 
      objAttachments.Item(i).SaveAsFile strFile 
      objAttachments.Item(i).Delete 

      If objMsg.BodyFormat <> olFormatHTML Then 

       strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">" 
      Else 
       strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _ 
       strFile & "'>" & strFile & "</a>" 
      End If 

      Next i 

      If objMsg.BodyFormat <> olFormatHTML Then 

       objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body 
      Else 
       objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody 
      End If 

      objMsg.Save 

     End If 
    Next 


ExitSub: 
    Set objAttachments = Nothing 
    Set objMsg = Nothing 
    Set SubFolder = Nothing 
    Set olNs = Nothing 
End Sub 

從Excel運行它。

Option Explicit 
Public Sub SaveAttachments() 
    Dim App As Outlook.Application 
    Dim olNs As Outlook.Namespace 
    Dim objMsg As Outlook.MailItem 
    Dim objAttachments As Outlook.Attachments 
    Dim objItems As Outlook.Items 
    Dim SubFolder As Outlook.MAPIFolder 
    Dim i As Long 
    Dim lngCount As Long 
    Dim strFile As String 
    Dim strFolderpath As String 
    Dim strDeletedFiles As String 

    strFolderpath = "C:\Users\gpyko\Desktop\Pentaho project\HDPS RAPORTY" 
    Set App = New Outlook.Application 
    Set olNs = App.GetNamespace("MAPI") 

    Set SubFolder = olNs.GetDefaultFolder(olFolderInbox).Folders("Folder Name") 

    strFolderpath = strFolderpath & "\Attachments\" 


    For Each objMsg In SubFolder.Items 
     Set objAttachments = objMsg.Attachments 
     lngCount = objAttachments.Count 
     strDeletedFiles = "" 

     If lngCount > 0 Then 

      For i = lngCount To 1 Step -1 

      strFile = objAttachments.Item(i).Filename 
      strFile = strFolderpath & strFile 
      objAttachments.Item(i).SaveAsFile strFile 
      objAttachments.Item(i).Delete 

      If objMsg.BodyFormat <> olFormatHTML Then 

       strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">" 
      Else 
       strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _ 
       strFile & "'>" & strFile & "</a>" 
      End If 

      Next i 

      If objMsg.BodyFormat <> olFormatHTML Then 

       objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body 
      Else 
       objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody 
      End If 

      objMsg.Save 

     End If 
    Next 

ExitSub: 
    Set objAttachments = Nothing 
    Set objMsg = Nothing 
    Set SubFolder = Nothing 
    Set olNs = Nothing 
End Sub 
+0

謝謝!非常感謝。然而,我仍然面臨一個錯誤: 'Set SubFolder = olNs.GetDefaultFolder(olFolderInbox).Folders(「ARIES」)' 「無法找到對象」。文件夾名稱正確。也許我想念什麼? –

+0

@GrzegorzPyko無法找到對象意味着無法找到您的文件夾名稱。 – 0m3r

+0

是的,但我敢肯定,文件夾名稱是正確的,我有一個這樣命名 –

相關問題