var.bas

自己做的

Attribute VB_Name = "Var"
Public allflag As Object '用来说明是谁发的指令
Public disp As String
Public allflag1 As Boolean
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public out As Variant
Public tex As Variant
Public shortflag As Integer '标志发送的类型
Public shortdial As String '短信号码
Public shortdialhex As String
Public shorttext As String '短信内容
Public shorttexthex As String '十六进制短信内容
Public shorttextlen As String '短信长度
Public shorttextlenhex As String
Public time As Boolean
Const WaitSendTime = 7000
Const comNum = 1
Const Rate = 115200
Const note = "查询终端对应手机编辑查询手机月份(如200604)串号，查询手机对应终端编辑查询终端月份(200604)号码"

Public Sub InitList(ByVal lst As Control) '
  lst.View = lvwReport
  lst.GridLines = True
    With lst.ColumnHeaders
     .Add , , "服务号码", 1250
        .Add , , "接受时间", 1200
         .Add , , "短信内容", 2600
        End With ' Listview表头
End Sub
Public Sub FillList(ByVal com As MSComm, ByVal lst As Control, ByVal phone_no As String, ByVal Rtime As String, ByVal Content As String)
Dim i
On Error Resume Next
i = lst.ListItems.Count
lst.ListItems.Add.text = phone_no
lst.ListItems(i + 1).SubItems(1) = Rtime
lst.ListItems(i + 1).SubItems(2) = Content

Dim key, smonth, data, str
str = Trim(Content)
key = Left(str, 4)
smonth = Mid(str, 5, 6)
data = Right(str, Len(str) - 10)
phone_no = Right(phone_no, 11)
If key = "查询终端" Or key = "查询手机" Then
Search com, smonth, phone_no, data, key
End If

End Sub



Public Sub GetDataMean(ByVal com As MSComm, ByVal Term As Control, ByVal lst As Control) '用于等待MODEM回应的延时
On Error Resume Next
Dim buffer As Variant
Dim lenbuffer As Integer

Sleep (300)
buffer = com.Input
lenbuffer = Len(buffer)
If lenbuffer <> 0 Then
    Call ShowBackMsg(Term, CStr(buffer))
    Call ReceiveMsg(com, Term, CStr(buffer), lst)
    End If
End Sub


Public Sub ShowInfo(ByVal com As MSComm)
com.Output = "AT+CGMI" & Chr$(13)
Sleep (100)
com.Output = "AT+CGMR" & Chr$(13)
Sleep (100)
com.Output = "AT+CGSN" & Chr$(13)
Sleep (100)
com.Output = "AT+CGMM" & Chr$(13)
Sleep (100)
com.Output = "AT+CMGD＝1" & Chr$(13)
Sleep (100)
End Sub
Public Function FixData(ByVal data As String) As String
Dim i As Integer
  ' 过滤/处理退格符。
    Do
       i = InStr(data, Chr$(8))
       If i Then
          If i = 1 Then
             Term.SelStart = TermSize - 1
             Term.SelLength = 1
             data = Mid$(data, i + 1)
          Else
             data = Left$(data, i - 2) & Mid$(data, i + 1)
       End If
       End If
    Loop While i
    
    ' 除去换行符。
    Do
       i = InStr(data, Chr$(10))
       If i Then
          data = Left$(data, i - 1) & Mid$(data, i + 1)
       End If
    Loop While i

    ' 确定所有的回车都包含换行符。
    i = 0
    Do
       i = InStr(i + 1, data, Chr$(13))
       If i Then
          data = Left$(data, i) & Chr$(10) & Mid$(data, i + 1)
       End If
       
    Loop While i
    
    FixData = data
    
End Function

Public Sub ShowBackMsg(ByVal Term As Control, ByVal data As String)
'显示模块，用于显示从串口返回的数据
    Term.text = Term.text & FixData(data)
    
End Sub

Public Sub ReceiveMsg(ByVal com As MSComm, Term As Control, indata As String, ByVal lst As Control) '接收短信子程序
Dim receive_ok As String
Dim i, j As Integer

If indata = "" Then Exit Sub

j = Len(indata)



