logo标签列表

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

vbaoutlookattachment
45

我正在尝试在Outlook中编写一个VBA宏，可以将电子邮件附件保存到特定文件夹，并将收件日期添加到文件名中。

我的搜索已经让我走了这么远：

Public Sub saveAttachtoDisk (itm As Outlook.MailItem) 
    Dim objAtt As Outlook.Attachment 
    Dim saveFolder As String
    Dim dateFormat As String
    saveFolder = "C:\Temp\"
    dateFormat = Format(Now, "yyyy-mm-dd H-mm")

    For Each objAtt In itm.Attachments
        objAtt.SaveAsFile saveFolder & "\" & dateFormat & objAtt.DisplayName
        Set objAtt = Nothing
    Next 
End Sub

显而易见的第一个问题是它将当前时间应用于文件名，而不是接收时间，但我似乎无法更改它。我的理论是Outlook.Attachment没有 ReceivedTime ，必须引用电子邮件本身。

其次，这根本不起作用，哈！我刚开始尝试时可以正常工作，但之后它就停止保存文件了。

6个回答
48

这是我的保存附件脚本。您选择想要从中保存附件的所有邮件，它将在那里保存一份副本。它还向邮件正文添加文本，指示附件保存的位置。您可以轻松更改文件夹名称以包含日期，但需要确保在开始保存文件之前存在该文件夹。

Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
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 = CreateObject("WScript.Shell").SpecialFolders(16)
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 & "\Attachments\"

' 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
2
谢谢！唯一需要的是它能够处理重复文件——如果一个文件已经存在于目标目录中，它将被覆盖。除了我熟悉的 System File Object 之外，是否有“WScript.Shell”命令或其他有效的方法可以轻松确定文件是否已经存在于目标目录中，并使其名称唯一？ - Jakub Sisak GeoGraphics
9
警告：即使“SaveAsFile”操作失败，程序仍将继续执行并删除您所有的附件。请注意。 - Navin
@Navin 有没有办法计算目录中的文件数量？这样你就可以在删除附件之前查看它们是否与附件数量匹配了吗？ - BLang
希望有人能回答。如何修改原始代码以处理收件箱中的电子邮件。宏是有效的，但必须手动完成，我希望在电子邮件到达我的“测试”文件夹时自动完成？ - Kalenji
7

查看ReceivedTime属性

http://msdn.microsoft.com/en-us/library/office/aa171873(v=office.11).aspx

在SaveAs File行中，你在C:\Temp\的结尾加了另一个\。这可能会导致问题。在添加路径分隔符之前先进行测试。

dateFormat = Format(itm.ReceivedTime, "yyyy-mm-dd H-mm")  
saveFolder = "C:\Temp"

您没有设置objAtt，所以不需要 "Set objAtt = Nothing"。如果有的话，应该放在循环结束前的End Sub之前，而不是在循环中。
Public Sub saveAttachtoDisk (itm As Outlook.MailItem) 
    Dim objAtt As Outlook.Attachment 
    Dim saveFolder As String Dim dateFormat
    dateFormat = Format(itm.ReceivedTime, "yyyy-mm-dd H-mm")  saveFolder = "C:\Temp"
    For Each objAtt In itm.Attachments
        objAtt.SaveAsFile saveFolder & "\" & dateFormat & objAtt.DisplayName
    Next
End Sub

关于“开始尝试时它可以工作，但之后就无法保存文件”的问题：

通常是由于安全设置引起的。这是为了让第一次使用者允许宏而设置的"陷阱"，然后再取消掉。请参考http://www.slipstick.com/outlook-developer/how-to-use-outlooks-vba-editor/

4
Public Sub Extract_Outlook_Email_Attachments()

Dim OutlookOpened As Boolean
Dim outApp As Outlook.Application
Dim outNs As Outlook.Namespace
Dim outFolder As Outlook.MAPIFolder
Dim outAttachment As Outlook.Attachment
Dim outItem As Object
Dim saveFolder As String
Dim outMailItem As Outlook.MailItem
Dim inputDate As String, subjectFilter As String


saveFolder = "Y:\Wingman" ' THIS IS WHERE YOU WANT TO SAVE THE ATTACHMENT TO

If Right(saveFolder, 1) <> "\" Then saveFolder = saveFolder & "\"

subjectFilter = ("Daily Operations Custom All Req Statuses Report") ' THIS IS WHERE YOU PLACE THE EMAIL SUBJECT FOR THE CODE TO FIND

