tc35.cls

西门子TC35源程序

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "TC35"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Dim v_ErrMsg          As String '当前的错误信息
Dim v_IsInit          As Boolean   '是否已经初始化
Dim v_MSComm          As MSCommLib.MSComm '所用的串口对像
Dim v_ServiceTelphone As String '短信服务器中心呈码


'以下三个变量用于控制异步事件
Dim v_bExit         As Boolean
Dim v_StartTimes    As Long '执行执行的开始时间
Dim v_Msg           As String '发送的SM内容
Dim v_Telphone      As String '发送的电话号码
Dim v_LastHappenTime   As Date '最后尝试的时间

Dim v_Para1          As String '系统参数
Dim v_Para2          As String '系统参数
Dim v_Para3          As String '系统参数
Dim v_Key            As String '系统参数

Const MAXSENDTIME = 9000  '发送一条SM的最长时间9秒
Const SUFX = "000800"

Public Enum EventStatus '定义事件状态
      STATUS_SENDING = 1 '正在发送
      STATUS_GETTING = 2 '正在读取数据
      STATUS_SENDED = 2  '发送完成
      STATUS_OK = 3    '发送OK
      STATUS_UNKNOWS = 0 '状态未知
      STATUS_ERROR = 4 '发送出错
      STATUS_OUTTIME = 5 '获取超时
      STATUS_BREAK = 6 '获取超时
End Enum

Public Event ChangeStatus(ByVal Status As EventStatus) '定义事件

'取得短信内容
Public Property Get Msg() As String
   Msg = v_Msg
End Property


'设置发送的短信内容
Public Property Let Msg(ByVal newValue As String)
    v_Msg = newValue
End Property


'取得短信内容
Public Property Get Key() As String
   Key = v_Key
End Property


'设置发送的短信内容
Public Property Let Key(ByVal newValue As String)
    v_Key = newValue
End Property


'取得接收的电话号码
Public Property Get Telphone() As String
   Telphone = v_Telphone
End Property


'设置短信发送的接收号码
Public Property Let Telphone(ByVal newValue As String)
    v_Telphone = newValue
End Property


'当前操作的错误信息
Public Property Get LastHappenTime() As Date
    LastHappenTime = v_LastHappenTime
End Property

'当前相关的参数1值
Public Property Get Para1() As String
    Para1 = v_Para1
End Property

'设置操作的参数1
Public Property Let Para1(ByVal newValue As String)
    v_Para1 = newValue
End Property


'取得当前的参数2值
Public Property Get Para2() As String
    Para2 = v_Para2
End Property

'当前操作的Para2值
Public Property Let Para2(ByVal newValue As String)
    v_Para2 = newValue
End Property


'当前操作的错误信息
Public Property Get Para3() As String
    Para3 = v_Para3
End Property


'当前操作的错误信息
Public Property Let Para3(ByVal newValue As String)
    v_Para3 = newValue
End Property



'当前操作的错误信息
Public Property Get ErrMsg() As String
    ErrMsg = v_ErrMsg
End Property

'初始化是否成功
Public Property Get IsInit() As Boolean
    IsInit = v_IsInit
End Property

'当前发送SM的服务号码
Public Property Get ServiceTelphone() As String
    ServiceTelphone = v_ServiceTelphone
End Property


'设置发送SM的服务号码
Public Property Let ServiceTelphone(newValue As String)
   Dim s As String
   s = checkTelphone(newValue, "发送短信服务中心") '检查服务中心号码是否正确
   If s <> "" Then
      v_ServiceTelphone = s
   End If
End Property


'初始化串口
'入口参数
'　mscomm 通讯对象
'  commPort COM端口号
' ServerCenter 发送SM的服务号码
'返回：TRUR |false
'  若为 false ,v_ErrMsg 会有详细的错误描述
Public Function Init(MSComm As MSComm, _
                     Optional ByVal CommPort As Integer = 1, _
                     Optional ByVal ServerCenter As String = "13800755500" _
                     ) As Boolean
   On Error GoTo laberr
   Dim ts As String
   
   v_IsInit = False
   
   v_ServiceTelphone = checkTelphone(ServerCenter, "发送短信服务中心") '检查服务中心号码是否正确
   If v_ServiceTelphone = "" Then Exit Function
   
   Set v_MSComm = MSComm
   With MSComm
        If .PortOpen = True Then .PortOpen = False '已经找开端口，则关闭它
        .CommPort = CommPort '写端口号
        If .PortOpen = False Then .PortOpen = True '打开端口
        .Settings = "9600,n,8,1" '设置相关值
        If Output("ATE0" & vbCr, False, True, 1000) = True Then '不需要T35返回命令数值
            v_IsInit = Output("AT+CMGF=0" & vbCr, False, True, 1000) '设置发送短信的格式为PDU
        End If
   End With
   Init = v_IsInit
   Exit Function
