commsms.cls

通过西门子模块收发短信

   SendSMS = "ERROR/操作超时"
   Exit Function
Else  '如果正确，进入发送
   strSMSComin = ""
   Call Pause(0.1)
   MyComm.Output = strSMSCode & Chr(26) '发送短信
   Call WaitA
   If InStr(strSMSComin, "ERROR") > 0 Then '如果发送错误，退出
      SendSMS = "ERROR/发送错误"
   ElseIf blnExceed = True Then
      SendSMS = "ERROR/发送超时"
   Else
      Call Pause(0.2)
      SendSMS = "OK/发送成功"
   End If
End If

Exit Function

ErrorDeal:
  
SendSMS = "ERROR/发送错误"

End Function

Public Function InitialCard() As String '启动sim卡
Dim sglBasetime As Single

blnExceed = False
strSMSComin = ""

MyComm.Output = "AT+CPIN?" & Chr(13) '进入读卡流程
Call WaitB
If InStr(strSMSComin, "ERROR") > 0 Or blnExceed = True Then
   strSMSComin = ""
   InitialCard = "ERROR/读卡失败"
   Exit Function
End If

strSMSComin = ""
MyComm.Output = "AT+CMGF=0" & Chr(13) '进入设置PDU模式流程
Call WaitB
If InStr(strSMSComin, "ERROR") > 0 Or blnExceed = True Then
   strSMSComin = ""
   InitialCard = "ERROR/无法进入PDU模式"
   Exit Function
End If

strSMSComin = ""
MyComm.Output = "AT+CNMI=0,0,0,0,1" & Chr(13) '进入设置通信读取模式流程
Call WaitB
If InStr(strSMSComin, "ERROR") > 0 Or blnExceed = True Then
   InitialCard = "ERROR/无法进入正确读写模式"
Else
   InitialCard = "OK/SIM卡启动成功"
End If
   
End Function

Public Function SetCenter(CenterNum As String) As String '设置服务中心

blnExceed = False
strSMSComin = ""

MyComm.Output = "AT+CSCA=" + CenterNum & Chr(13)
Call WaitA
If blnExceed = True Then
   SetCenter = "ERROR/设置超时"
   Exit Function
End If
   
If InStr(strSMSComin, "OK") > 0 Then
   SetCenter = "ERROR/设置成功"
Else
   SetCenter = "ERROR/设置失败"
End If
strSMSComin = ""

End Function

Public Function EraseAll() As String '删除全部短信
On Error GoTo ErrorDeal

blnExceed = False
strSMSComin = ""
InSMSList = ""

MyComm.Output = "AT+CMGL=4" & Chr(13)
Call WaitA
EraseAll = "ERROR/操作延时错误"

If InStr(strSMSComin, "CMGL:") = 0 Then
   EraseAll = "OK/没有储存的短信"
   Exit Function
Else
   Do
   DoEvents
      DealString = GetBetweenPart(strSMSComin, "+", ",,")
      InSMSList = InSMSList + GetBetweenPart(DealString, "CMGL: ", ",") + ","
      strSMSComin = GetRightPart(strSMSComin, ",,")
   Loop Until InStr(strSMSComin, "CMGL") = 0
   strSMSComin = ""
End If

Do While InStr(InSMSList, ",") > 0
DoEvents
    MyComm.Output = "AT+CMGD=" + GetLeftPart(InSMSList, ",") & Chr(13) '删除短信
    InSMSList = GetRightPart(InSMSList, ",")
    Call WaitA
    If blnExceed = True Then '短信清单出错处理
       EraseAll = "ERROR/操作延时错误"
       strSMSComin = ""
       Exit Function
    End If
    strSMSComin = ""
Loop
EraseAll = "OK/删除成功"

Exit Function

ErrorDeal:
  
EraseAll = "ERROR/删除错误"

End Function

Private Sub SMSDeal(hcode As String, con As String) 'PDU编码例程

Dim Lenth As Long '内容长度
Dim hexstr(70) As String '长度为70的hex数组
Dim hexcon As String 'Unicode
Dim codepdu As String 'pdu码
Dim hexlen As String 'pdu码的hex长度

Lenth = Len(con)

If Lenth > 70 Then
   con = Left(con, 70)
   Lenth = 70
End If

For I = 1 To Lenth

  hexstr(I) = Hex(AscW(Right(Left(con, I), 1)))

  If Len(hexstr(I)) < 4 Then
  hexstr(I) = "00" + hexstr(I)
  End If

  hexcon = hexcon + hexstr(I)

Next I
 
codepdu = Right(Left(hcode, 2), 1) + Left(hcode, 1) + Right(Left(hcode, 4), 1) + Right(Left(hcode, 3), 1) + Right(Left(hcode, 6), 1) + Right(Left(hcode, 5), 1) + Right(Left(hcode, 8), 1) + Right(Left(hcode, 7), 1) + Right(Left(hcode, 10), 1) + Right(Left(hcode, 9), 1) + "f" + Right(hcode, 1)
hexlen = Hex(2 * Lenth)

