haiwasms.ctl

一个利用AT指令驱动手机进行中文短消息收发的控件源码

VERSION 5.00
Object = "{648A5603-2C6E-101B-82B6-000000000014}#1.1#0"; "Mscomm32.ocx"
Begin VB.UserControl haiwasmscontrol 
   Appearance      =   0  'Flat
   BackColor       =   &H80000005&
   BackStyle       =   0  '透明
   ClientHeight    =   375
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   375
   ClipBehavior    =   0  '无
   MaskColor       =   &H80000005&
   MaskPicture     =   "haiwasms.ctx":0000
   Picture         =   "haiwasms.ctx":08CA
   ScaleHeight     =   375
   ScaleWidth      =   375
   ToolboxBitmap   =   "haiwasms.ctx":190C
   Begin MSCommLib.MSComm MSC 
      Left            =   510
      Top             =   180
      _ExtentX        =   1005
      _ExtentY        =   1005
      _Version        =   393216
      DTREnable       =   -1  'True
   End
End
Attribute VB_Name = "haiwasmscontrol"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'缺省属性值:
Const m_def_copyright = "HaiwaSms V2.0 Copyright By ZhuDingHua www.soez.cn"
Const m_def_nationcode = "86"
Const m_def_autorec = True
'属性变量:
Dim m_copyright As String
Dim m_nationcode As String
Dim m_smsc As String
Dim m_autorec As Boolean
Dim strau, strauto As String
Dim m_strau As String
Dim m_enable As Integer
Dim m_regstat As Boolean
'事件声明:
Event readallrec(ByVal index As String, ByVal sendno As String, ByVal sendtime As String, ByVal msg As String)
Event newmsg(ByVal sendno As String, ByVal sendtime As String, ByVal msg As String)



'注意！不要删除或修改下列被注释的行！
'MappingInfo=UserControl,UserControl,-1,Enabled
Public Property Get Enabled() As Boolean
Attribute Enabled.VB_Description = "返回/设置一个值，决定一个对象是否响应用户生成事件。"
    Enabled = UserControl.Enabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
    UserControl.Enabled() = New_Enabled
    PropertyChanged "Enabled"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=MSC,MSC,-1,CommPort
Public Property Get CommPort() As Integer
Attribute CommPort.VB_Description = "设置/返回通讯端口号。"
    CommPort = MSC.CommPort
End Property

Public Property Let CommPort(ByVal New_CommPort As Integer)
    MSC.CommPort() = New_CommPort
    PropertyChanged "CommPort"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=MSC,MSC,-1,Settings
Public Property Get Settings() As String
Attribute Settings.VB_Description = "设置/返回波特率、奇偶校验、数据位和停止位参数。"
    Settings = MSC.Settings
End Property

Public Property Let Settings(ByVal New_Settings As String)
    MSC.Settings() = New_Settings
    PropertyChanged "Settings"
End Property
'

 Function readmsg(ByVal number As Integer) As Boolean
If MSC.PortOpen = True Then
   MSC.Output = "AT+CMGR=" & number & vbCr
   readmsg = True
Else
   readmsg = False
End If

End Function

'注意！不要删除或修改下列被注释的行！
'MemberInfo=14
Public Function delmsg(ByVal msgindex As Integer) As Boolean
Attribute delmsg.VB_Description = "删除消息"
If MSC.PortOpen Then
   MSC.Output = "AT+CMGD=" & msgindex & vbCr
   delmsg = True
Else
   delmsg = False
End If
End Function



Private Sub MSC_OnComm()
Dim m_strau As String
If MSC.CommEvent = 2 Then
   On Error GoTo err1
  Do While m_enable = 0 And MSC.InBufferCount <> 0
     DoEvents
     timer1 = Timer()
     Do
     DoEvents
     Loop Until timer1 + 0.0001 < Timer()
     On Error GoTo err1
     m_strau = MSC.Input
     If m_strau = "+" Then
     m_enable = 1
     Else
     If m_strau <> "O" And m_strau <> "K" Then
     strau = strau & m_strau
     End If
     End If
  Loop
    strau = "+" & strau
   Call msgtrs
    
End If
err1:
End Sub


Private Sub msgtrs()
Dim i As Integer
Dim j As String
Dim strcmt As String
If InStr(strau, "+CMGL") Then
strcmt = strau
index = CInt(Mid(strcmt, InStr(strcmt, "+CMGL") + 7, 2))
i = InStr(strcmt, ",,")
strcmt = Right(strcmt, Len(strcmt) - i - 2)
j = transmsg(Trim(strcmt))
i = InStr(j, "#")
sendno = Left(j, i - 1)
j = Right(j, Len(j) - i)
sendtime = Left(j, 12)
msg = Right(j, Len(j) - 13)
If m_regstat = False Then
msg = "Welcome To www.soez.cn" & msg
End If
msg = Left(msg, 70)
RaiseEvent readallrec(index, sendno, sendtime, msg)
strau = ""
m_enable = 0
ElseIf InStr(strau, "+CMT") Then
strcmt = strau
i = InStr(strcmt, "+CMT: ,")
strcmt = Right(Trim(strcmt), Len(Trim(strcmt)) - i - 7)
j = transmsg(Trim(strcmt))
i = InStr(j, "#")
sendno = Left(j, i - 1)
j = Right(j, Len(j) - i)
sendtime = Left(j, 12)
msg = Right(j, Len(j) - 13)
If m_regstat = False Then
msg = "Welcome To www.soez.cn" & msg
End If
msg = Left(msg, 70)
RaiseEvent newmsg(sendno, sendtime, msg)
strau = ""
m_enable = 0
m_strau = ""

ElseIf InStr(strau, "+CMGR") And InStr(strau, "ERROR") = 0 Then
strcmt = strau
i = InStr(strcmt, ",,")
strcmt = Right(strcmt, Len(strcmt) - i - 2)
j = transmsg(Trim(strcmt))
i = InStr(j, "#")
sendno = Left(j, i - 1)
j = Right(j, Len(j) - i)
sendtime = Left(j, 12)
msg = Right(j, Len(j) - 13)
If m_regstat = False Then
msg = "Welcome To www.soez.cn" & msg
End If
msg = Left(msg, 70)
RaiseEvent newmsg(sendno, sendtime, msg)
strau = ""
m_enable = 0
ElseIf InStr(strau, "ERROR") Then
strau = ""
m_strau = ""
m_enable = 0
Else
strau = ""
m_enable = 0
m_strau = ""
End If
End Sub


'为用户控件初始化属性
Private Sub UserControl_InitProperties()
'    m_telno = m_def_telno
'    m_msg = m_def_msg
    m_autorec = m_def_autorec
    m_smsc = m_def_smsc
'    m_waittime = m_def_waittime
    m_nationcode = m_def_nationcode
    m_copyright = m_def_copyright
End Sub

'从存贮器中加载属性值
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
    MSC.CommPort = PropBag.ReadProperty("CommPort", 1)
    MSC.Settings = PropBag.ReadProperty("Settings", "9600,n,8,1")
    m_autorec = PropBag.ReadProperty("autorec", m_def_autorec)
    m_smsc = PropBag.ReadProperty("smsc", m_def_smsc)
    m_nationcode = PropBag.ReadProperty("nationcode", m_def_nationcode)
    m_copyright = PropBag.ReadProperty("copyright", m_def_copyright)
End Sub

'将属性值写到存储器
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

    Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True)
    Call PropBag.WriteProperty("CommPort", MSC.CommPort, 1)
    Call PropBag.WriteProperty("Settings", MSC.Settings, "9600,n,8,1")
    Call PropBag.WriteProperty("autorec", m_autorec, m_def_autorec)
    Call PropBag.WriteProperty("smsc", m_smsc, m_def_smsc)
    Call PropBag.WriteProperty("nationcode", m_nationcode, m_def_nationcode)
    Call PropBag.WriteProperty("copyright", m_copyright, m_def_copyright)
End Sub

'注意！不要删除或修改下列被注释的行！
'MemberInfo=14
Public Function gsmopen() As Boolean
If Not MSC.PortOpen Then
MSC.InputLen = 1
MSC.InBufferSize = 2048
MSC.RThreshold = 1
MSC.InputMode = 0
On Error GoTo err1
MSC.PortOpen = True
MSC.Output = "ATE0" & vbCr
MSC.Output = "AT+CMGF=0" + vbCr
 If m_autorec Then
  MSC.Output = "AT+CNMI=2,2,0,0,1" & vbCr
 Else
 MSC.Output = "AT+CNMI=0,0,0,0,0" & vbCr
 End If
 gsmopen = True
Else
err1:
 gsmopen = False
End If
End Function

'注意！不要删除或修改下列被注释的行！
'MemberInfo=0,0,0,true0
Public Property Get autorec() As Boolean
Attribute autorec.VB_Description = "设置是否自动接收新的消息"
    autorec = m_autorec
End Property

Public Property Let autorec(ByVal New_autorec As Boolean)
    m_autorec = New_autorec
    PropertyChanged "autorec"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=0
Function sendmsg(ByVal telephoneno As String, ByVal msg As String) As Boolean
If MSC.PortOpen Then
 Dim smsc As String
 Dim count As Long
 smsc = m_smsc
 If m_regstat = False Then
msg = "欢迎使用海华短信二次开发接口控件Welcome To www.soez.cn" & msg
 End If
msg = Left(msg, 70)
Dim m_m_telephoneno As String
m_m_telephoneno = telephoneno
length = Len(msg) * 2
s_len = 8 + Len(notrans(m_m_telephoneno)) / 2
count = MSC.OutBufferCount
If count > 0 Then
sendmsg = False
Exit Function
End If
MSC.Output = "AT+CMGS=" & Str(length + s_len) & vbCr
MSC.Output = msgtrans(smsc, telephoneno, msg) & Chr$(26)
timer1 = Timer()
Do
 DoEvents
Loop Until timer1 + 1 < Timer()
sendmsg = True
Else
sendmsg = False
End If
End Function
Private Function ctu(ByVal c_string As String) As String
Dim s_len, chr_len, i As Integer
s_len = Len(c_string) '计算字符串总长度
For i = 1 To s_len
  chr_len = Len(Hex(AscW(c_string))) '取得第一个字符的UNICODE编码
    If chr_len = 2 Then '如果UNICODE编码长度为"2",则该字符为英文字符
    ctu = ctu & "00" & Hex(AscW(c_string))
     c_string = Right(c_string, Len(c_string) - 1)
    Else '否则为中文字符
    ctu = ctu & Hex(AscW(c_string)) '直接转换为UNICODE编码
    c_string = Right(c_string, Len(c_string) - 1)
    End If
Next i
End Function
Private Function utc(ByVal u_string As String) As String
Dim s_len, i As Integer
Dim intstr As String
s_len = Len(u_string)
For i = 4 To s_len Step 4
    intstr = "&H" & Left(u_string, 4)
    utc = utc & ChrW(CInt(intstr))
    u_string = Right(u_string, s_len - i)
Next i
End Function
Private Function msgtrans(smsc As String, telephoneno As String, msg As String) As String
smsc = "91" & notrans(smsc)
m_telephoneno = telephoneno
'If Left(m_telephoneno, 2) = "86" Then
If Left(m_telephoneno, 2) = m_nationcode Then
Else
  ' m_telephoneno = "86" & m_telephoneno
    m_telephoneno = m_nationcode & m_telephoneno
End If
telephoneno = notrans(telephoneno)

msg = ctu(msg)
msglen = Hex(Len(msg) / 2)
If Len(msglen) = 1 Then
   msglen = "0" & msglen
End If


msgtrans = "0" & Len(smsc) / 2 & smsc & "1100" & "0" & Hex(Len(m_telephoneno)) & "91" & telephoneno & "000800" & msglen & msg
End Function
Private Function notrans(telephoneno As String) As String
Dim m_telephoneno, m_telephone, m_notrans As String
'If Left(telephoneno, 2) = "86" Then
If Left(telephoneno, 2) = m_nationcode Then
Else
 'telephoneno = "86" & telephoneno
  telephoneno = m_nationcode & telephoneno
End If

If Len(telephoneno) Mod 2 = 1 Then
 telephoneno = telephoneno & "F"
Else
 telephoneno = telephoneno
End If
m_telephoneno = telephoneno
For i = 2 To Len(m_telephoneno) Step 2
    m_telephone = Left(m_telephoneno, 2)
    m_notrans = m_notrans & Right(m_telephone, 1) & Left(m_telephone, 1)
    m_telephoneno = Right(telephoneno, Len(telephoneno) - i)
Next i
  notrans = m_notrans
