首页 文章

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

提问于
浏览
37

我正在尝试在 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 回答

  • 35

    这是我的“保存附件”脚本。您选择要从中保存附件的所有邮件,它将在其中保存一个副本。它还会将文本添加到邮件正文中,指示附件的保存位置。您可以轻松地更改文件夹名称以包括日期,但是在开始保存文件之前,需要确保该文件夹存在。

    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
    
  • 5

    参见ReceivedTime属性

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

    您在“另存为文件”行的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/

  • 3
    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
                        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

    添加了简单的代码以可读的 date-time 标记保存。

    使用sync2pst可以将 Outlook 中的所有数据与所有设备同步,如下所示:

    • 您只需要购买 1 个许可证:将 pst 文件保存在网络上的一台计算机上(我们将此 PC 称为“服务器”)。

    • 创建计划的任务,以使“服务器”上的 pst 文件与所有设备上的所有 pst 文件同步,无论哪个设备首先下载了电子邮件(您都需要具备一定的 dos 编程知识,才能绕过在同步时打开的 pst 文件) 。

    • 将所有附件保存在所有设备上相同位置的同一 skydrive 文件夹中(e.g. e: skydriveattachments)

    • 在所有设备上使用下面的代码保存附件(如上所述更改路径)

    • 对所有帐户使用“仅一个 PST-file **”,创建文件夹,子文件夹等...

    • 在 VBA 中:请参阅“ microsoft scripting runtime'extra/references...”

    • 这是代码

    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

    我实际上在发布后不久就解决了这个问题,但是未能发布我的解决方案。老实说我不记得了。但是,当我得到一个面临相同挑战的新项目时,我不得不 re-visit 完成任务。

    我使用 Outlook.MailItem 的 ReceivedTime 属性来获取 time-stamp,因此我可以将其用作每个文件的唯一标识符,这样它们就不会彼此覆盖。

    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 个任务要执行。首先将电子邮件附件提取到文件夹,然后使用特定名称保存或重命名。

    如果您的搜索可以分为 2 个搜索,则您会获得更多匹配。我可以参考一页说明如何将附件保存到系统文件夹<1>的页面。

    如果发现使用特定名称保存附件,请张贴任何页面或代码。

相关问题