VBA: 查找邮件主题和附件名称之间是否存在共同模式

Question

我想验证外发电子邮件是否正确附加了正确的文件。电子邮件主题包含一个代码。附件文件名使用代码自动生成并手动附加到电子邮件中。 VBA 是检查电子邮件主题是否包含附件文件名中的常见模式。

代码类似于H??#######，即它必须以“H”开头，后跟 2 个字母，然后是 7 个数字。

如果邮件主题和文件名都包含相同的代码，则允许发送邮件，否则发出警告。例如：

Subject: Urgent Chapter 10 - HCX1234567 updated on 12 Dec 2015

Filename: HCX1234567_ABCCh10_20151212_0408

允许此电子邮件。

是否可以在发送前进行此类验证？

这是我的尝试：

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'Create Geoff Lai on 14 March 2016

Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.PropertyAccessor

Dim prompt As String
Dim strMsg As String
Dim mailContent As String
Dim jobCode As String
Dim attachName As String
Dim pos As Integer
Dim jcodepos As Integer

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

attachName = Item.Attachments.Item(1).FileName

mailContent = Item.Body + Item.Subject    ' Get a copy of all the e-mail body text and subject text to search.
mailContent = LCase(mailContent)          ' Make whole string lowercase for easier searching.

Set recips = Item.Recipients
For Each recip In recips        'Record email addressees if send to external domain
    Set pa = recip.PropertyAccessor
        If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@mydomain.com") = 0 Then
            strMsg = strMsg & "   " & pa.GetProperty(PR_SMTP_ADDRESS) & vbNewLine
        End If
Next
If strMsg <> "" Then
    If (Item.Attachments.Count = 0) Then      ' Check attachment
        If InStr(1, mailContent, "attach") > 0 Then
            pos = 1
            ElseIf InStr(1, mailContent, "Attach") > 0 Then
                pos = 1
            ElseIf InStr(1, mailContent, "enclose") > 0 Then
                pos = 1
            ElseIf InStr(1, mailContent, "Enclose") > 0 Then
                pos = 1
            Else: pos = 0
        End If
    End If
    If (pos > 0) Then       'If there is no attachment:
        If MsgBox("With the word attach or enclose, attachment should be found in this email" & vbNewLine & "Please Confirm.", vbYesNo + vbCritical + vbMsgBoxSetForeground, "Missing Attachment") = vbYes Then
            prompt = "This email will be sent outside of mydomain.com to:" & vbNewLine & strMsg & "Do you want to proceed?"
            If MsgBox(prompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Address") = vbNo Then
                Cancel = True
                Exit Sub
                Else
                    Exit Sub
            End If
            Else
                Cancel = True       'Stop sending
        End If
    End If
    If (Item.Attachments.Count > 0) Then        ' Validate attachment and subject
        jcodepos = InStr(1, attachName, "H??#######", 0)    ' Get job code position
        jobCode = Mid(attachName, jcodepos, 10)       ' Get job code
        If (InStr(1, Item.Subject, jobCode, 0) = 0) Then        ' If no common code between subject and attachment
            If MsgBox("There is no common job code between the email subject and the filename of the attachment." & vbNewLine & "Do you want to proceed?", _
                vbYesNo + vbCritical + vbMsgBoxSetForeground, "Wrong Attachment?") = vbNo Then
                Cancel = True
                Exit Sub
                Else
                    Exit Sub
            End If
            ElseIf MsgBox("Common job code " & jobCode & " is found in the email subject and the filename of the attachment" & prompt, _
                vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Confirm Job Code") = vbNo Then       ' If common code is found
                Cancel = True
                Exit Sub
                Else
                    Exit Sub
        End If
    End If
End If
End Sub

但是，我在 jobCode = Mid(attachName, jcodepos, 10) 处收到错误，即：

Run-time error '5' Invalid procedure call or argument

Answer 1

既然您考虑使用 VBA，我假设您正在使用 Outlook 作为您的电子邮件客户端。如果是这样，请将其添加到您的问题和标签中。有了这个假设，答案是它取决于：

如果真的用Outlook来发邮件就可以了。以下问答可能是一个很好的起点。 how to check details before sending mails in outlook using macros?

然而，如果电子邮件是 created with File | Send commands in Office programs or similar commands in Windows Explorer or other programs.

，上述技术将不起作用

Answer 2

Application_ItemSend，通常的方式，在 ThisOutlookModule 中。

在 VB 编辑器中设置对正则表达式的引用。

类似于Regular Expression Rules in Outlook 2007?的问题部分的代码。根据文件名检查 RegEx.Pattern = "(H[A-Z]{2}[0-9]{7})"。继续使用 RegEx 或 InStr 验证主题是否包含文件名匹配。

Answer 3

终于搞定了，多谢指教！这是我的锻炼。

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

Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.PropertyAccessor

Dim regex As Object, codeInSubject As Object, codeInAttach As Object

Dim matchSbjtCode As String, matchAttchcode As String
Dim prompt As String
Dim strMsg As String
Dim mailContent As String
Dim attachName As String
Dim pos As Integer

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

Set regex = CreateObject("vbScript.regExp")
With regex
    .Pattern = "[H][ACDILNOPQTUVW][BCGJMOPRSTWY][1-9][0-9]{6}"      ' Set regular expression pattern
    .Global = False     ' Check the first instance only
End With

attachName = Item.Attachments.Item(1).FileName
mailContent = Item.Body + Item.Subject    ' Get a copy of all the e-mail body text and subject text to search.
mailContent = LCase(mailContent)          ' Make whole string lowercase for easier searching.

Set recips = Item.Recipients
For Each recip In recips        'Record email addressees if send to external domain
    Set pa = recip.PropertyAccessor
        If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@mydomain.com") = 0 Then
            strMsg = strMsg & "   " & pa.GetProperty(PR_SMTP_ADDRESS) & vbNewLine
        End If
Next
prompt = "This email will be sent outside of mydomain.com to:" & vbNewLine & strMsg & "Do you want to proceed?"
If strMsg <> "" Then
    If (Item.Attachments.Count = 0) Then      ' Check attachment
        If InStr(1, mailContent, "attach") > 0 Then
            pos = 1
            ElseIf InStr(1, mailContent, "enclose") > 0 Then
            Else: pos = 0
        End If
    End If
    If (pos > 0) Then       'If there is no attachment:
        If MsgBox("With the word 'attach' or 'enclose', attachment should be found in this email" & vbNewLine & _
            "Please Confirm.", vbYesNo + vbCritical + vbMsgBoxSetForeground, "Missing Attachment") = vbYes Then     ' Prompt to check
            If MsgBox(prompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Address") = vbNo Then
                Cancel = True
                Exit Sub
                Else
                    Exit Sub
            End If
            Else
                Cancel = True       'Stop sending
        End If
    End If
    If (Item.Attachments.Count > 0) Then        ' Validate attachment and subject
        If regex.test(Item.Subject) And regex.test(attachName) Then     ' Test the job codes in the email subject and attachment filename
            Set codeInSubject = regex.Execute(Item.Subject)
            Set codeInAttach = regex.Execute(attachName)
            If StrComp(codeInSubject(0), codeInAttach(0)) = 0 Then      ' Compare the codes found
                If MsgBox("Common job code """ & codeInAttach(0) & """ is found in the email subject and the filename of the attachment. " & vbNewLine & prompt, _
                    vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Confirm Job Code") = vbNo Then       ' If found, confirm to send
                    Cancel = True
                    Else: Exit Sub
                End If
                ElseIf MsgBox("There is no common job code between the email subject and the filename of the attachment." & vbNewLine & _
                    "Do you want to DISCARD?", vbYesNo + vbCritical + vbMsgBoxSetForeground, "Wrong Attachment?") = vbYes Then      ' if not found, discard
                    Cancel = True
                    Else: Exit Sub
            End If
        End If
    End If
End If
End Sub

VBA: 查找邮件主题和附件名称之间是否存在共同模式

VBA: Find whether there is common pattern between the email subject and attachment name

outlook

vba

string-comparison