时间戳

首页 > 解决方案 > 保存当前电子邮件并将其重新创建为新邮件

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

问题描述

我需要一个用于 Outlook 的宏，它可以：

  1. 将打开的电子邮件另存为 email.msg（包括附件）
  2. 关闭当前的电子邮件窗口
  3. 创建一封从 email.msg 读取的新电子邮件（从步骤 1 开始。）

我在谷歌上做了一些研究，但没有什么对我有用。这就是我到目前为止所做的（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

标签： vbaoutlooksavenew-operator

解决方案

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

推荐阅读