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

时间：2013-03-20 17:50:20

标签： vba outlook attachment outlook-vba

我正在尝试在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 个答案:

答案 0 :(得分：33)

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

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

答案 1 :(得分：5)

请参阅ReceivedTime属性

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

您在 SaveAs文件行中的\末尾添加了另一个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

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

  

这通常是由安全设置引起的。这是一个“陷阱”，为初次使用者设置允许宏然后将其带走。 http://www.slipstick.com/outlook-developer/how-to-use-outlooks-vba-editor/

答案 2 :(得分：2)

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

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

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

  5. 对所有帐户使用仅一个PST文件，制作文件夹，子文件夹等...

    6. VBA中的

  6. ：请参阅“microsoft scripting runtime'额外/参考...'

  7. 这是代码

    8. 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

答案 3 :(得分：2)

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

答案 4 :(得分：1)

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

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

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

答案 5 :(得分：1)

您的问题有两项任务要执行。首先将电子邮件附件提取到文件夹，然后使用特定名称保存或重命名。

如果您的搜索可以拆分为2次搜索，则会获得更多点击次数。我可以参考一页解释如何将附件保存到系统文件夹＆lt; Link for the page to save attachments to a folder＆gt;。

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

相关问题
最新问题