搬家第25天-Citect V7.4 CitectVBA 利用excel宏和CDO发邮件

我们使用citect采集了现场数据形成报表后，有时候需要把数据定时发电子邮件给某些人。微软的CDO组件支持邮件发送功能，我在学习citectVBA发邮件时，经历了一些波折，我在这篇博客把这些学习过程下来。

      我的想法是点击画面上的按钮，后台脚本用一个qq信箱给一个126信箱发一封电子邮件，不需要打开浏览器登录信箱，也不需要打开outlook灯邮箱工具。

      首先呢，QQ信箱默认没有开通第三方工具发送邮件的功能，需要登录信箱设置一下。

点击设置后，选择“账户”，开通POP3/SMTP服务，qq信箱要设置这个服务需要通过手机发送短信来获取授权码，这个授权码一会需要用到。

第一次，我在cicode编辑器中用citectVBA写以下代码，运行没有效果，可以跳过这一步不看。

Sub VBASendmail()
    Dim msg As Object
    Dim eul As String
    Set msg = CreateObject("CDO.Message")
    msg.From = "12345@qq.com"  '发件人信箱
    msg.To = "54321@126.com"  '收件人信箱
    'msg.CC = "23456@126.com"                        '设置抄送的邮箱
    'msg.BCC = "34567@126.com"                       '设置密送的邮箱
    msg.Subject = "这是一份测试邮件"
    msg.textbody = "这是测试邮件正文"
   msg.AddAttachment "c:\path.txt"  '附件
    eul = "http://schemas.microsoft.com/cdo/configuration/"
    With msg.Configuration.Fields
       .Item(eul & "smtpserver") = "smtp.qq.com"
       .Item(eul & "smtpserverport") = 465 'SMTP端口号
       .Item(eul & "sendusing") = 2  '端口号
       .Item(eul & "smtpauthenticate") = 1 '需要用户名和密码
       .Item(eul & "smtpusessl") = 1        
       .Item(eul & "sendusername") = "12345@qq.com" '发件人信箱
       .Item(eul & "sendpassword") = "asdfghjklqwertyu" '这个是授权码,就是前面发手机短信生成的        
       .Item(eul & "smtpconnectiontimeout") = 60
       .Update        
    End With
   msg.Send
    Set msg = Nothing   
End Sub

第一次尝试失败后，我在excel文件sendmail.xlsm中建立宏，把上述代码拷贝进去，然后运行宏，成功了。先在的问题就变成了，在citectVBA中调用excel宏，后台运行发邮件。

在cicode中建立以下CitectVBA代码

Sub RunExcelMacroSendMail()
Dim xlApp As Object
Dim xlwb As Object
Set xlApp=CreateObject("excel.application")
xlApp.Visible=false
Set xlwb = xlapp.WorkBooks.Open("D:\CitectPrj\VBATest\sendmail.xlsm") '带有宏的excel文件路径
xlApp.run "VBASendmail" '发送邮件的宏的名字
xlwb.Close

Set objwb=nothing
xlApp.Quit
Set xlApp=Nothing
End Sub

在画面上添加一个按钮，按钮的鼠标点击事件中写入

civba call RunExcelMacroSendMail()

保存编译运行，点击按钮就能发送邮件了。发送邮件的功能测试好之后，结合报表自动导出为文件，设定事件定时运行citectvba程序，就能定时自动发送邮件了。

标签：25,V7.4,eul,Citect,信箱,Item,msg,com,邮件
来源： https://www.cnblogs.com/fishingsriver/p/14429463.html