在Outlook中使用VBA從多個嵌套文件夾中提取附件

在Outlook中使用VBA我試圖將附件從電子郵件複製到網絡上的特定位置（Z :)。我已經看到了各種各樣的腳本，但是絆倒我的是文件結構。這是因爲如下：在Outlook中使用VBA從多個嵌套文件夾中提取附件

Inbox 
Drafts 
Outbox 
My Folder 
    Employer Name 
    Project Name 
     Organizational Folder 
     Organizational Folder 
    Project Name 
     Organizational Folder 
     Organizational Folder 
    Employer Name 
    Project Name 
     Organizational Folder 
     Organizational Folder

沒有郵件將要存儲在工作單位或項目的文件夾，裏面只有組織文件夾（這是一些類似招聘信息，認證等）。

我已經創建了另一個腳本，可以在Outlook和網絡中自動創建這些文件夾，因此這些文件夾將始終存在，但可以有任意數量的Employer文件夾以及任意數量的Project文件夾。

從\My Folder\Employer 1\Project 2\Organizational Folder\所以基本上附件在Outlook需要被複制到Z:\Employer 1\Project 2\Organizational Folder\

我假設我將不得不使用嵌套的循環，如果不知何故，以深入到每一個文件夾結構複製的附件。

我試過儘可能具體，我對基本的編程概念有些熟悉，但是我是全新的VBA和微軟宏，所以如果任何人都可以提供一些代碼片段，甚至只是一些閱讀對我來說會很棒！

來源

2016-04-23 Aidan Vanleuven

看一看這個答案：如何複製Outlook郵件消息到Excel中使用VBA或宏（http://stackoverflow.com/a/12146315/973283）。大部分答案都是關於顯示哪些電子郵件看起來像VBA，這與您當前的問題無關。底部是一對遞歸例程，它們將在層次結構中的任何位置搜索文件夾。您需要在「\ My Folder」之前放置PST文件名。 –

以前的評論引用的答案鏈接到早期的答案，該答案提供了Outlook對象模型上的OTT教程。你可能會覺得很有幫助 –

我不是100％確定我已經掌握了你想要做的事情，但我認爲這樣做會有效。注意 - 只有當您的文件夾結構深度不超過3級時纔可以使用，如果您需要添加額外的級別。您也可以考慮使用遞歸子來搜索文件夾。 這是未經測試的sudocode，但它至少應該是您需要的90％。

Sub SaveOutlookAttachments() 

Dim Ol As New Outlook.Application 
Dim Tf As Outlook.Folder, Sf1 As Outlook.Folder, Sf2 As Outlook.Folder, Sf3 As Outlook.Folder 

'Bind Fl to your top folder 
Set Tf = Ol.Session.GetDefaultFolder(olFolderInbox).Folders("My Folder") 
'Loop through each subfolder 
For Each Sf1 In Tf.Folders 
    For Each Sf2 In Sf1.Folders 
     For Each Sf3 In Sf2.Folders 
      'Loop through items in Sf3 
      Call SaveAtt(Sf3, Tf.Name & "\" & Sf1.Name & "\" & Sf2.Name & "\" & Sf3.Name & "\") 
     Next 
     'Loop through items in Sf2 
     Call SaveAtt(Sf2, Tf.Name & "\" & Sf1.Name & "\" & Sf2.Name & "\") 
    Next 
    'Loop through items in Sf1 
    Call SaveAtt(Sf1, Tf.Name & "\" & Sf1.Name & "\") 
Next 

'Quit outlook 
Ol.Quit 
Set Ol = Nothing 

End Sub 

Sub SaveAtt(OlFolder As Outlook.Folder, SaveFolder As String) 

'***Alter this*** 
Const MainFolder = "\\Server\Folder1\Folder2\" 
'**************** 
Dim Mi As Outlook.MailItem 
Dim Att As Outlook.Attachment 
Dim FSO As New FileSystemObject 

'Loop through items within the folder passed to the sub 
For Each Mi In OlFolder.Items 
    'Check for an attachment 
    If Mi.Attachments.Count > 1 Then 
     'Check if the folder exists 
     If FSO.FolderExists(MainFolder & SaveFolder) = False Then FSO.CreateFolder (MainFolder & SaveFolder) 
     'Save the attachments 
     For Each Att In Mi.Attachments 
      Att.SaveAsFile (MainFolder & SaveFolder & Att.Filename) 
     Next 
    End If 
Next 
Set FSO = Nothing 

End Sub

來源

2016-04-23 08:07:01

輝煌。花了一些光修改，以適應我的需求，但最終工作恰到好處！謝謝！ –

在Outlook中使用VBA從多個嵌套文件夾中提取附件

回答

相關問題