(求助)有关VBA调用本地签名问题！

cccc5900

大家好。经过前两天大家的帮忙。我终于完成了一个简单的VBA程序。
不过，发现在它缺少邮件签名功能。在网上找了半天。
以下代码可以成功调用本地OUTLOOK签名。但我不会把它合到我的VBA中。试了好多次都失败了


sendemailatt(fina).rar (20.16 KB, 下载次数: 63)

2015-1-22 15:55 上传

点击文件名下载附件

Sub Mail_Outlook_With_Signature_Plain()
' Don't forget to copy the function GetBoiler in the module.
' Working in Office 2000-2010
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim SigString As String
Dim Signature As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "Hi there"
'Use the second SigString if you use Vista or Win 7 as operating system
SigString = "C:\Users\Leroy\AppData\Roaming\Microsoft\Signatures\test.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
With OutMail
.To = "cccc5900@hotmail.com"
.CC = "chen.lei@onsite.brocent.com"
.BCC = ""
.Subject = "This is the Subject line"
.htmlBody = strbody & Signature
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Send   'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function


有人能教我下怎么弄吗？

cccc5900

自己先往上顶俩下！！！

cccc5900

顶啊顶！顶啊顶！

cccc5900

自己顶自己顶自己顶自己顶自己顶自己顶自己顶自己顶

闻启学

cccc5900 发表于 2015-1-22 18:48
自己顶自己顶自己顶自己顶自己顶自己顶自己顶自己顶

1. Function sendemail(ByVal smail As String, ByVal scc As String, ByVal sbcc As String, ByVal ssubject As String, ByVal sbody As String, ByVal sAtt1 As String, ByVal sAtt2 As String, ByVal sAtt3 As String)
   
2.     On Error Resume Next
   
3. 
   
4.     Dim olapp As Object
   
5.     Dim olnamespace As Object
   
6.     Dim olfolder As Object
   
7.     Dim olmail As Object
   
8.     Dim Signature As String
   
9.     Set olapp = CreateObject("outlook.application")
   
10.     Set olnamespace = olapp.getnamespace("mapi")
    
11.     Set olfolder = olnamespace.getdefaultfolder(6)
    
12.     Set olmail = olapp.CreateItem(0)
    
13.     Dim myqianming As String
    
14. 
    
15.     myqianming = "C:\Users\Administrator\AppData\Roaming\Microsoft\Signatures\wdw.txt"
    
16.     With olmail
    
17.         .Subject = ssubject
    
18.         .To = smail
    
19.         .CC = scc
    
20.         .BCC = sbcc
    
21.         myqianming = Module4.GetBoiler(myqianming)
    
22.         .HTMLBody = sbody & "<br />" & myqianming
    
23.         .BodyFormat = olFormatHTML  '//设置邮件格式 是否html 格式的
    
24.         .attachments.Add sAtt1
    
25.         .attachments.Add sAtt2
    
26.         .attachments.Add sAtt3
    
27.         .send
    
28.     End With
    
29. 
    
30. End Function
    
31. 
    
32. 
    
33. Function GetBoiler(ByVal sFile As String) As String
    
34. 
    
35. '//sFile  邮件签名的 所在文件
    
36.     Dim fso As Object
    
37.     Dim ts As Object
    
38. 
    
39.     Set fso = CreateObject("Scripting.FileSystemObject")
    
40. 
    
41.     If fso.FileExists(sFile) Then    '//文件存在的就打开文件 获得签名的文字
    
42.         Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    
43.         GetBoiler = ts.readall
    
44.         ts.Close
    
45. 
    
46.     Else
    
47.         '// 不存在的 返回空值
    
48. 
    
49.         GetBoiler = ""
    
50.     End If
    
51. 
    
52. End Function
    

复制代码

改一下  更新代码

cccc5900

闻启学 发表于 2015-1-22 22:59
改一下  更新代码

谢了！！！我下班回家就更新试试！
我就是不明白， 为什么有的发邮件脚本用到FUNCTION。有的就不用。正在读新手入门！

cccc5900

闻启学 发表于 2015-1-22 22:59
改一下  更新代码

感谢大神！
现在有签名了！
但图片显示不出来，我再好好检查代码吧。
谢谢了！！！

闻启学

cccc5900 发表于 2015-1-23 11:18
谢了！！！我下班回家就更新试试！
我就是不明白， 为什么有的发邮件脚本用到FUNCTION。有的就不用。正在 ...

有什么好纠结的 各施各法 各庙各菩萨    每人的习惯不同

闻启学

cccc5900 发表于 2015-1-23 22:57
感谢大神！
现在有签名了！
但图片显示不出来，我再好好检查代码吧。

txt 文件是不能存放图片的 不用检查

你试一试提取html 文件吧  估计都不行

cccc5900

闻启学 发表于 2015-1-23 23:09
txt 文件是不能存放图片的 不用检查

你试一试提取html 文件吧  估计都不行

试了，果然！就是图片显示不出来。
Sub send()
    Dim strbody As String, strsubject As String
    Dim strmail As String, strcc As String, strbcc As String
    Dim stratt1 As String, stratt2 As String, stratt3 As String
   
   
    With ActiveSheet
        strmail = .Range("F4")
        strcc = .Range("f5")
        strbcc = .Range("f6")
        strsubject = .Range("F7")
        strbody = .Range("F8")
        stratt1 = .Range("f9")
        stratt2 = .Range("f10")
        stratt3 = .Range("f11")
        
    End With
    sendemail strmail, strcc, strbcc, strsubject, strbody, stratt1, stratt2, stratt3
    MsgBox "complete", vbInformation + vbOKOnly, "note"
End Sub
    Function sendemail(ByVal smail As String, ByVal scc As String, ByVal sbcc As String, ByVal ssubject As String, ByVal sbody As String, ByVal sAtt1 As String, ByVal sAtt2 As String, ByVal sAtt3 As String)
    On Error Resume Next
   
    Dim olapp As Object
    Dim olnamespace As Object
    Dim olfolder As Object
    Dim olmail As Object
    Dim signature As String
    Set olapp = CreateObject("outlook.application")
    Set olnamespace = olapp.getnamespace("mapi")
    Set olfolder = olnamespace.getdefaultfolder(6)
    Set olmail = olapp.createitem(0)
    Dim mysign As String
    mysign = "C:\Users\Ray\AppData\Roaming\Microsoft\Signatures\test.htm"
   
    With olmail
        .Subject = ssubject
        .to = smail
        .cc = scc
        .bcc = sbcc
        mysign = getboiler(mysign)
        .BodyFormat = olFormatHTML
        .HTMLBody = sbody & "<br />" & mysign
        .attachments.Add sAtt1
        .attachments.Add sAtt2
        .attachments.Add sAtt3
        .send
    End With
   
    End Function

Function getboiler(ByVal sfile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("scripting.filesystemobject")
If fso.fileexists(sfile) Then
Set ts = fso.getfile(sfile).openastextstream(1, -2)
getboiler = ts.readall
ts.Close
Else
getboiler = ""
End If

End Function
如果把 ON ERROR RESUME NEXT去掉。.BodyFormat = olFormatHTML就被标黄了，
现在不知道是什么问题。应该可以发有图片的签名吧？VBA这么强大，不应该不能啊？