laberr:
   v_ErrMsg = "初始化出错,错误信息为" & Err.Description
   Debug.Print v_ErrMsg
   Init = False
End Function

'将信息内容转换成USC2编码
Private Function toUSC2(ByVal s As String) As String
  Dim i As Integer
  Dim rs As String
  Dim n As Integer
  Dim tn As Integer
  rs = ""
  For i = 1 To Len(s)
      n = AscW(Mid(s, i, 1)) '取得USC2值
      tn = Abs(n)
      If tn >= 16 And tn <= 127 Then '若值d 16－127之间，则只需要在编码前面加入2个0
            rs = rs & "00"
      ElseIf tn >= 1 And tn < 16 Then '在1-15之间，需要前面加入3个0，如回车的编码为 000D
           rs = rs & "000"
      End If
      rs = rs & Hex(n)   ' Mid(s, i, 1) & "=" & Hex(n) & ","
  Next i
  toUSC2 = rs
End Function

'将电话号码移位处理
Private Function toTelphone(ByVal Mobile As String) As String
     Dim l As String
     Dim r As String
     Dim rs As String
     Dim i As Integer
     Dim n As Integer
     rs = ""
     n = Len(Mobile)
     For i = 1 To n Step 2
        l = Mid(Mobile, i, 1)
        If i = n Then '若是最后一位,则后面加入F
           r = "F"
        Else
           r = Mid(Mobile, i + 1, 1)
        End If
        rs = rs & r & l '高低位互换
     Next i
     toTelphone = rs
End Function

'发送SM
' 入口参数：
'   mobile 手机号码/市话通号码(必须加入长度区号)
'   Msg SM内容不能70个字符
'返回 TRUR | false
'  若为False, v_ErrMsg表示错误信息
Public Function Send() As Boolean
     Dim pmsg As String
     Dim length As Integer
     Dim at As String
     Dim pdu As String
     Dim Mobile As String
     
     Dim CenterPart As String
     
     Dim TPPart As String
     Dim SMPart As String
     
     Send = False
     
     If v_IsInit = False Then v_ErrMsg = "通讯串口未初始化或者初始化不成功": Exit Function
     
     length = Len(v_Msg) * 2
     If length > 140 Then
        v_ErrMsg = "发送的短信内容不能超过70个字符。"
        Exit Function
     End If
     
     '检查手机号码,若不成功，则会返回空字符串值
     Mobile = checkTelphone(v_Telphone) '检查接收的手机或者市话通号码是否正确
     If Mobile = "" Then Exit Function
     
     
     pmsg = toUSC2(v_Msg) '将SM转换成USC2编码
     
     CenterPart = toTelphone(v_ServiceTelphone) '将其转换成电话要求的编码
     CenterPart = toHex(Len(CenterPart) / 2 + 1, 2) & "91" & CenterPart '生成头部信息
   
     TPPart = "1100" & toHex(Len(Mobile), 2) & "91" & toTelphone(Mobile)
     '短信信息部分
     SMPart = SUFX & IIf(length < 16, "0", "") & Hex(length) & pmsg
     
     '组成成AT发送SM的命令串，并等待正确返回"> "，超时是1秒
     at = "AT+CMGS=" & ((Len(TPPart) + Len(SMPart)) \ 2) & vbCr
     If Output(at, False, True, 1000, "> ") = True Then
           '正确接受到“> ",则向串口写入相关的信息内容
            at = CenterPart & TPPart & SMPart & Chr$(26)
            Send = Output(at, True)
     End If
End Function

Public Sub Break()
      v_bExit = True
End Sub

