扫描外部域的电子邮件收件人

时间:2017-08-23 15:23:54

标签: vba outlook outlook-vba

我编写了一些代码来扫描已发送电子邮件的收件人,并编辑外部域的主题行。但是,如果包含电子邮件通讯组列表,则会引发错误。如何在搜索外部域时处理通讯组列表中的成员?

Private Sub Application_ItemSend(ByVal Item As Object, cancel As Boolean)

Dim strSubject As String
Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.PropertyAccessor
Dim outsideEmails() As String
Dim includesOutsideDomain As Boolean
Dim i As Integer
Dim userChoice As Integer

Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"

Set recips = Item.Recipients
ReDim outsideEmails(recips.Count)

strSubject = Item.Subject
includesOutsideDomain = False

i = 0

For Each recip In recips
    Debug.Print recip
    Set pa = recip.PropertyAccessor
    If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@example.com") = 0 Then
       outsideEmails(i) = pa.GetProperty(PR_SMTP_ADDRESS)
        'On Error Resume Next
       includesOutsideDomain = True
    End If
Next
If includesOutsideDomain Then
    If InStr(LCase(strSubject), "encrypt:") = 0 Then
        userChoice = MsgBox("You may be sending this email to an outside domain without encryption. Would you like to encrypt this message?" _
            , vbYesNoCancel + vbCritical + vbMsgBoxSetForeground, "Encryption Warning")

        Select Case userChoice
            Case 6: 'yes
                strSubject = "Encrypt:" & strSubject
                Item.Subject = strSubject
            Case 7: 'no
            Case 2: 'cancel
                cancel = True
        End Select
    End If
End If
End Sub

这是错误: Error Message

2 个答案:

答案 0 :(得分:0)

是的,如果给定的属性不存在,<script src="https://cdnjs.cloudflare.com/ajax/libs/vue/2.4.2/vue.js"></script> <div id="app"> <div class="panel panel-default"> <ul class="list-group"> <li class="list-group-item" v-for="(panel, index) in panels" :class="{active: index === activeItem}" :style="{ color: panel.color }" v-on:click="clickHandler(index)" > A section {{panel.section}} was {{panel.action}} </li> </ul> </div> </div>将引发异常。这是设计的。您必须期望并捕获该异常。

答案 1 :(得分:0)

如此处所述http://www.vbaexpress.com/forum/showthread.php?53174-VBA-to-expand-Outlook-Distribution-Group-before-send

这会扩展分发列表和嵌套分发列表。

Set recips = Item.Recipients

之前
Sub DLExpand()

    ' http://www.vbaexpress.com/forum/showthread.php?53174-VBA-to-expand-Outlook-Distribution-Group-before-send

    Dim currItem As mailitem
    Dim recips As Recipients

    Dim innerDistListFound As Boolean

    Dim i As Long
    Dim j As Long

    Set currItem = ActiveInspector.currentItem
    innerDistListFound = True

    Do Until innerDistListFound = False

        Set recips = currItem.Recipients
        innerDistListFound = False

        If recips.count = 0 Then GoTo ExitRoutine

        For j = recips.count To 1 Step -1

             'Debug.Print recips(j)

            If recips(j).AddressEntry.DisplayType <> olUser Then

                 ' Expand the dist list
                For i = 1 To recips(j).AddressEntry.Members.count

                    If recips(j).AddressEntry.Members.Item(i).DisplayType = olUser Then
                        currItem.Recipients.Add (recips(j).AddressEntry.Members.Item(i).Address)
                    Else
                        currItem.Recipients.Add (recips(j).AddressEntry.Members.Item(i).name)
                        innerDistListFound = True
                         'Debug.Print " innerDistListFound: " & innerDistListFound
                    End If

                    Debug.Print "- " & recips(j).AddressEntry.Members.Item(i).name

                Next

                recips(j).Delete
                recips.ResolveAll
                DoEvents

            End If

        Next j

        recips.ResolveAll

    Loop

ExitRoutine:
    Set currItem = Nothing
    Set recips = Nothing

     'Debug.Print "Done."

End Sub