i = InStr(indata, "+CMT:")
If i Then
    receive_ok = Right(indata, j - i + 4)
    Dim i1, i2, i3, i4 As Integer
    Dim cal, tim, text As String
    
    Dim ii As Integer
    Dim aa, bb, cc, c1, c2 As String
    
    Dim jj As String
    Dim kk As Integer
    
    i1 = InStr(receive_ok, Chr$(34))
    If i1 Then
        i2 = InStr(i1 + 1, receive_ok, Chr$(34))
        i3 = InStr(i2 + 1, receive_ok, Chr$(34))
        i4 = InStr(i3 + 1, receive_ok, Chr$(34))
        cal = Mid(receive_ok, i1 + 1, i2 - i1 - 1)
        tim = Mid(receive_ok, i3 + 1, i4 - i3 - 1)
        text = Mid(receive_ok, i4 + 3)
    FillList com, lst, cal, tim, text
        Else
            i2 = InStr(receive_ok, "F") '处理主叫号码
            aa = Mid(receive_ok, i2 + 4, 2)
            If aa = "0D" Then
                cal = Mid(receive_ok, i2 + 8, 14)
                For ii = 1 To 14 Step 2
                    bb = Mid(cal, ii, 2)
                    c1 = Left(bb, 1)
                    c2 = Right(bb, 1)
                    cc = cc & c2 & c1
                    
                Next
                cal = "+" & Mid(cc, 1, 13)
            End If
            If aa = "OB" Then
                cal = Mid(receive_ok, i2 + 8, 12)
                For ii = 1 To 12 Step 2
                    bb = Mid(cal, ii, 2)
                    c1 = Left(bb, 1)
                    c2 = Right(bb, 1)
                    cc = cc & c2 & c1
                Next
                cal = Mid(cc, 1, 11)
            End If
            
            cc = ""
            i2 = InStr(i2 + 1, receive_ok, "F") '处理接收时间
            tim = Mid(receive_ok, i2 + 6, 14)
            For ii = 1 To 14 Step 2
                bb = Mid(tim, ii, 2)
                c1 = Left(bb, 1)
                c2 = Right(bb, 1)
                If ii = 3 Or ii = 5 Then cc = cc & "/"
                If ii = 7 Then cc = cc & ","
                If ii = 9 Or ii = 11 Then cc = cc & ":"
                If ii = 13 Then cc = cc & "+"
                cc = cc & c2 & c1
            Next
            tim = cc
            
            cc = ""
            aa = Mid(receive_ok, i2 + 4, 2) '处理信息内容
            text = Mid(receive_ok, i2 + 22)
            If aa = "08" Then '收到中中文短信
                jj = Mid(receive_ok, i2 + 20, 2) '字符个数
                kk = Val("&h" & jj) '变成十进制
                For ii = 1 To (kk / 2)
                    bb = Mid(text, (ii - 1) * 4 + 1, 4)
                    cc = cc & ChrW(Val("&h" & bb))
                Next
                text = cc
            End If
            If aa = "00" Then '收到手机发来的7比特西文短信
                jj = Mid(receive_ok, i2 + 20, 2) '字符个数
                kk = Val("&h" & jj) '变成十进制
                jj = InStr(text, vbCr)
                text = Left(text, jj - 1) '去掉内容后面的回车符
                jj = Len(text)
                For ii = (jj / 2) To 1 Step -1
                    bb = Mid(text, ii * 2 - 1, 2)
                    cc = cc & bb
                Next
                text = cc
                cc = ""
                For ii = 1 To jj
                    bb = Mid(text, i, 1)
                    Select Case bb
                        Case "0"
                            cc = cc & "0000"
                        Case "1"
                            cc = cc & "0001"
                        Case "2"
                            cc = cc & "0010"
                        Case "3"
                            cc = cc & "0011"
                        Case "4"
                            cc = cc & "0100"
                        Case "5"
                            cc = cc & "0101"
                        Case "6"
                            cc = cc & "0110"
                        Case "7"
                            cc = cc & "0111"
                        Case "8"
                            cc = cc & "1000"
                        Case "9"
                            cc = cc & "1001"
                        Case "A"
                            cc = cc & "1010"
                        Case "B"
                            cc = cc & "1011"
                        Case "C"
                            cc = cc & "1100"
                        Case "D"
                            cc = cc & "1101"
                        Case "E"
                            cc = cc & "1110"
                        Case "F"
                            cc = cc & "1111"
                    End Select
                Next
                text = cc
                cc = ""
                For ii = kk To 1 Step -1
                    bb = "0" & Mid(text, ii * 7 - 7, 7)
                    cc = cc & str(Val("&b" & bb))
                Next
                text = cc
            End If
                                
               
                
   
             FillList com, lst, cal, tim, text
    End If
