Question

我已创建此宏，可让我执行以下操作：

选择要将附件保存到
从

保存电子邮件后，我需要从电子邮件中删除已保存的附件，并将其替换为指向其保存位置的链接。

以下是我正在使用的代码：

Option Explicit

Sub SaveMailAttachments()
On Error Resume Next
Dim ns As NameSpace
Set ns = GetNamespace("MAPI")
Dim Inbox As MAPIFolder
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Dim saveFolder As String
Dim subFolder As MAPIFolder
Dim Item As Object
Dim Attach As Attachment
Dim FileName As String, fName As String
Dim i As Integer
Dim Searchdate As String
Dim SentDate As String
Dim sntDate As Date

Searchdate = InputBox("Please enter a Previous date to search from")

saveFolder = BrowseForFolder("Select the folder you will like to save the attachments to.")
If saveFolder = vbNullString Then Exit Sub

  i = 0

   If Inbox.Items.Count = 0 Then
    MsgBox "There are no messages in the inbox.", vbInformation, _
                "nothing Found"
    Exit Sub
End If

On Error Resume Next

For Each Item In Inbox.Items
    sntDate = Item.SentOn

    SentDate = Format(sntDate, "mm/dd/yyyy")

    For Each Attach In Item.Attachments
        If Searchdate < SentDate Then
        FileName = saveFolder & "\" & Attach.FileName
        Attach.SaveAsFile FileName
        i = i + 1
        End If

    Next Attach
    'End If

Next Item

End Sub

Answer 1

要删除附件，请调用Attachment.Delete。对于每个＆＃34;您可能希望使用for i = Attachments.Count to 1 step -1循环而不是＆＃34;因为删除附件会改变收集计数。您可能还想检查附件扩展名/ etc。首先要确保您没有删除嵌入的HTML图像附件。

要插入附件作为参考，请调用Attachments.Add指定新的附件位置，但将olByReference作为第二个参数传递。

Answer 2

这里几乎有工作代码http://www.outlook-tips.net/code-samples/save-and-delete-attachments/

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 & "OLAttachments"

'Use the MsgBox command to troubleshoot. Remove it from the final code.
MsgBox strFolderpath

' Check each selected item for attachments. If attachments exist,
' save them to the Temp 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

        'Use the MsgBox command to troubleshoot. Remove it from the final code.
        MsgBox objAttachments.Count

        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 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
        End If

        ' Adds the filename string to the message body and save it
        ' Check for HTML body
        If objMsg.BodyFormat <> olFormatHTML Then
            objMsg.Body = objMsg.Body & vbCrLf & _
              "The file(s) were saved to " & strDeletedFiles
        Else
            objMsg.HTMLBody = objMsg.HTMLBody & "<p>" & _
              "The file(s) were saved to " & strDeletedFiles & "</p>"
        End If

        objMsg.Save
        'sets the attachment path to nothing before it moves on to the next message.
        strDeletedFiles = ""

    End If
Next

ExitSub:

Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing

End Sub

它使用“On Error Resume Next”来解决过去的问题，但是关于添加消息链接的重要部分很好。

无论有什么其他问题，都需要其中两个。

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

保存后删除电子邮件附件并将保存位置添加到Outlook中的电子邮件中

2 个答案: