Outlook 标题 附件 提醒 VBA 代码

 

网上转载，仅供参考

经常为忘了写标题和贴附件而苦恼，今天开始不用了。。。

老大推荐了这个宏，很好很强大，只是存在几个Bug...
1.代码格式十分FT..提示用中文
2.邮件的回复、转发等内容不用检查
3.提示在前台而不是后台
4.取消发送不是将邮件保留到草稿箱。

操作如下：
a. 打开outlook
b. 按“Alt + F11” 键来打开VB Script,或者[工具]->[宏]->[Visual Basic 编辑器]
c. 点击左侧树状目录最下面的“ThisOutlookSession”，看到右边出现空白的编辑窗口
d. 把代码拷贝到编辑窗口，保存，退出VB Script编辑。

代码修改了如下：

重启失效的原因是需要修改outlook的“工具”-->“宏”-->“安全性”-->修改安全级别为中或者低 

这样重启outlook的时候，才会提示你是否加载该宏，而不是直接就默认拒掉

 

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

If TypeName(Item) <> "MailItem" Then Exit Sub

Dim intRet As Integer

'CHECK FOR BLANK SUBJECT LINE
If Item.Subject = "" Then
    intRet = MsgBox("警告：您的郵件缺少主題，請注意填寫" & vbNewLine, vbOKOnly + vbMsgBoxSetForeground + vbExclamation, "缺少主題")
    If intRet = vbOK Then
        Cancel = True
        Exit Sub
    End If
End If

'CHECK FOR FORGETTING ATTACHMENT
Dim intRes As Integer
Dim strMsg As String
Dim strThismsg As String
Dim intOldmsgstart As Integer

' Does not search for "Attach", but for all strings in an array that is defined here
Dim sSearchStrings(2) As String
Dim bFoundSearchstring As Boolean
Dim i As Integer

bFoundSearchstring = False
sSearchStrings(0) = "attach"
sSearchStrings(1) = "enclose"
sSearchStrings(2) = "附件"

' intOldmsgstart = InStr(Item.Body, "-----Original Message-----")
intOldmsgstart = InStr(Item.Body, "發件人:")

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
' if the original included message is mentioning an attachment, ignore that Also includes the subject line at the end of the strThismsg string

For i = LBound(sSearchStrings) To UBound(sSearchStrings)
    If InStr(LCase(strThismsg), sSearchStrings(i)) > 0 Then
        bFoundSearchstring = True
        Exit For
    End If
Next i

If bFoundSearchstring Then
    If Item.Attachments.Count = 0 Then
        strMsg = "警告：您的郵件缺少附件，請注意添加" & vbNewLine & "確認是否發送?"
        intRet = MsgBox(strMsg, vbYesNo + vbMsgBoxSetForeground + vbDefaultButton2 + vbExclamation, "缺少附件")
        If intRet = vbNo Then
            Cancel = True
            Exit Sub
        End If
    End If
End If

End Sub