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

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 Boolean

On 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 With

Set objMessage = New CDO.Message '

Set objMessage.Configuration = objConfig

'The Mail Cc
If IsNull(strCc) Then
Else
    objMessage.CC = strCc
End If

With objMessage
    .To = strTo
    .From = strFrom  '"Display Name "
    .Subject = strSubject  '"SMTP Relay Test"
    .TextBody = strMailText  '"SMTP Relay Test Sent @ " & Now()
    .Send
End With

Set Fields = Nothing
Set objMessage = Nothing
Set objConfig = Nothing
    Exit Function
ErrorHandler:
    MsgBox "Error!" & vbCrLf & "ErrorNumber:" & vbCrLf & "Error Description:" & Err.Description
    Resume Next
End Function

主要添加了一条使用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 = name

Dim 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, "", True

End Sub

发送方：

接收方：

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

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