Option ExplicitPrivate SmsCommFlag As Boolean '到短消息服务器的通讯状态标志，TRUE--通讯正常，FALSE--通讯失败 Private SmsCenterIP As String, SmsCenterPort As String '短消息发送服务器IP地址及端口号 Private SmsString As String Dim rs As New ADODB.Recordset Dim conn As New ADODB.Connection Dim MaxID As IntegerPrivate Sub CmdChange_Click()
Open App.Path + "\SMS.INI" For Output As SmsFile Print #SmsFile, "SmsCenterIP=" + Trim(Me.SmsCenterIPText.Text) Print #SmsFile, "SmsCenterPort=" + Trim(Me.SmsCenterPortText.Text) Close SmsFile
Label14.ForeColor = vbRed Label14.Caption = "失败！"
TestSmsComm.Connect
End SubPrivate Function isNumber(ByVal rText As String)On Error GoTo NotNumber Dim tmp As Double
tmp = CDbl(rText) / 10000 isNumber = True
Exit Function
NotNumber: isNumber = False
End FunctionPrivate Sub MakeSmsString(ByRef rSmsString As String)'生成发送到短消息服务器的消息串，格式为：'包的总长度 4 不包括本域，不足4位左补0，有中文字符时每个中文字符长度为2个 '保留 5 FFFFF '手机长度 2 '手机号 不定长 '短信的长度 3 左补0，有中文字符时每个中文字符长度为2 '短信内容 不定长 '分配给各个客户ID 3 '短信的区别ID 12 YYMMDD＋6位流水号，这里以时间为流水号 '收费标志位 1 0 '收费代码的长度 4 04 '收费代码 4 01：对"计费用户号码"免费 ' 02：对"计费用户号码"按条计信息费 ' 03：对"计费用户号码"按包月收取信息费 ' 固定为HYMF Dim SmsLen As Integer, TotalLen As Integer, SmsID As String, SmsStr As String
TestSmsComm.Connect '循环等待连接短消息发送服务器成功 Do While Not SmsCommFlag DoEvents Loop
If SmsCommFlag Then Me.Label14.ForeColor = vbGreen Me.Label14.Caption = "成功！" End IfEnd SubPrivate Sub GetSmsCenterPara(ByRef rSmsCenterIp As String, _ ByRef rSmsCenterPort As String)
'从SMS.INI中取短消息服务器IP及端口号，如文件不存在，返回空 Dim Fso, SmsFile As Integer, tmpStr As String, pos As Integer
rSmsCenterIp = "": rSmsCenterPort = ""
Set Fso = CreateObject("Scripting.FileSystemObject") If Fso.FileExists(App.Path + "\SMS.INI") Then SmsFile = FreeFile
Open App.Path + "\SMS.INI" For Input As SmsFile
Do While Not EOF(SmsFile) Line Input #SmsFile, tmpStr
If InStr(UCase(tmpStr), "SMSCENTERIP=") Then pos = InStr(UCase(tmpStr), "=") rSmsCenterIp = Mid(tmpStr, pos + 1) End If
If InStr(UCase(tmpStr), "SMSCENTERPORT=") Then pos = InStr(UCase(tmpStr), "=") rSmsCenterPort = Mid(tmpStr, pos + 1) End If
End SubPrivate Sub PhoneNo_GotFocus() Label4.Caption = "" End SubPrivate Sub SmsCenter_Connect() '连接短消息发送服务器成功后发送数据 SmsCenter.SendData SmsString ' SendContent.Text = SmsString End SubPrivate Sub SmsCenter_DataArrival(ByVal bytesTotal As Long) Dim str As String Dim sql As String Dim msg() As String SmsCenter.GetData str 'SendResult.Text = PhoneNo.Text + str If str = "***" Then SmsCenter.Close Else msg = Split(str, "#*#") sql = "select * from ly_archives" rs.Open sql, conn, 3, 2 rs.AddNew rs("LyID") = msg(0) rs("Content") = msg(2) rs("holdset") = msg(1) rs("b_time") = msg(3) rs("Status") = 0 rs.Update rs.Close MaxID = msg(0) End If End SubPrivate Sub SmsCenter_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean) '连接短消息发送服务器失败时禁止弹出式提示信息，启动尝试连接程序 CancelDisplay = True SmsCommFlag = False
Me.Label14.ForeColor = vbGreen Me.Label14.Caption = "成功！" ' TestSmsComm.SendData SmsString End SubPrivate Sub TestSmsComm_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)'在连接短消息服务器时出现错误 CancelDisplay = True TestSmsComm.Close SmsCommFlag = False TestSmsTimer.Enabled = True
End SubPrivate Sub TestSmsTimer_Timer() '当到短消息服务器的连接中断时，尝试重新连接
If TestSmsComm.RemoteHost <> "" And TestSmsComm.RemotePort > 0 Then TestSmsComm.Close
m_sock.Connect IP, Port
Private SmsCenterIP As String, SmsCenterPort As String '短消息发送服务器IP地址及端口号
Private SmsString As String
Dim rs As New ADODB.Recordset
Dim conn As New ADODB.Connection
Dim MaxID As IntegerPrivate Sub CmdChange_Click()
Dim SmsFile As Integer
SmsCenter.RemoteHost = SmsCenterIPText.Text
SmsCenter.RemotePort = SmsCenterPortText.Text
TestSmsComm.Close
TestSmsComm.RemoteHost = SmsCenterIPText.Text
TestSmsComm.RemotePort = SmsCenterPortText.Text
SmsFile = FreeFile
Open App.Path + "\SMS.INI" For Output As SmsFile Print #SmsFile, "SmsCenterIP=" + Trim(Me.SmsCenterIPText.Text)
Print #SmsFile, "SmsCenterPort=" + Trim(Me.SmsCenterPortText.Text) Close SmsFile
Label14.ForeColor = vbRed
Label14.Caption = "失败！"
TestSmsComm.Connect
End SubPrivate Function isNumber(ByVal rText As String)On Error GoTo NotNumber Dim tmp As Double
tmp = CDbl(rText) / 10000
isNumber = True
Exit Function
NotNumber:
isNumber = False
End FunctionPrivate Sub MakeSmsString(ByRef rSmsString As String)'生成发送到短消息服务器的消息串，格式为：'包的总长度 4 不包括本域，不足4位左补0，有中文字符时每个中文字符长度为2个
'保留 5 FFFFF
'手机长度 2
'手机号 不定长
'短信的长度 3 左补0，有中文字符时每个中文字符长度为2
'短信内容 不定长
'分配给各个客户ID 3
'短信的区别ID 12 YYMMDD＋6位流水号，这里以时间为流水号
'收费标志位 1 0
'收费代码的长度 4 04
'收费代码 4 01：对"计费用户号码"免费
' 02：对"计费用户号码"按条计信息费
' 03：对"计费用户号码"按包月收取信息费
' 固定为HYMF Dim SmsLen As Integer, TotalLen As Integer, SmsID As String, SmsStr As String
SmsLen = LenB(StrConv("ly", vbFromUnicode))
SmsID = Format(MaxID, "000000000000")
SmsStr = "FFFFF" + "11" + "8613611111111" + Format(SmsLen, "000") + "ly" + "123" + SmsID + "0" + "04" + "HYMF"
TotalLen = LenB(StrConv(SmsStr, vbFromUnicode))
rSmsString = Format(TotalLen, "0000") + SmsStrEnd SubPrivate Sub Form_Load()
Dim str As String
str = "select max(lyid) from ly_archives"
conn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" + VB.App.Path + "\zhly.mdb;Persist Security Info=False"
conn.Open
rs.Open str, conn, adOpenKeyset
If rs.RecordCount = 0 Then
MaxID = 0
Else
MaxID = rs.Fields(0)
End If
rs.Close
If App.PrevInstance Then
MsgBox App.EXEName & "程序已经运行！", 48 '给出程序已运行的提示和一惊叹号以示警告
End
End If Me.Show
'从SMS.INI中取短消息服务器IP地址及端口号
GetSmsCenterPara SmsCenterIP, SmsCenterPort
SmsCenter.RemoteHost = SmsCenterIP
SmsCenter.RemotePort = SmsCenterPort
TestSmsComm.RemoteHost = SmsCenterIP
TestSmsComm.RemotePort = SmsCenterPort
Label14.ForeColor = vbRed
Label14.Caption = "失败！"
SmsCommFlag = False
TestSmsComm.Connect '循环等待连接短消息发送服务器成功
Do While Not SmsCommFlag
DoEvents
Loop
If SmsCommFlag Then
Me.Label14.ForeColor = vbGreen
Me.Label14.Caption = "成功！"
End IfEnd SubPrivate Sub GetSmsCenterPara(ByRef rSmsCenterIp As String, _
ByRef rSmsCenterPort As String)
'从SMS.INI中取短消息服务器IP及端口号，如文件不存在，返回空 Dim Fso, SmsFile As Integer, tmpStr As String, pos As Integer
rSmsCenterIp = "": rSmsCenterPort = ""
Set Fso = CreateObject("Scripting.FileSystemObject")
If Fso.FileExists(App.Path + "\SMS.INI") Then
SmsFile = FreeFile
Open App.Path + "\SMS.INI" For Input As SmsFile
Do While Not EOF(SmsFile)
Line Input #SmsFile, tmpStr
If InStr(UCase(tmpStr), "SMSCENTERIP=") Then
pos = InStr(UCase(tmpStr), "=")
rSmsCenterIp = Mid(tmpStr, pos + 1)
End If
If InStr(UCase(tmpStr), "SMSCENTERPORT=") Then
pos = InStr(UCase(tmpStr), "=")
rSmsCenterPort = Mid(tmpStr, pos + 1)
End If
DoEvents
Loop
Close SmsFile
End If
Set Fso = Nothing
SmsCenterIPText.Text = rSmsCenterIp
SmsCenterPortText.Text = rSmsCenterPort
End SubPrivate Sub PhoneNo_GotFocus()
Label4.Caption = ""
End SubPrivate Sub SmsCenter_Connect()
'连接短消息发送服务器成功后发送数据 SmsCenter.SendData SmsString
' SendContent.Text = SmsString
End SubPrivate Sub SmsCenter_DataArrival(ByVal bytesTotal As Long)
Dim str As String
Dim sql As String
Dim msg() As String
SmsCenter.GetData str
'SendResult.Text = PhoneNo.Text + str
If str = "***" Then
SmsCenter.Close
Else
msg = Split(str, "#*#")
sql = "select * from ly_archives"
rs.Open sql, conn, 3, 2
rs.AddNew
rs("LyID") = msg(0)
rs("Content") = msg(2)
rs("holdset") = msg(1)
rs("b_time") = msg(3)
rs("Status") = 0
rs.Update
rs.Close
MaxID = msg(0)
End If
End SubPrivate Sub SmsCenter_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
'连接短消息发送服务器失败时禁止弹出式提示信息，启动尝试连接程序 CancelDisplay = True
SmsCommFlag = False
Err.Clear
' SendResult.Text = PhoneNo.Text + " 发送失败！"
TestSmsTimer.Enabled = TrueEnd SubPrivate Sub TestSmsComm_Connect()
'成功连接到短消息发送服务器 SmsCommFlag = True
TestSmsComm.Close
' TestSmsTimer.Enabled = False
Me.Label14.ForeColor = vbGreen
Me.Label14.Caption = "成功！"
' TestSmsComm.SendData SmsString
End SubPrivate Sub TestSmsComm_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)'在连接短消息服务器时出现错误 CancelDisplay = True
TestSmsComm.Close
SmsCommFlag = False
TestSmsTimer.Enabled = True
End SubPrivate Sub TestSmsTimer_Timer()
'当到短消息服务器的连接中断时，尝试重新连接
If TestSmsComm.RemoteHost <> "" And TestSmsComm.RemotePort > 0 Then
TestSmsComm.Close
Me.Label14.ForeColor = vbRed
Me.Label14.Caption = "失败！尝试连接中..."
If Not SmsCommFlag And TestSmsComm.State = sckClosed Then
TestSmsComm.Connect
Else
MakeSmsString SmsString
SmsCenter.Connect
End If
End If
End Sub
Private Sub Form_Terminate()
Unload Me
End
End SubPrivate Sub Form_Unload(Cancel As Integer)
Unload Me
End
End Sub