Question

在Outlook中使用VBA我正在尝试将附件从电子邮件复制到网络上的特定位置（Z :)。我已经看过各种各样的脚本，但是绊倒我的是文件结构。它如下：

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文件夹。

因此，Outlook中\My Folder\Employer 1\Project 2\Organizational Folder\的附件基本上需要复制到Z:\Employer 1\Project 2\Organizational Folder\

我假设我必须以某种方式使用嵌套的if循环来挖掘每个文件夹结构以复制附件。

我试图尽可能具体，我对基本的编程概念有些熟悉，但我对VBA和Microsoft宏一般都是新手，所以如果有人可以提供一些代码片段甚至只是一些为我阅读那将是非常棒的！

Answer 1

我并非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

使用VBA从Outlook中的多个嵌套文件夹中提取附件

1 个答案: