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

我想验证发送的电子邮件是否正确附加了正确的文件。电子邮件主题包含一个代码。附件文件名由代码自动生成，并手动附加到电子邮件中。VBA检查电子邮件主题在附件的文件名中是否包含公共模式

该代码类似于

H？？#######

，即它必须以“H”开头，后跟2个字母，然后是7位数字

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

主题：紧急第10章-HCX1234567于2015年12月12日更新

文件名：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

私有子应用程序\u ItemSend（ByVal项作为对象，取消作为布尔值）
“于2016年3月14日创建Geoff Lai
将收件人设置为Outlook.Recipients
将recip设置为Outlook.Recipient
将pa设置为Outlook.PropertyAccessor
将提示变暗为字符串
作为字符串的Dim strMsg
将邮件内容设置为字符串
将作业代码设置为字符串
作为字符串的Dim attachName
作为整数的Dim pos
Dim jcodepos作为整数
常量PR_SMTP_地址作为字符串=”http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
attachName=Item.Attachments.Item（1）.FileName
mailContent=Item.Body+Item.Subject'获取要搜索的所有电子邮件正文文本和主题文本的副本。
mailContent=LCase（mailContent）'使整个字符串小写以便于搜索。
设置recips=Item.Recipients
对于recips中的每个recips，如果发送到外部域，则记录电子邮件收件人
设置pa=recip.PropertyAccessor
如果InStr（LCase（pa.GetProperty（PR_SMTP_地址）），“@mydomain.com”）=0，则
strMsg=strMsg&&pa.GetProperty（PR\u SMTP\u地址）&vbNewLine
如果结束
下一个
如果strMsg“”则
如果（Item.Attachments.Count=0），则“检查附件”
如果InStr（1，mailContent，“attach”）>0，则
位置=1
ElseIf InStr（1，邮件内容，“附加”）>0然后
位置=1
ElseIf InStr（1，mailContent，“随函附上”）>0则
位置=1
ElseIf InStr（1，mailContent，“随函附上”）>0则
位置=1
其他：位置=0
如果结束
如果结束
如果（位置>0），则“如果没有附件：
如果MsgBox（“带有attach或include字样，附件应在本电子邮件中找到”&vbNewLine&“请确认”，vbYesNo+vbCritical+vbMsgBoxSetForeground，“缺少附件”）=vbYes，则
prompt=“此电子邮件将在mydomain.com之外发送到：”&vbNewLine&strMsg&“是否继续？”
如果MsgBox（提示，vbYesNo+VBEQUOTION+vbMsgBoxSetForeground，“检查地址”）=vbNo，则
取消=真
出口接头
其他的
出口接头
如果结束
其他的
取消=真“停止发送
如果结束
如果结束
如果（Item.Attachments.Count>0），则“验证附件和主题”
jcodepos=InStr（1，附件名，“H？”，0）“获取工作代码位置”
jobCode=Mid（附件名称，jcodepos，10）'获取作业代码
如果（说明（1，项目主题，工作代码，0）=0），则“如果主题和附件之间没有通用代码
如果MsgBox（“电子邮件主题和附件文件名之间没有通用职务代码。”&vbNewLine&“是否继续？”_
vbYesNo+vbCritical+vbMsgBoxSetForeground，“错误的附件？”）=vbNo然后
取消=真
出口接头
其他的
出口接头
如果结束
ElseIf MsgBox（“通用职务代码”和职务代码&“在电子邮件主题和附件的文件名”和提示符中找到_
vbYesNo+vbQuestion+vbMsgBoxSetForeground，“确认作业代码”）=vbNo然后“如果找到公共代码
取消=真
出口接头
其他的
出口接头
如果结束
如果结束
如果结束
端接头

但是，我在

jobCode=Mid（attachName，jcodepos，10）

处得到一个错误，即：

运行时错误“5”过程调用或参数无效

---

既然您考虑使用VBA，我就假设您使用Outlook作为电子邮件客户端。如果是，请将此添加到您的问题和标签中。根据这一假设，答案是它取决于：

如果Outlook实际用于发送电子邮件，则可以完成此操作。下面的问答可能是一个很好的起点。

---

然而，如果电子邮件是此OutlookModule中通常使用的应用程序发送方式，则上述技术将不起作用

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

---

类似于问题部分的代码。对照文件名检查RegEx.Pattern=“（H[A-Z]{2}[0-9]{7}）”。继续使用RegEx或InStr验证主题是否包含文件名匹配。

最后，我已经找到了答案，谢谢您的建议！ 这是我的训练

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

私有子应用程序\u ItemSend（ByVal项作为对象，取消作为布尔值）
将收件人设置为Outlook.Recipients
将recip设置为Outlook.Recipient
将pa设置为Outlook.PropertyAccessor
Dim regex作为对象，CodeInObject作为对象，codeInAttach作为对象
Dim matchSbjtCode为字符串，MATCHATTCHEDE为字符串
将提示变暗为字符串
作为字符串的Dim strMsg
将邮件内容设置为字符串
作为字符串的Dim attachName
作为整数的Dim pos
常量PR_SMTP_地址作为字符串=”http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
设置regex=CreateObject（“vbScript.regExp”）
用正则表达式
.Pattern=“[H][ACDILNOPQTUVW][BCGJMOPRSTWY][1-9][0-9]{6}”设置正则表达式模式
.Global=False“仅检查第一个实例
以
附件名称=项目