VBA实现outlook的签名日期可以自动更新

hydrant

采用脚本生成签名的方式，二不是使用outlook自带的签名。
    Outlook 支持签名，但是使用Word域方式在签名中加入日期，不能在创建邮件的时候自动更新为当前系统日期，必须按F9来更新，感觉很不方便，因为我用VBA写了一段脚本自动更具用户的需求添加签名内容，日期可以实现自动提取当前日期。

    注意：

    outlook的宏安全性必须设置为低

    如果谁感兴趣可以按照下面的方式操作：

    1.打开outlook，取消原来设置的签名

    2.按照菜单（工具－宏－Visual Basic 编辑器）

    3.在出现的编辑器，从左边选择：ThisOutlookSession，右边默认应该是空白。

    4.将下面的代码复制到右边：  '------------------------------------------------------------------

Dim myOlApp As New Outlook.Application

Private WithEvents myOlInspectors As Outlook.Inspectors

Private myMailItem As Outlook.MailItem

Function Signature() As String

Dim mDate As Date

mDate = Format(Now, "yyyy-MM-dd")

Signature = "<font size=2>"

Signature = Signature & "<p>&nbsp;</p>"

Signature = Signature & "<p style=""""font-size: 10px"""">" & mDate & " <br />"

Signature = Signature & "致礼！</p>"

Signature = Signature & "<p style=""""font-size: 10px"""">尚德明<br />"

Signature = Signature & "//---------------------------------------------------------------<br />"

Signature = Signature & "&nbsp;德国倍福自动化有限公司上海代表处<br />"

Signature = Signature & " ADD.:&nbsp;上海市江场三路市北工业园区163 号5楼（200436 &nbsp;）<br />"

Signature = Signature & " TEL: &nbsp;&nbsp; 021-66312666-837 <br />"

Signature = Signature & " FAX: &nbsp;&nbsp; 021-66315696 <br />"

Signature = Signature & " MAIL:&nbsp;&nbsp; <a href=""""mailto:d.shang@beckhoff.com.cn"""">d.shang@beckhoff.com.cn </a> <br />"

Signature = Signature & " Web:&nbsp;&nbsp; <a href=""""http://www.beckhoff.com.cn/""""> www.beckhoff.com.cn </a><br />"

Signature = Signature & " &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <a href=""""http://www.pc-control.net/""""> www.pc-control.net </a><br />"

Signature = Signature & " &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <a href=""""http://www.ethercat.org/""""> www.ethercat.org </a>&nbsp; </p>"

Signature = Signature & "<span >//---------------------------------------------------------------</span>"

Signature = Signature & "</font> "

End Function

Private Sub Application_Startup()

'GetSignature

Set myOlInspectors = myOlApp.Inspectors

End Sub

Private Sub myOlInspectors_NewInspector(ByVal Inspector As Inspector)

Set myMailItem = Inspector.CurrentItem

With myMailItem

.HTMLBody = Signature()

.Display‘如果是outlook 2007 将此行注释掉

End With

End Sub

'----------------------------------------------------------------------------------



    中间部分是签名的HTML内容，可以修改为自己需要设置的。

    5.保存，退出。重新启动outlook，将工具－宏－安全性中设置为低

    以后新建邮件将会用代码中设置的签名内容


文章转载自网管之家：http://www.bitscn.com/pdb/dotnet/200904/160922.html

Admin

   

很遗憾通知楼上朋友，您的帖子在24小时之内没有任何回复！

通常情况下，本论坛发布的主题帖会在8小时被回复或处理。您的帖子在24小时之内未被回复，其中的原因可能是：

1、问题表述不清、模棱两可，难以理解，帮助者被搞晕了，夺帖而出；
2、没有上传必要的附件，或附件被遗忘在某个角落；
3、发帖提问时，语气带棱角、带挑衅，不幸被列入不受欢迎的帖子；
4、所提问题不成立，或提不合理的要求，乐于助人者使出“走为上”之计；
5、话题较偏、较冷或者发布到了不合适的版块，暂时无人问津，顾影自怜。


为了提高您的问题解决效率，我们推荐您阅读以下文章：
* 如何发表新话题和上传附件：http://club.excelhome.net/thread-45649-1-1.html
* 发帖的技巧：http://club.excelhome.net/thread-176339-1-1.html
* EH技术论坛的最佳学习方法：http://club.excelhome.net/thread-117862-1-1.html

gz_wu

很好的一个VBA，

PS：
.Display‘如果是outlook 2007 将此行注释掉
应该是OL2003时注释掉这一句？我的是2003，要注释掉这一句后才能用。

还有：
当我将上述VBA与下述VBA共存时，则上述VBA不能用，不知道是什么原因？
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim lngres As Long
If InStr(1, UCase(Item.Body), "附件") Or InStr(1, UCase(Item.Body), "附档") <> 0 Then
If Item.Attachments.Count = 0 Then
lngres = MsgBox("邮件内容中包含'附件', 但是没有发现附件 – 仍然发送?", _
vbYesNo + vbDefaultButton2 + vbQuestion, "你要求我向你提示...")
If lngres = vbNo Then Cancel = True
End If
End If
End Sub
Sub olAddAttachedFileTitle()
Dim mFileName, mSubject As String
Dim iPos As Integer
Dim i As Integer
Set CurrentMail = ActiveInspector.CurrentItem
If TypeName(CurrentMail) <> "MailItem" Then
    MsgBox "当前活动窗口不是一封邮件"
Else
    If CurrentMail.Attachments.Count > 0 Then '必须是在有附件的情况下
        For Each Item In CurrentMail.Attachments
            mFileName = Item.FileName '取得附件文件名称（包括后缀）
            mLen = Len(mFileName) '取得名称长度
            For i = mLen To 1 Step -1
                If Mid(mFileName, i, 1) = "." Then
                    iPos = i '.的位置
                End If
            Next i
            iPos = iPos - 1
            mFileName = Left(mFileName, iPos) '去掉了后缀的文件名称
            If mSubject = "" Then
                mSubject = mFileName
            Else
                mSubject = mSubject & ", " & mFileName
            End If
        Next
        CurrentMail.Subject = mSubject '把得到的名称写入邮件主题
    Else
        MsgBox "当前邮件没有附件"
    End If
End If
End Sub


另外，上述VBA签名能否设置相应的格式和字体？

yghj03050523

对啊，2003outlook要去掉｛.Display‘如果是outlook 2007 将此行注释掉｝才行。
同问，怎么设置字体颜色和大小

wjl96236

楼主,好像不行,都不会自动插入签名

开心萝卜惠州

新建邮件时可以了，但读取邮件时正文内容也变成签名了，该如何解决，还请指点。

s_on

开心萝卜惠州 发表于 2011-11-16 22:03
新建邮件时可以了，但读取邮件时正文内容也变成签名了，该如何解决，还请指点。

我的也是这样，请问你解决了吗？

开心萝卜惠州

s_on 发表于 2012-3-20 15:10
我的也是这样，请问你解决了吗？

没有解决，还是手工输输