获取一封包含两个附件的电子邮件，并将每个附件保存到不同的文件夹中

Question

我定期在一封电子邮件中收到两份 excel 文档。我设置了一个规则，可以将附加文档保存到一个文件夹中。对于我最终想要自动化的内容，我需要将文档保存到不同的文件夹中。到目前为止，我可以编辑两个文档的名称，但是每当我尝试进行某种比较时，一个文件名进入文件夹 x，另一个进入文件夹 y，要么我将两个文件都放在文件夹 x 中，只有一个出现曾经，或者他们都被遗忘了。

这是我目前的情况：

Public Sub saveAttachtoDiskRule(itm As Outlook.MailItem)

Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim fso As Object
Dim oldName

Dim file As String
Dim DateFormat As String
Dim newName As String

Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))
saveFolder = enviro & "\Desktop\SWR\"

Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next

 For Each objAtt In itm.Attachments


    '~> These two lines are where I run into trouble. 
    '~> Trying to change where I save the file. Only one at a time ever works.
    If InStr(objAtt.DisplayName, "Team") <> 0 Then saveFolder = saveFolder & "Productivity\"
    If InStr(objAtt.DisplayName, "Overdue") <> 0 Then saveFolder = saveFolder & "Overdue\"


    file = saveFolder & objAtt.DisplayName
    objAtt.SaveAsFile file

    Set oldName = fso.GetFile(file)

    '~> edits date to my specifications, works great
    DateFormat = Format(DateAdd("d", -3, oldName.DateLastModified), "mm-dd-yyyy ")
    '~> combines old name with date. Works great
    newName = DateFormat & objAtt.DisplayName

    oldName.Name = newName

    Set objAtt = Nothing
Next

    Set fso = Nothing
End Sub

Answer 1

只需使用 if 和 Else 命令，我还添加了新的 Dim SavePath As String 这样代码就不会混淆附件的保存位置。

查看完整代码。

Option Explicit
Public Sub saveAttachtoDiskRule(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Dim SaveFolder As String
    Dim SavePath As String
    Dim FSO As Object
    Dim oldName
    Dim file As String
    Dim DateFormat As String
    Dim newName As String
    Dim enviro As String

    enviro = CStr(Environ("USERPROFILE"))
    SaveFolder = enviro & "\Desktop\SWR\"

    Set FSO = CreateObject("Scripting.FileSystemObject")
'    On Error Resume Next

    For Each objAtt In itm.Attachments

        '~> These two lines are where I run into trouble.
        '~> Trying to change where I save the file. Only one at a time ever works.
'       If InStr(objAtt.DisplayName, "Team") <> 0 Then SaveFolder = SaveFolder & "Productivity\"
'       If InStr(objAtt.DisplayName, "Overdue") <> 0 Then SaveFolder = SaveFolder & "Overdue\"

        If InStr(objAtt.DisplayName, "Team.xlsx") Then
            SavePath = SaveFolder & "Productivity\"
        Else
            If InStr(objAtt.DisplayName, "Overdue.xlsx") Then
                SavePath = SaveFolder & "Overdue\"
            End If
        End If

        file = SavePath & objAtt.DisplayName

        objAtt.SaveAsFile file

        Set oldName = FSO.GetFile(file)

        '~> edits date to my specifications, works great
        DateFormat = Format(DateAdd("d", -3, oldName.DateLastModified), "mm-dd-yyyy ")
        '~> combines old name with date. Works great
        newName = DateFormat & objAtt.DisplayName

        oldName.Name = newName

    Next

    Set objAtt = Nothing
    Set FSO = Nothing
End Sub

获取一封包含两个附件的电子邮件，并将每个附件保存到不同的文件夹中

Take one email with two attachments and save each attachment into a different folder

vba

outlook

outlook-2010