在近期專案完成後，有遇到情況：類似於語音報警後，中控室人員未及時報告給我們造成了事件的危害升級，以及造成很不好的影響。針對這個情況特此新增語音報警後，自動傳送郵件提醒，完善現有的報警機制。

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.結果測試

傳送方：

接收方：

測試成功，這樣就在遠距離情況下，也能第一時間從手機郵件提醒中，檢視故障情況，並及時處理。