Intouch/ifix语音报警系统制作(4-自动发送邮件提醒)

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

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 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) = "用户名" '"[email protected]"
    .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

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 = 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("[email protected]", "[email protected]", "泵站", mail) = True Then
End If
openpicture tt, "", TOP, LEFT, 0, , NONE, "", True

End Sub

3.结果测试

发送方：

接收方：

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

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