Outlook空标题检测脚本

Outlook空标题检测脚本

'在Outlook里面，按alt+F11，然后编辑器里搞这个进去
'这样在发送邮件的时候会检测空标题
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    If TypeName(Item) <> "MailItem" Then Exit Sub
    Dim cancel_Subject As Boolean
    Dim cancel_Attach As Boolean

    'CHECK FOR BLANK SUBJECT LINE
    If Item.Subject = "" Then
        cancel_Subject = MsgBox("邮件无标题，依然发送吗？", vbYesNo + vbExclamation, "邮件标题为空") = vbNo
        If (cancel_Subject) = True Then
            Cancel = True
            Exit Sub
        End If
    End If

    '附件检查功能不启用了
    Exit Sub

    'CHECK FOR FORGETTING ATTACHMENT
    Dim intRes As Integer
    Dim strMsg As String
    Dim strThismsg As String
    Dim intOldmsgstart As Integer
    ' ADDED BY LS >>>
    ' - Does not search for "Attach", but for all strings in an array that is defined here
    Dim sSearchStrings(1) As String
    Dim bFoundSearchstring As Boolean
    Dim i As Integer ' loop var for FOR-NEXT-loop
    bFoundSearchstring = False
    sSearchStrings(0) = "附件"
    ' ADDED BY LS <<<
    intOldmsgstart = InStr(Item.Body, "-----Original Message-----")
    ' intOldmsgstart is the location of where old/re/fwd msg starts. Will be 0 if new msg
    If intOldmsgstart = 0 Then
        strThismsg = Item.Body + " " + Item.Subject
    Else
        strThismsg = Left(Item.Body, intOldmsgstart) + " " + Item.Subject
    End If

    ' The above if/then/else will set strThismsg to be the text of this message only,
    ' excluding old/fwd/re msg
    ' IE if the original included message is mentioning an attachment, ignore that
    ' Also includes the subject line at the end of the strThismsg string
    ' ADDED BY LS >>>
    For i = LBound(sSearchStrings) To UBound(sSearchStrings)
        If InStr(LCase(strThismsg), sSearchStrings(i)) > 0 Then
            bFoundSearchstring = True
            Exit For
        End If
    Next i

    ' ADDED BY LS <<<
    If bFoundSearchstring Then
        If Item.Attachments.Count = 0 Then
            strMsg = "邮件可能缺少附件，依然发送？"
            intRes = MsgBox(strMsg, vbYesNo + vbDefaultButton2 + vbExclamation, "邮件缺失附件")
            If intRes = vbNo Then
                ' cancel send
                cancel_Attach = True
            End If
        End If
    End If
    If (cancel_Subject Or cancel_Attach) = True Then
        Cancel = True
    End If
End Sub