如何用VBA使每次转发时只转发附件而将正文清空

yy10

如题，对于outlook vba不了解，不知这个应该怎么实现。

aaaaabbbbb

请参考这个帖子:
http://www.codeforexcelandoutloo ... -send-clean-emails/

我把代码拷贝出来,我试过了,是可以的.

   Sub SaveFilesAndSendCleanEmail()
' save attachments to desktop folder (create one if necessary),
' then email them out one by one

    Dim Msg As Outlook.MailItem
    Dim NewMsg As Outlook.MailItem
    Dim MsgColl As Object
    Dim MsgAttach As Outlook.Attachments
    Dim NewMsgAttach As Outlook.Attachments
    Dim ThisAttach As Outlook.Attachment
    Dim i As Long
    Dim strMyDesktop As String
    Dim strDestinationFolder As String
    Dim strFileN As String
    Dim fso As Object
    Dim item As Object
  
   On Error Resume Next
   Set MsgColl = ActiveExplorer.Selection
   On Error GoTo 0
  
   If MsgColl Is Nothing Then
     MsgBox "Nothing selected"
     GoTo ExitProc
   End If
  
   ' get path of user's desktop and build a string for the destination folder
   strMyDesktop = MyDesktopPath & "\"
   strDestinationFolder = strMyDesktop & "Saved Attachments\"
  
   ' get a FileSystemObject reference
   Set fso = GetFSO
  
   ' check if the folder exists, if not then create it to store the attachments
   If fso.FolderExists(strDestinationFolder) = False Then
       MkDir strDestinationFolder
   End If
  
   ' loop through each selected item and make sure they are all mailitems
   ' if so, then save each attachment from each message to the destination folder
   For Each item In MsgColl
     If item.Class = olMail Then ' it's an email, not a post, note, meeting request, etc
       Set Msg = item
       Set MsgAttach = Msg.Attachments
  
       If MsgAttach.count > 0 Then
         For i = 1 To MsgAttach.count
           MsgAttach.item(i).SaveAsFile strDestinationFolder & MsgAttach.item(i).FileName
         Next i
       End If
     End If
   Next item
  
   ' Forward attachments to another email address
   ' first create the email, then loop through destination folder, adding attachments to the email and deleting them from the folder as we go
   Set NewMsg = CreateItem(olMailItem)
   Set NewMsgAttach = NewMsg.Attachments
  
   strFileN = Dir(strDestinationFolder & "*.*")
  
   Do While Len(strFileN) > 0
     NewMsgAttach.Add strDestinationFolder & strFileN
     Kill strDestinationFolder & strFileN
     strFileN = Dir
   Loop
  
   NewMsg.Display
  
   ' clean up emails (optional)
   If MsgBox("Would you like to delete the selected emails now?", vbInformation + vbYesNo) = vbYes Then
     For i = 1 To MsgColl.count
       Set Msg = MsgColl.item(i)
       With Msg
         .UnRead = False
         .Delete
       End With
     Next i
   End If
  
   If MsgBox("Delete destination folder that was created on your desktop?", vbInformation + vbYesNo) = vbYes Then
     RmDir strDestinationFolder
   End If
  
ExitProc:
   Set Msg = Nothing
   Set MsgColl = Nothing
   Set MsgAttach = Nothing
   Set fso = Nothing
   Set NewMsg = Nothing
   Set NewMsgAttach = Nothing
   End Sub


Function MyDesktopPath() As String
' returns path to Desktop folder as a String
' from http://tinyurl.com/GetFolderPath
Dim WSHShell As Object

Set WSHShell = CreateObject("WScript.Shell")
MyDesktopPath = WSHShell.SpecialFolders("Desktop")

Set WSHShell = Nothing
End Function

Function GetFSO() As Object
' returns a reference to the Scripting.FileSystemObject to the calling sub
On Error Resume Next
   Set GetFSO = GetObject(, "Scripting.FileSystemObject")
On Error GoTo 0

If GetFSO Is Nothing Then
   Set GetFSO = CreateObject("Scripting.FileSystemObject")
End If
End Function