Save current email and recreate it as new mail

Question

I need a macro for Outlook that will do:

1. Saves the open e-mail as email.msg (including attachments)
2. Closes the curent e-mail window
3. Creates a new email, which is read from email.msg (from step 1.)

---

I did some research on google, but nothing works for me. This is what i've done so far (the 1. step.. but not working)

    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