End Function
Private Function transmsg(ByVal cmtmsg As String) As String
Dim i As Integer
 i = InStr(cmtmsg, "9168") - 3
 cmtmsg = Right(cmtmsg, Len(cmtmsg) - i)
 j = CInt(Left(cmtmsg, 2))
 cmtmsg = Right(cmtmsg, Len(cmtmsg) - (j * 2 + 5))
 nolong = Left(cmtmsg, 1)
 nolong = "&H" & nolong
 nolong = CLng(nolong)
 If nolong * 1 Mod 2 = 0 Then
 Else
 nolong = nolong + 1
 End If
 cmtmsg = Right(cmtmsg, Len(cmtmsg) - 3)
 telno = notrans(Left(cmtmsg, nolong))    '去出原始格式的发送号码
 telno = Right(telno, Len(telno) - 2)     '转换后去掉"86"
 'cmtmsg = Right(cmtmsg, Len(cmtmsg) - Len(telno) - 4)  '去掉发送号码和TP-PID,TP-DCS共4位标识
 cmtmsg = Right(cmtmsg, Len(cmtmsg) - Len(telno) - 2)   '去掉发送号码,TP-PID标识
 msgtp_dcs = Left(cmtmsg, 2)                            '取出TP-DCS标识
 cmtmsg = Right(cmtmsg, Len(cmtmsg) - 2)                '去掉TP-DCS标识
 
 stime = notrans(Left(cmtmsg, 12))                     '取出时间
 stime = Right(stime, Len(stime) - 2)                  '去掉时间的后两位(02)
 cmtmsg = Right(cmtmsg, Len(cmtmsg) - 14)              '将原信息去掉14位时间戳
 msglong = CLng("&H" & Left(cmtmsg, 2))                '取信息长度
 cmtmsg = Right(cmtmsg, Len(cmtmsg) - 2)               '将原信息去掉2位长度数据
 '新添加的
 cmtmsg = Left(cmtmsg, msglong * 2)                    '将信息进行解码
 If Right(telno, 1) = "F" Then
   telno = Left(telno, Len(telno) - 1)
 End If
 transmsg = telno & "#" & stime & "#" & utc(cmtmsg)
End Function


'注意！不要删除或修改下列被注释的行！
'MemberInfo=14,0,0,
Public Property Get smsc() As Variant
    smsc = m_smsc
End Property

Public Property Let smsc(ByVal New_smsc As Variant)
    m_smsc = New_smsc
    PropertyChanged "smsc"
End Property
'
''注意！不要删除或修改下列被注释的行！
''MemberInfo=7,0,0,2
'Public Property Get waittime() As Integer
'    waittime = m_waittime
'End Property
'
'Public Property Let waittime(ByVal New_waittime As Integer)
'    m_waittime = New_waittime
'    PropertyChanged "waittime"
'End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=13,0,0,86
Public Property Get nationcode() As String
    nationcode = m_nationcode
End Property

Public Property Let nationcode(ByVal New_nationcode As String)
    m_nationcode = New_nationcode
    PropertyChanged "nationcode"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=0

'注意！不要删除或修改下列被注释的行！
'MemberInfo=0
Public Function gsmclose() As Boolean
If MSC.PortOpen Then
   m_enable = 1
   MSC.PortOpen = False
   gsmclose = True
Else
   gsmclose = False
End If
End Function

'注意！不要删除或修改下列被注释的行！
'MemberInfo=0
Public Function readall() As Boolean
If MSC.PortOpen Then
 MSC.Output = "AT+CMGL" & vbCr
 readall = True
Else
 readall = False
End If
End Function

'注意！不要删除或修改下列被注释的行！
'MemberInfo=13,1,1,Copyright By Haiwasoft Inc.www.soez.cn
Public Property Get copyright() As String
    copyright = m_copyright
End Property

Public Property Let copyright(ByVal New_copyright As String)
    If Ambient.UserMode = False Then Err.Raise 387
    If Ambient.UserMode Then Err.Raise 382
    m_copyright = New_copyright
    PropertyChanged "copyright"
End Property


Public Function reg(ByVal username As String, ByVal regcode As String) As Boolean
'此行为控件注册方法，请自行设计加密方法
If username = "guowd" And regcode = "jfgsejkfgweHHvc6Nk" Then
m_regstat = True
reg = True
Else
m_regstat = False
reg = False
End If
End Function