保存当前电子邮件并将其重新创建为新邮件

Question

我需要一个适用于 Outlook 的宏：

将打开的电子邮件另存为email.msg（包括附件）
关闭当前电子邮件window
创建一封新电子邮件，该电子邮件是从 email.msg（从第 1 步开始）读取的。

我对 google 做了一些研究，但对我没有任何帮助。这是我到目前为止所做的（第 1. 步..但没有用）

    Option Explicit
    Public Sub SaveMessageAsMsg()
      Dim oMail As Outlook.MailItem
      Dim objItem As Object
      Dim sPath As String
      Dim dtDate As Date
      Dim sName As String
      Dim enviro As String
     
        enviro = CStr(Environ("USERPROFILE"))
       For Each objItem In ActiveExplorer.Selection
       If objItem.MessageClass = "IPM.Note" Then
        Set oMail = objItem
       
      sName = oMail.Subject
      ReplaceCharsForFileName sName, "email"
     
      dtDate = oMail.ReceivedTime
      sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
        vbUseSystem) & Format(dtDate, "-hhnnss", _
        vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
         
        sPath = enviro & "\Documents\"
      Debug.Print sPath & sName
      oMail.SaveAs sPath & sName, olMsg


'this closes window:

Dim myinspector As Outlook.Inspector
 
Dim myItem As Outlook.MailItem
  
Set myinspector = Application.ActiveInspector
Set myItem = myinspector.CurrentItem
 myItem.Close olSave
      
      End If
      Next
      
    End Sub

Answer 1

Option Explicit

Sub SaveCurrentItemAsMsg()

    Dim oMail As MailItem
    Dim objItem As Object
    Dim sPath As String
    Dim dtDate As Date
    Dim sName As String
    Dim enviro As String
    
    Dim myItem As MailItem
    
    enviro = CStr(Environ("USERPROFILE"))
    
    Set objItem = ActiveInspector.currentItem
    
    If objItem.MessageClass = "IPM.Note" Then
        
        Set oMail = objItem
            
        sName = oMail.Subject
        ReplaceCharsForFileName sName, "email"
            
        dtDate = oMail.ReceivedTime
        sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
            vbUseSystem) & Format(dtDate, "-hhnnss", _
            vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
         
        sPath = enviro & "\Documents\"
        Debug.Print sPath & sName
        oMail.SaveAs sPath & sName, olMsg
        
        oMail.Close olDiscard
        Set oMail = Nothing
        
        Set myItem = Session.OpenSharedItem(sPath & sName)
        myItem.Display
            
    End If
      
End Sub


Sub SaveSelectedMessagesAsMsg()

    Dim oMail As MailItem
    Dim objItem As Object
    Dim sPath As String
    Dim dtDate As Date
    Dim sName As String
    Dim enviro As String
    
    Dim myItem As MailItem
     
    enviro = CStr(Environ("USERPROFILE"))
    
    For Each objItem In ActiveExplorer.Selection
    
        If objItem.MessageClass = "IPM.Note" Then
        
            Set oMail = objItem
            
            sName = oMail.Subject
            ReplaceCharsForFileName sName, "email"
     
            dtDate = oMail.ReceivedTime
            sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
              vbUseSystem) & Format(dtDate, "-hhnnss", _
              vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
         
            sPath = enviro & "\Documents\"
            Debug.Print sPath & sName
            oMail.SaveAs sPath & sName, olMsg
  
            Set myItem = Session.OpenSharedItem(sPath & sName)
            myItem.Display
            
        End If
    Next
      
End Sub

保存当前电子邮件并将其重新创建为新邮件

Save current email and recreate it as new mail

outlook

vba

save

new-operator