End If

i = 0
i = InStr(indata, "+CMGS:")
If i Then Call ShowBackMsg(Term, "发送短信成功")



End Sub
Public Function OpenDev(ByVal frm As Form, ByVal com As MSComm) As Boolean
On Error Resume Next
With com
.CommPort = comNum
.Settings = Rate & ",n,8,1"
If .PortOpen Then
.PortOpen = False
End If
.PortOpen = True

If Err.Number <> 0 Then
OpenDev = Falses
Exit Function
End If
frm.cmdDis.Enabled = Not frm.cmdDis.Enabled
frm.cmdOpen.Enabled = Not frm.cmdOpen.Enabled
frm.cmdsMs.Enabled = Not frm.cmdsMs.Enabled

OpenDev = True
End With


End Function
Public Function SendChinese(ByVal com As MSComm, ByVal phone_no As String, ByVal msg As String) As Boolean

Dim test As Long
Dim i As Integer
Dim k As Boolean
Dim b, ib As Integer
Dim cin, c1, c2, cout As String
Dim ii, kk, jj As Integer '处理要发送的字符
Dim aa, bb, cc As String

test = 0
k = False
shortdial = phone_no
shortdialhex = "" '处理16进制号码
b = Len(shortdial)

For ib = 1 To b
    If (ib Mod 2 = 0) Then
        c = Mid(shortdial, ib - 1, 2)
        c1 = Left(c, 1)
        c2 = Right(c, 1)
        cout = c2 & c1
        shortdialhex = shortdialhex & cout

    End If
Next
shortdialhex = shortdialhex & "F" & Right(shortdial, 1)
shorttext = msg
shorttexthex = ""
ii = Len(msg)
kk = 0
For jj = 1 To ii
  aa = Mid(shorttext, jj, 1) '获取一个字符
  bb = AscW(aa) '变成内码
  cc = Hex(bb) '变成16进制
  If bb < 128 And bb > 0 Then
    kk = kk + 2
    cc = "00" & cc
  Else
      kk = kk + 2
  End If
  shorttexthex = shorttexthex & cc

Next jj

If kk < 15 Then '处理要发送文本的长度
  shorttextlenhex = "0" + CStr(Hex(kk))
  Else
    If i < 70 Then
      shorttextlenhex = CStr(Hex(kk))
      Else
      shorttextlenhex = "8C"
    End If
End If
shorttextlen = kk
time = False
Dim tmpS
tmpS = "0011000D9168" & shortdialhex & "0008A7" & shorttextlenhex & shorttexthex & Chr(26)

With com
DoEvents
.Output = "AT+CMGF=0" + Chr(13)
Sleep (100)
.Output = "AT+CMGS=" & (shorttextlen + 15) & Chr(13)
Sleep (100)
DoEvents
.Output = tmpS
Sleep (WaitSendTime)
shortdialhex = ""
shorttexthex = ""
End With

End Function
Public Sub Search(ByVal com As MSComm, ByVal smonth As String, ByVal back_phone_no As String, ByVal data As String, ByVal key As String)
On Error Resume Next
Dim Rs As ADODB.Recordset
Dim msg
If key = "查询终端" Then
Sql = "select * from dcustimeimsg" & smonth & "  where phone_no='" & data & "'"
ElseIf key = "查询手机" Then
Sql = "select * from dcustimeimsg" & smonth & "  where substring(imei_no,1,14)='" & Left(data, 14) & "'"
End If
Set Rs = ExeSQL(Sql, "s")
If Not Rs.EOF Then
Do Until Rs.EOF
msg = "号码:" & Rs("phone_no") & "串号:" & Rs("imei_no") & "最近通话:" & Year(Rs("call_date")) & Month(Rs("call_date")) & Day(Rs("call_date"))
MsgBox Sql & msg & back_phone_no
Exit Sub
Call SendChinese(com, back_phone_no, msg)
msg = ""
Loop
Else
Call SendChinese(com, back_phone_no, note)
End If
End Sub