If Len(hexlen) < 2 Then
   hexlen = "0" + hexlen
End If

strSMSCode = "0011000d9168" + codepdu + "0008ff" + hexlen + hexcon
strSMSLen = (Len(strSMSCode) - 2) / 2

End Sub

Private Sub Pause(st As Single) '延时等待函数

sglBasetime = Timer

Do
  DoEvents
Loop Until Timer > sglBasetime + st

End Sub

Private Sub WaitA() '延时等待15秒，模块返回信息

sglBasetime = Timer

Do
  DoEvents
  strSMSComin = strSMSComin + MyComm.Input
Loop Until InStr(strSMSComin, "OK") > 0 Or InStr(strSMSComin, "ERROR") > 0 Or Timer > sglBasetime + 8

If Timer > sglBasetime + 15 Then
   blnExceed = True
   Exit Sub
End If

sglBasetime = Timer

Do
  DoEvents
  strSMSComin = strSMSComin + MyComm.Input
Loop Until Timer > sglBasetime + 0.1

End Sub

Private Sub WaitB() '延时等待2秒，模块返回信息

sglBasetime = Timer

Do
  DoEvents
  strSMSComin = strSMSComin + MyComm.Input
Loop Until InStr(strSMSComin, "OK") > 0 Or InStr(strSMSComin, "ERROR") > 0 Or Timer > sglBasetime + 2

If Timer > sglBasetime + 2 Then
   blnExceed = True
   Exit Sub
End If

sglBasetime = Timer

Do
  DoEvents
  strSMSComin = strSMSComin + MyComm.Input
Loop Until Timer > sglBasetime + 0.1

End Sub

Public Function SetActPort(I As Integer) As String '设置活动端口

On Error GoTo ErrorDeal

If InStr(UseComList, I & ",") > 0 Then
   Set MyComm = frmMain.MSComm(I)
   SetActPort = "OK/设置成功"
Else
   SetActPort = "ERROR/端口未初始化"
End If

Exit Function

ErrorDeal:

SetActPort = "ERROR/端口设置失败"

End Function

Public Function ComPortInit() As String '端口初始化

Dim I As Long, PortSum As Long, PortList As String
Dim TestList As String
Dim MaxPort As Long

On Error GoTo ErrorDeal

For I = 1 To 16
   frmMain.MSComm(0).CommPort = I
   frmMain.MSComm(0).PortOpen = True
   frmMain.MSComm(0).PortOpen = False
   PortList = PortList & I & ","
   PortSum = PortSum + 1
Recycle:

Next I

On Error GoTo ErrorDeal2
If PortSum >= 8 Then
   For I = 1 To 7
      Load frmMain.MSComm(I)
   Next I
   MaxPortNo = Left(Right(PortList, 3), 2)
   For I = 0 To 7
       frmMain.MSComm(I).CommPort = MaxPortNo + I - 7
       frmMain.MSComm(I).PortOpen = True
   Next I
   UseComList = "0,1,2,3,4,5,6,7,"
Else
   I = 0
   TestList = PortList
   Do
   DoEvents
      If I > 0 Then
         Load frmMain.MSComm(I)
      End If
      frmMain.MSComm(I).CommPort = GetLeftPart(TestList, ",")
      frmMain.MSComm(I).PortOpen = True
      TestList = GetRightPart(TestList, ",")
      UseComList = UseComList & I & ","
      I = I + 1
   Loop Until TestList = ""
End If

ComPortInit = "OK/" & (I + 1) & "个端口初始化成功"

Exit Function

ErrorDeal:
  If I = 16 Then
  Else
     GoTo Recycle
  End If
Exit Function

ErrorDeal2:
ComPortInit = "ERROR/" + Err.Description

End Function

Private Function GetBetweenPart(con As String, tag1 As String, tag2 As String)
On Error GoTo ErrorDeal '取标志中间字符串

GetBetweenPart = GetLeftPart(GetRightPart(con, tag1), tag2)
Exit Function

ErrorDeal:
GetBetweenPart = ""

End Function

Private Function GetRightPart(con As String, tag As String)
On Error GoTo ErrorDeal '取标志右边字符串

GetRightPart = Right(con, Len(con) - InStr(con, tag) - Len(tag) + 1)
Exit Function

ErrorDeal:
GetRightPart = ""

End Function

Private Function GetLeftPart(con As String, tag As String)
On Error GoTo ErrorDeal '取标志左边字符串

GetLeftPart = Left(con, InStr(con, tag) - 1)
Exit Function

ErrorDeal:
GetLeftPart = ""

End Function