OutlookOpened = False
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
    Set outApp = New Outlook.Application
    OutlookOpened = True
End If
On Error GoTo 0

If outApp Is Nothing Then
    MsgBox "Cannot start Outlook.", vbExclamation
    Exit Sub
End If

Set outNs = outApp.GetNamespace("MAPI")
Set outFolder = outNs.GetDefaultFolder(olFolderInbox)

If Not outFolder Is Nothing Then
    For Each outItem In outFolder.Items
        If outItem.Class = Outlook.OlObjectClass.olMail Then
            Set outMailItem = outItem
                If InStr(1, outMailItem.Subject, subjectFilter) > 0 Then 'removed the quotes around subjectFilter
                    For Each outAttachment In outMailItem.Attachments
                    outAttachment.SaveAsFile saveFolder & outAttachment.filename

                    Set outAttachment = Nothing

                    Next
                End If
        End If
    Next
End If

If OutlookOpened Then outApp.Quit

Set outApp = Nothing

End Sub
2
我其实在发布后不久就解决了这个问题，但没有发布我的解决方案。我真的不记得了。但是，当我接到一个面临同样挑战的新项目时，我不得不重新访问这个任务。
我使用了Outlook.MailItem的ReceivedTime属性来获取时间戳，我能够将其用作每个文件的唯一标识符，以便它们不会互相覆盖。
Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
        saveFolder = "C:\PathToDirectory\"
    Dim dateFormat As String
        dateFormat = Format(itm.ReceivedTime, "yyyy-mm-dd Hmm ")
    For Each objAtt In itm.Attachments
        objAtt.SaveAsFile saveFolder & "\" & dateFormat & objAtt.DisplayName
    Next
End Sub

非常感谢您提供的其他解决方案，其中很多超出了预期 :)

这让我省了很多时间，因为我不需要再尝试创建带有(1)、(2)等的文件名了。使用日期时间简单得多。 - Fandango68
2

添加了简单的代码以保存带有可读日期时间戳的内容。

使用sync2pst将Outlook中的所有数据与所有设备同步，操作如下：

  1. 您只需要购买1个许可证：在您网络上的一台计算机上保存您的pst文件（我们将其称为pc“服务器”）。
  2. 创建定期任务，将“服务器”上的pst文件与所有设备上的pst文件同步，无论哪个设备先下载电子邮件（您需要一些dos编程知识来绕过同步时打开的pst文件）。
  3. 将所有附件保存在相同的skydrive文件夹中，该文件夹位于所有设备上的相同位置（例如e：\ skydrive \ attachments）
  4. 在所有设备上使用以下代码保存附件（根据上述说明更改路径）

  5. 对于所有帐户，请仅使用一个PST文件，创建文件夹，子文件夹等...

  6. 在VBA中：引用'Microsoft Scripting Runtime'extra / references ...'

  7. 以下是代码

Private Sub Application_NewMail()
SaveAttachments
End Sub

Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
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
Dim fs As FileSystemObject

' Get the path to your My Documents folder
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
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 = "F:\SkyDrive\Attachments\"

' 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.
        Set fs = New FileSystemObject

        For i = lngCount To 1 Step -1

            ' Save attachment before deleting from item.
            ' Get the file name.
            strFile = Left(objAttachments.Item(i).FileName, Len(objAttachments.Item(i).FileName) - 4) + "_" + Right("00" + Trim(Str$(Day(Now))), 2) + "_" + Right("00" + Trim(Str$(Month(Now))), 2) + "_" + Right("0000" + Trim(Str$(Year(Now))), 4) + "_" + Right("00" + Trim(Str$(Hour(Now))), 2) + "_" + Right("00" + Trim(Str$(Minute(Now))), 2) + "_" + Right("00" + Trim(Str$(Second(Now))), 2) + Right((objAttachments.Item(i).FileName), 4)

            ' 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

1
你有两个任务需要完成。首先是将电子邮件附件提取到文件夹中，并使用特定名称保存或重命名。如果你的搜索可以分为两个搜索，你会得到更多的结果。我可以引用一个页面，解释如何将附件保存到系统文件夹中（保存附件到文件夹的链接）。请发布任何已找到的页面或代码，以便保存具有特定名称的附件。
在我的上面的代码中，我调用了.SaveAsFile方法，该方法需要目标文件的完整路径。您可以更改此代码以指定文件名。 - Stuart
网页内容由stack overflow 提供, 点击上面的
可以查看英文原文，
原文链接