OUTLOOK忘记添加附件的提醒

lx105834038

经常在邮件中说“见附件”，但是却忘记贴附件，非常的尴尬。
所以找了一段代码提醒自己。
原文参考：http://blog.sina.com.cn/s/blog_660c623c0100timt.html

楼主测试用的系统说明：
OUTLOOK版本：LTSC；
系统版本：Win10；

使用方法：
Alt+F11→在ThisOutlookSession中复制以下代码→保存
提醒：其他版本的建议保存后重启OUTLOOK，或者关闭时提醒宏保存的点击保存。

1. Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
   
2.     ' 只检查邮件类型
   
3.     If TypeName(Item) <> "MailItem" Then Exit Sub
   
4.    
   
5.     Dim intRet As Integer
   
6.     Dim strMsg As String
   
7.    
   
8.     ' 空主题？
   
9.     If Item.Subject = "" Then
   
10.        strMsg = "您的邮件缺少主题，返回填写吗？" & vbCrLf & "没有主题的邮件可不礼貌哦～"
    
11.        intRet = MsgBox(strMsg, vbYesNo + vbExclamation, "缺少主题")
    
12.        If intRet = vbYes Then
    
13.            Cancel = True
    
14.            Exit Sub
    
15.        End If
    
16.    End If
    
17.    
    
18.     ' 忘了帖附件？
    
19.     Dim intRes As Integer
    
20.     Dim strThismsg As String
    
21.     Dim intOldmsgstart As Integer
    
22.    
    
23.     Dim sSearchStrings(2) As String
    
24.     Dim bFoundSearchstring As Boolean
    
25.     Dim i As Integer
    
26.    
    
27.     ' 指定提示邮件可能需要附件的词
    
28.    bFoundSearchstring = False
    
29.     ' 英文邮件
    
30.    sSearchStrings(0) = "attach"
    
31.    sSearchStrings(1) = "enclose"
    
32.     ' 中文邮件
    
33.    sSearchStrings(2) = "附件"
    
34.    
    
35.    ' 对于转发和回复的邮件，不要到信末附的邮件原文进行搜索
    
36.     ' 纯文本格式的原文信头是“Original Message”或“邮件原件”，但HTML格式的回复没有
    
37.    intOldmsgstart = InStr(Item.Body, "发件人:")
    
38.    ' 如果在邮件国际选项中打开了“答复和转发时邮件头使用英语”，则应该搜索英文信头
    
39.    ' intRes作为临时变量
    
40.    intRes = InStr(Item.Body, "From:")
    
41.    ' 对于多次回复和转发又有多种语言的情况，总是选择最上一封
    
42.    If intRes > 0 Then
    
43.        If (intOldmsgstart = 0) Or (intOldmsgstart > 0 And intRes < intOldmsgstart) Then
    
44.            intOldmsgstart = intRes
    
45.        End If
    
46.    End If
    
47.    
    
48.     If intOldmsgstart = 0 Then
    
49.        ' 不是Re/Fw的邮件则搜索邮件全文和主题
    
50.        strThismsg = Item.Body + " " + Item.Subject
    
51.     Else
    
52.        ' 是Re/Fw的邮件则只搜索用户写的部分和邮件主题
    
53.        strThismsg = Left(Item.Body, intOldmsgstart) + " " + Item.Subject
    
54.     End If
    
55.    
    
56.    ' 搜索邮件正文（和主题）中所有可能提示邮件需要附件的词
    
57.     For i = LBound(sSearchStrings) To UBound(sSearchStrings)
    
58.        If InStr(LCase(strThismsg), sSearchStrings(i)) > 0 Then
    
59.            bFoundSearchstring = True
    
60.            Exit For
    
61.        End If
    
62.    Next i
    
63.    
    
64.     If bFoundSearchstring Then
    
65.        If Item.Attachments.Count = 0 Then
    
66.            strMsg = "您的邮件可能缺少附件！" & vbCrLf & "是否仍要发送？"
    
67.            intRet = MsgBox(strMsg, vbYesNo + vbDefaultButton2 + vbExclamation, "缺少附件")
    
68.            If intRet = vbNo Then
    
69.                Cancel = True
    
70.                Exit Sub
    
71.            End If
    
72.        End If
    
73.    End If
    
74. End Sub

复制代码

lx105834038

有时候我们不想立即发送邮件，希望推出一点时间反悔。
但是设置规则中推迟都是分钟级别的，有太长，那么能不能推迟比如20秒呢？答案的人是可以的。
在执行以上的提醒后，在末尾加上以下代码即可实现推迟20S发送的效果。

1. '延时发送邮件
   
2. Dim d
   
3. d = 20
   
4. tip = "是否延时" & d & "秒后发送邮件？" & vbCrLf & _
   
5.          "说明：点是延时，点否立即发送。 "
   
6. If MsgBox(tip, vbYesNo) = vbYes Then
   
7.     t = DateAdd("s", d, Now)
   
8.     Item.DeferredDeliveryTime = t
   
9. End If
   

复制代码

会阁

没看懂怎么设置忘记发附件的提醒。

lx105834038

会阁 发表于 2022-1-26 14:33
没看懂怎么设置忘记发附件的提醒。

使用方法：
Alt+F11→在ThisOutlookSession中复制以下代码→保存
提醒：其他版本的建议保存后重启OUTLOOK，或者关闭时提醒宏保存的点击保存。

使用方法说了啊。后面发邮件的时候会触发这个宏。