从Outlook 2010中的新电子邮件中提取本机收件人'电子邮件地址

时间:2015-08-18 17:37:57

标签: outlook outlook-addin outlook-vba outlook-2010

以下程序是从Outlook 2010中新组合的电子邮件帐户中提取收件人电子邮件地址。然后将其插入电子邮件正文中,并且工作正常。

但是,我只想提取和插入真实地址。现在程序将获取John Dow (john@isp.com); John1 Dow (john1@isp.com)等地址,并按原样将其插入电子邮件正文中。

我需要的是提取地址并仅插入地址john@isp.com; john@isp.com而不使用每个地址之前的全名。

感谢您的帮助。以下是我正在使用的代码 -

Sub copy_change() 'read the recepients of the new email and add them to the text body where the curser is.

Dim eRecipients As String

eRecipients = Application.ActiveInspector.currentItem.To

Dim objDoc As Word.Document, objSel As Word.Selection
On Error Resume Next

'~~> Get a Word.Selection from the open Outlook item
Set objDoc = Application.ActiveInspector.WordEditor
Set objSel = objDoc.Windows(1).Selection

'~~> Type Relevant Text
objSel.TypeText "Recipient : " & eRecipients

Set objDoc = Nothing
Set objSel = Nothing


End Sub

1 个答案:

答案 0 :(得分:1)

替换

eRecipients = Application.ActiveInspector.currentItem.To

dim recip As Recipient
eRecipients = ""
for each recip in Application.ActiveInspector.CurrentItem.Recipients
  if Recip.Type = olTo Then
    if (eRecipients <> "") Then eRecipients  = eRecipients  & ", " 
    eRecipients = eRecipients & recip.Address
  End If
next