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

Question

提问by Roy Haskell

I'm trying to get a VBA macro in Outlook that will save an email's attachment to a specific folder and add the date receivedto the file name.

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

My googling has gotten me this far:

我的谷歌搜索让我走到了这一步：

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

The first obvious thing is that it's applying the current time to the file name instead of the received time, but I can't seem to change it. My theory is that the Outlook.Attachment doesn't have a ReceivedTimeand that the email itself has to be referenced.

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

Secondly, this doesn't seem to work at all, ha! It worked the first day I started tinkering but after that it stopped saving files.

其次，这似乎根本行不通，哈！它在我开始修补的第一天就起作用了，但在那之后它停止了保存文件。

Answer 1

采纳答案by Stuart

This is my Save Attachments script. You select all the messages that you want the attachments saved from, and it will save a copy there. It also adds text to the message body indicating where the attachment is saved. You could easily change the folder name to include the date, but you would need to make sure the folder existed before starting to save files.

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

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

Answer 2

回答by niton

See ReceivedTimeProperty

见ReceivedTime属性

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

You added another \to the end of C:\Temp\in the SaveAs Fileline. Could be a problem. Do a test first before adding a path separator.

您在SaveAs File行\的末尾添加了另一个。可能是个问题。在添加路径分隔符之前先进行测试。C:\Temp\

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

You have not set objAttso there is no need for "Set objAtt = Nothing". If there was it would be just before End Subnot in the loop.

您尚未设置，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

Re: It worked the first day I started tinkering but after that it stopped saving files.

回复：它在我开始修补的第一天就起作用了，但在那之后它停止了保存文件。

This is usually due to Security settings. It is a "trap" set for first time users to allow macros then take it away. http://www.slipstick.com/outlook-developer/how-to-use-outlooks-vba-editor/

这通常是由于安全设置。这是为首次用户设置的“陷阱”，允许宏然后将其删除。 http://www.slipstick.com/outlook-developer/how-to-use-outlooks-vba-editor/

Answer 3

回答by David

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

Answer 4

回答by user2485790

Added simple code to save with readable date-time stamp.

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

Use sync2pstto sync all your data in outlook with all your devices, work like this:

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

you only need to buy 1 license: save your pst file on one computer (let's call this pc 'server') on your network.
create scheduled tasks that will synchronize the pst file on your 'server' with all the pst files on all your devices, no matter which device downloaded the emails first (you need some dos programming knowledge to bypass pst files that are open at sync time).
save all your attachments on the same skydrive folder that is located on the same place on all your devices (e.g. e:\skydrive\attachments)
Use the code below on all your devices to save attachments (change the path as mentioned above)
Use ONLY ONE PST-filefor all your accounts, make folders, subfolders and so ...
in VBA: refer to 'microsoft scripting runtime'extra/references...'
here's the code

您只需要购买 1 个许可证：将您的 pst 文件保存在您网络上的一台计算机上（我们称这台电脑为“服务器”）。
创建计划任务，将“服务器”上的 pst 文件与所有设备上的所有 pst 文件同步，无论哪个设备先下载了电子邮件（您需要一些 dos 编程知识来绕过同步时打开的 pst 文件） .
将所有附件保存在所有设备上相同位置的同一个 skydrive 文件夹中（例如 e:\skydrive\attachments）
在所有设备上使用以下代码保存附件（更改上述路径）
对您的所有帐户仅使用一个 PST 文件，创建文件夹、子文件夹等...
在 VBA 中：参考microsoft scripting runtime“额外/引用...”
这是代码

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

Answer 5

回答by Roy Haskell

I actually had solved this not long after posting but failed to post my solution. I honestly don't remember it. But, I had to re-visit the task when I was given a new project that faced the same challenge.

我实际上在发布后不久就解决了这个问题，但未能发布我的解决方案。老实说我不记得了。但是，当我接到一个面临同样挑战的新项目时，我不得不重新审视这个任务。

I used the ReceivedTime property of Outlook.MailItem to get the time-stamp, I was able to use this as a unique identifier for each file so they do not override one another.

我使用 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

Thanks a ton for the other solutions, many of them go above an beyond :)

非常感谢其他解决方案，其中许多都超越了:)

Answer 6

回答by KumaraPush

Your question has 2 tasks to be performed. First to extract the Email attachments to a folder and saving or renaming it with a specific name.

您的问题有 2 个任务要执行。首先将电子邮件附件解压缩到一个文件夹并使用特定名称保存或重命名它。

If your search can be split to 2 searches you will get more hits. I could refer one page that explains how to save the attachment to a system folder <Link for the page to save attachments to a folder>.

如果您的搜索可以拆分为 2 个搜索，您将获得更多点击。我可以参考解释如何将附件保存到系统文件夹的页面<用于将附件保存到文件夹的页面的链接>。

Please post any page or code if you have found to save the attachment with specific name.

如果您发现以特定名称保存附件，请发布任何页面或代码。

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

提问by Roy Haskell

采纳答案by Stuart

回答by niton

回答by David

回答by user2485790

回答by Roy Haskell

回答by KumaraPush

相关推荐

最近更新

标签

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

提问by Roy Haskell

采纳答案by Stuart

回答by niton

回答by David

回答by user2485790

回答by Roy Haskell

回答by KumaraPush

相关推荐

vba 每当单元格更改时，excel VBA都会自动运行宏

vba VBA中的文件搜索

Excel VBA - 将多个用户表单复选框值写入单个单元格

访问 VBA：根据非绑定列在组合框中查找项目

相关推荐

最近更新

标签