将附件保存到 Outlook 中的文件夹并重命名它们

Question

我正在尝试将 Outlook 附件保存到一个文件夹，并且文件名已经存在的位置以不同的名称保存较新的文件，以免覆盖现有文件....也许只是给出扩展名“v2”甚至如果存在“v2”，则为“v3”。

我遇到了这个答案，但发现新文件保存在现有文件之上

Save attachments to a folder and rename them

我使用了下面的代码；

Dim objAttachments As Outlook.Attachments
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



' Get the path to your My Documents folder
strFolderpath = "C:\Users\Owner\my folder is here"
On Error Resume Next

' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")

' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection

' Set the Attachment folder.
strFolderpath = strFolderpath & "\my subfolder is here\"

' Check each selected item for attachments. If attachments exist,
' save them to the strFolderPath folder and strip them from the item.
For Each objMsg In objSelection

' This code only strips attachments from mail items.
' If objMsg.class=olMail Then
' Get the Attachments collection of the item.
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
strDeletedFiles = ""

If lngCount > 0 Then

    ' We need to use a count down loop for removing items
    ' from a collection. Otherwise, the loop counter gets
    ' confused and only every other item is removed.

    For i = lngCount To 1 Step -1

        ' Save attachment before deleting from item.
        ' Get the file name.
        strFile = objAttachments.Item(i).FileName

        ' Combine with the path to the Temp folder.
        strFile = strFolderpath & strFile

        ' Save the attachment as a file.
        objAttachments.Item(i).SaveAsFile strFile


        ' Delete the attachment.
        objAttachments.Item(i).Delete

        'write the save as path to a string to add to the message
        'check for html and use html tags in link
        If objMsg.BodyFormat <> olFormatHTML Then
            strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
        Else
            strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
            strFile & "'>" & strFile & "</a>"
        End If

        'Use the MsgBox command to troubleshoot. Remove it from the final code.
        'MsgBox strDeletedFiles

    Next i

    ' Adds the filename string to the message body and save it
    ' Check for HTML body
    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

我对 vba 比较陌生，所以也许有解决方案，但我没有看到它！

Answer 1

看看我下面的代码。它遍历特定​​ Outlook 文件夹（您指定）中的所有项目，遍历每个项目中的每个附件，并将附件保存在指定的文件路径中。

'Establish path of folder you want to save to

Dim FilePath As Variant

FilePath = "C:\Users\Owner\my folder is here\my subfolder is here\"

    Set FSOobj = CreateObject("Scripting.FilesystemObject")

    'If path doesn't exist, create it. If it does, either do nothing or delete its contents
    If FSOobj.FolderExists(FilePath) = False Then
        FSOobj.CreateFolder FilePath
    Else
        ' This code is if you want to delete the items in the existing folder first. 
        ' It's not necessary for your case.
        On Error Resume Next
        Kill FilePath & "*.*"
        On Error GoTo 0
    End If

'Establish Outlook folders, attachments, and other items

Dim msOutlook As Outlook.NameSpace 'Establish Outlook NameSpace
Dim Folder As Outlook.MAPIFolder 'Establish Folder as a MAPIFolder
Dim messageAttachments As Outlook.Attachments

Set msOutlook = Application.GetNamespace("MAPI")

'Set the folder that contains the email with the attachment
Set Folder = msOutlook.GetDefaultFolder(olFolderInbox).Folders("FOLDER NAME HERE")

Set folderItems = Folder.Items

Dim folderItemsCount As Long
folderItemsCount = folderItems.Count

Dim number as Integer
number = 1

For i = 1 To folderItemsCount
    'If you want to pull the attachments on some criteria, like the Subject of the email or 
    'the date received, you need to write an IF statement like:
    'If InStr(Folder.Items(i).Subject, "SPECIFIC SUBJECT TEXT") Then

    Set messageAttachments = folderItems.item(i).Attachments
    lngCount = messageAttachments.Count 'This lets you pull more than one attachment per message
    For thisAttachment = 1 To lngCount
        messageAttachments.item(thisAttachment).SaveAsFile FilePath & "YOUR_CHOSEN_FILENAME" & number & ".xlsx"
        number = number + 1
    Next thisAttachment
Next i

---

编辑

为了在抓取附件后删除项目，您可以使用与上述相同的代码，但您还需要包含 folderItems.item(i).Delete。此外，由于您正在移动项目，因此我切换到在您的 for 循环中向后循环，以免弄乱您的迭代。我写在下面：

For i = folderItemsCount To 1 Step -1
    'If you want to pull the attachments on some criteria, like the Subject of the email or 
    'the date received, you need to write an IF statement like:
    'If InStr(Folder.Items(i).Subject, "SPECIFIC SUBJECT TEXT") Then

    Set messageAttachments = folderItems.item(i).Attachments
    lngCount = messageAttachments.Count 'This lets you pull more than one attachment per message
    For thisAttachment = 1 To lngCount
        messageAttachments.item(thisAttachment).SaveAsFile FilePath & "YOUR_CHOSEN_FILENAME" & number & ".xlsx"
        number = number + 1
    Next thisAttachment
    folderItems.item(i).Delete
Next i

我希望这会有所帮助！