'向串口MSCOMM输出一个命令或者信息
'入口参数
'  msg 需要输出的信息串
'  isCheckResult 是否需要检查返回的结果(TRUe需要,False不需要)
'  nTimeout 等待结果超时的毫秒数(只对isCheckResult=true有效)
'　okRetMsg　返回正确结果时含的字符特征串，如"OK"
'　errRetMsg 返回错误结果时含的字符特征串，如"ERROR"
'返回值：truE \ FALSE
' 若为fasle ,v_ErrMsg表示出错的信息详情
Public Function Output(ByVal Msg As String, _
                       Optional ByVal isChangeStatusEvent As Boolean = False, _
                       Optional ByVal isCheckResult As Boolean = True, _
                       Optional ByVal nTimeout As Long = MAXSENDTIME, _
                       Optional ByVal okRetMsg As String = "OK", _
                       Optional ByVal errRetMsg As String = "ERROR" _
                      ) As Boolean
    Dim i As Integer
    Dim n As Integer
    Dim rs As String
    Dim StartTime As Long
    Dim isChangedEvents As Boolean
    'If v_IsInit = False Then v_ErrMsg = "通讯串口未初始化或者初始化不成功": Exit Function
    
    isChangedEvents = False
    
    With v_MSComm
        '清输入内容以及输出内容
        While .InBufferCount > 0
              DoEvents
              rs = .Input
        Wend
        '清除输出、输入Buffer
        .InBufferCount = 0
        .OutBufferCount = 0
        
        .Output = Msg
        While .OutBufferCount > 0 '发送信息,直到完成
              DoEvents
              If isChangedEvents = False And isChangeStatusEvent = True Then
                 RaiseEvent ChangeStatus(STATUS_SENDING)
                 isChangedEvents = True
              End If
        Wend
        
        If isChangeStatusEvent Then
            RaiseEvent ChangeStatus(STATUS_SENDED)
        End If
         
       
       isChangedEvents = False
       If isCheckResult = True Then '需要处理返回结果
            rs = ""
            StartTime = timeGetTime
            Do
               
               DoEvents
               
               If v_bExit Then
                  Output = False
                  v_ErrMsg = "用户中断"
                  If isChangeStatusEvent = True Then
                        RaiseEvent ChangeStatus(STATUS_BREAK)
                  End If
                  Exit Function
               End If
               
               rs = rs & .Input
               If isChangeStatusEvent = True And rs <> "" And isChangedEvents = False Then
                    RaiseEvent ChangeStatus(STATUS_GETTING)
                    isChangedEvents = True
               End If
               
               If InStr(1, rs, okRetMsg) > 0 Then '返回的结果中含有正确代码特征
                  v_ErrMsg = "发送成功！"
                  Output = True '处理正确
                  If isChangeStatusEvent Then
                       RaiseEvent ChangeStatus(STATUS_OK)
                  End If
                  v_LastHappenTime = Time
                  Exit Function
               ElseIf InStr(1, rs, errRetMsg) > 0 Then '返回的结果中含有错误代码特征
                  v_ErrMsg = "发送失败！"
                  v_LastHappenTime = Time
                  If isChangeStatusEvent Then
                     RaiseEvent ChangeStatus(STATUS_ERROR)
                  End If
                  Output = False '处理失败
                  Exit Function
               End If
            Loop Until StartTime + nTimeout < timeGetTime '直到没超时
            v_LastHappenTime = Time
            v_ErrMsg = "发送超时"
            If isChangeStatusEvent Then
               RaiseEvent ChangeStatus(STATUS_OUTTIME)
            End If
            Output = False
      Else
         v_LastHappenTime = Time
         v_ErrMsg = "发送成功！"
         If isChangeStatusEvent Then
            RaiseEvent ChangeStatus(STATUS_OK)
         End If
         Output = True
      End If
   End With
End Function

'将n转换成Hex格式,nbits表示结果的位数
Private Function toHex(ByVal n As Integer, Optional ByVal nBits As Integer = 2) As String
   Dim s As String
   Dim i As Integer
   s = Hex(n)
   For i = Len(s) + 1 To nBits
      s = "0" & s
   Next i
   toHex = s
End Function


'检查手机号码是否正确,若正确返回加入了国别或者接受者信息的号码,否则为空字符串值，此时v_ErrMsg表示错误信息
Private Function checkTelphone(ByVal Mobile As String, _
                          Optional ByVal Name As String = "接收短信的手机/市话通") As String
   
   Dim c As String
   Dim n As Integer
   Dim i As Integer
   
   checkTelphone = ""
   n = Len(Mobile)
   If n < 7 Then
        v_ErrMsg = Name & "号码长度必须大于或等于7。"
   Else
          If Left(Mobile, 2) = "13" Then
                   If n <> 11 Then
                       v_ErrMsg = Name & "(当前为手机)号码[" & Mobile & "]必须由11位数字组成."
                       Exit Function
                   Else
                       For i = 1 To 11
                          c = Mid(Mobile, i, 1)
                          If c < "0" Or c > "9" Then
                             v_ErrMsg = Name & "(当前为手机)号码[" & Mobile & "]必须由11位数字组成."
                             Exit Function
                          End If
                       Next i
                       
                       v_ErrMsg = ""
                       checkTelphone = "86" & Mobile
                   End If
           Else
                  For i = 1 To n
                      c = Mid(Mobile, i, 1)
                      If c < "0" Or c > "9" Then
                         v_ErrMsg = Name & "号码[" & Mobile & "]必须由11或12位数字组成."
                         Exit Function
                      End If
                   Next i
                   v_ErrMsg = ""
                   checkTelphone = Mobile
           End If
   End If
End Function

'对象初始化
Private Sub Class_Initialize()
    v_IsInit = False
    v_ErrMsg = "通讯串口未初始化"
    v_ServiceTelphone = ""
    v_Para1 = ""
    v_Para2 = ""
    v_Para3 = ""
    v_Key = ""
    
    v_bExit = False
    '异步初始化
    Call Destory
    Set v_MSComm = Nothing

End Sub

Private Sub Class_Terminate()
    Destory
End Sub


Public Sub Destory()
    On Error Resume Next
    With v_MSComm
            If .PortOpen = True Then .PortOpen = False
    End With
End Sub