在近期项目完成后，有遇到情况：类似于语音报警后，中控室人员未及时报告给我们造成了事件的危害升级，以及造成很不好的影响。针对这个情况特此添加语音报警后，自动发送邮件提醒，完善现有的报警机制。

1.函数编写（选自网友脚本）

Option Explicit
'需要引用  Microsoft CDO for Windows 2000 Library和 Microsoft ActiveX Data Objects 2.5 Library
Public Function SendMail(ByVal strFrom As String, _ByVal strTo As String, _ByVal strSubject As String, _ByVal strMailText As String, _Optional ByVal strCc As String = "") As BooleanOn Error GoTo ErrorHandler:Const cdoSendUsingMethod = _"http://schemas.microsoft.com/cdo/configuration/sendusing"
Const cdoSendUsingPort = 2
Const cdoSMTPServer = _"http://schemas.microsoft.com/cdo/configuration/smtpserver"
Const cdoSMTPServerPort = _"http://schemas.microsoft.com/cdo/configuration/smtpserverport"
Const cdoSMTPConnectionTimeout = _"http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout"
Const cdoSMTPAuthenticate = _"http://schemas.microsoft.com/cdo/configuration/smtpauthenticate"
Const cdoBasic = 1
Const cdoSendUserName = _"http://schemas.microsoft.com/cdo/configuration/sendusername"
Const cdoSendPassword = _"http://schemas.microsoft.com/cdo/configuration/sendpassword"Dim objConfig   As CDO.Configuration
Dim objMessage  As CDO.Message
Dim Fields      As ADODB.Fields' Get a handle on the config object and it's fields
Set objConfig = New CDO.Configuration
Set Fields = objConfig.Fields' Set config fields we care about
With Fields.Item(cdoSendUsingMethod) = cdoSendUsingPort.Item(cdoSMTPServer) = "邮件发送服务器地址" '"smtp.chinawiser.com".Item(cdoSMTPServerPort) = 25 '端口，默认为25.Item(cdoSMTPConnectionTimeout) = 30.Item(cdoSMTPAuthenticate) = cdoBasic.Item(cdoSendUserName) = "用户名" '"test@chinawiser.com".Item(cdoSendPassword) = "密码" '"test".Update
End WithSet objMessage = New CDO.Message 'Set objMessage.Configuration = objConfig'The Mail Cc
If IsNull(strCc) Then
ElseobjMessage.CC = strCc
End IfWith objMessage.To = strTo.From = strFrom  '"Display Name ".Subject = strSubject  '"SMTP Relay Test".TextBody = strMailText  '"SMTP Relay Test Sent @ " & Now().Send
End WithSet Fields = Nothing
Set objMessage = Nothing
Set objConfig = NothingExit Function
ErrorHandler:MsgBox "Error!" & vbCrLf & "ErrorNumber:" & vbCrLf & "Error Description:" & Err.DescriptionResume Next
End Function

2.运用语音触发

主要添加了一条使用sendmail函数脚本（其余不变）

Public Sub Sound(ByVal name As String, ByVal tt As String, ByVal sql As String)
On Error Resume Next
Dim workspace As Object
Set workspace = GetObject("", "Workspace.Application")
Dim tagvar As Object
Set tagvar = workspace.Documents("User").Page.FindObject("PicNumBer")
tagvar.Description = nameDim mail As String
mail = name + sql
Dim TOP As Integer
Dim LEFT As Integer
TOP = Int((50 * Rnd) + 1)
LEFT = Int((50 * Rnd) + 1)Dim StrD As String
Dim userid As String
Dim username As String
Dim groupname As String
System.FixGetUserInfo userid, username, groupname
StrD = Format(Now, "yyyy-mm-dd hh:mm:ss")
Set conODBC = New ADODB.Connection
conODBC.ConnectionString = "DSN=QPBZ;UID=sa;PWD=;"
conODBC.Open "QPBZ", "sa", ""
conODBC.Execute "insert into shijianjilu (DateTimee,mingcheng,neirong,operator) values ('" + StrD + "','" + name + "', '" + sql + "', '" + username + "')"
conODBC.Close
If SendMail("xxxx@163.com", "xxxxx@qq.com", "泵站", mail) = True Then
End If
openpicture tt, "", TOP, LEFT, 0, , NONE, "", TrueEnd Sub

3.结果测试

发送方：

接收方：

测试成功，这样就在远距离情况下，也能第一时间从手机邮件提醒中，查看故障情况，并及时处理。

接下来，准备将数据上阿里云，然后对接微信小程序，实现真正的报警推送机制。