Question

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

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

上

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

我希望这有帮助！

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

1 个答案: