VBA实现Outlook自动发送带附件带签名的工作周报

' 闲话少说 直接上代码：

Sub zhoubao()

    
    Dim outapp As Object
    Dim outmail As Object
    Dim body As String
    Dim fname As String

    Set outapp = CreateObject("Outlook.Application")
    
    '不使用模板
    'Set outmail = outapp.CreateItem(0)
    '使用模板
    Set outmail = outapp.CreateItemFromTemplate("C:\Users\Administrator\AppData\Roaming\Microsoft\Templates\2014年周工作总结与安排(周海清).oft")
    
    
    '附件
    fname = "D:\E\workspaces\3_公司\2_上报公司\1_工作周报\2014年周工作总结与安排(周海清).xlsx"
    '正文
    body = "<H3><B>Hi ,</B></H3>" & _
              "Please see attached!<br>" & _
              "<br><br><B></B>" & _
              GetSignature()
    
    
    
    On Error Resume Next
    With outmail
        .To = "xxx@chenzhimr.com"                 '收件人
        .CC = "xx@czcinfo.com"              '抄送人
        .BCC = ""                    '密送人
        .Subject = "2014年周工作总结与安排(周海清)——" & Now             '标题
        .HTMLBody = body   '.body = body
        .Attachments.Add fname
        .Send   'or use .Display
    End With
    On Error GoTo 0
    
    MsgBox ("Sent successfully!")
    

    
    Set outmail = Nothing
    Set outapp = Nothing
    
    
    
ErrMsg:
    
    MsgBox (Err.Description)




    
End Sub




Public Function GetSignature()


Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
SigPath = "C:\Users\Administrator\AppData\Roaming\Microsoft\Signatures\标准_CN.htm"
Set f_SignatureObj = fso.OpenTextFile(SigPath, 1, False, 0)

GetSignature = f_SignatureObj.ReadAll

f_SignatureObj.Close
Set fso = Nothing

End Function