VBA Copy Email as .MSG to New Email

时间:2016-10-20 19:28:17

标签: vba email outlook outlook-vba

I am new to using VBA and I've looked around trying to find a solution. I don't know if this is even possible but I'm going to try and see if anyone can come up with any ideas.

So when you go into Outlook and you right click on an email, you can select copy. When you create a new email and paste the email, the copied email gets attached as a .msg as an attached file.

I am trying to replicate this process. Right now my process is

  1. Find email

    InStr(olMail.Subject, "SUBJECT") <> 0
    
  2. Display email

    olMail.Display 
    
  3. Copy body and set text to strPaste

    Buf.SetText(OlMail.Body)
    Buf.PutInClipBoard 
    strPaste = Buf.GetText(1)
    
  4. Create new email

    MailItem = OlApp.CreateItem(0)
    
  5. Paste body

    .Body = strPaste
    

This works but it isn't as clean because there are other things that are going into a message and it would be better for the copied email to be attached to an email instead of copying the body text.

I also don't want to save the email as an .msg and then attach it because other people will be using the macro and it would be quite tedious to change the path of where the email gets saved for every individual.

Any suggestions would be great!

1 个答案:

答案 0 :(得分:1)

  

因此,当您进入Outlook并右键单击电子邮件时,您可以选择复制。当您创建新电子邮件并粘贴电子邮件时,复制的电子邮件将附加为.msg作为附件。

     

我正在尝试复制这个过程。

将MailItem转发为附件时,请使用olEmbeddeditem 哪个Outlook邮件格式文件(.msg)是原始邮件到新邮件的副本。

vba中的示例是

Option Explicit
Sub Example()
    '//  Declare variables
    Dim Msg As Outlook.MailItem
    Dim Item As Outlook.MailItem

    ' Select Item
    If Application.ActiveExplorer.Selection.Count = 0 Then
        MsgBox ("No Item selected")
        Exit Sub
    End If

    For Each Item In Application.ActiveExplorer.Selection
        Set Msg = Application.CreateItem(olMailItem)

        With Msg
            .Attachments.Add Item, olEmbeddeditem ' Attch Selected email
            .Display
        End With
    Next

    '// Clean up
    Set Item = Nothing
    Set Msg = Nothing
End Sub

选择您要将.msg复制到新电子邮件的电子邮件,然后运行代码