所用函数列表.txt

基于手机短信和gps、gis的车辆定位调度系统 使用了灵图的地图模块

Private Sub SHOW_SMS(SMS_ALL As String)
Dim SMS_LSXH As Long '临时序号
Dim SMS_LSXX As Long '0891所在位置
Dim SMS_LSBZ As Long, SMS_LSBZ1 As Long, SMS_LSBZ2 As Long 'F0040所在位置
Dim SMS_LSNRB As Long '内容的开始位置
Dim SMS_LSNRE As Long '内容的结束位置
Dim i, INDEX_SMS, STA_SMS, TIME_SMS As String, DATE_SMS As String, NO_SMS As String, HC_LS As Long, HH_LS As Long
Dim SMS_NR As String, SMS_NR_A As String, SMS_BZ As String
'信息内容
Dim SMS_LSCR As String '编码格式
i = 2
Text7.Text = ""
SMS_LSBZ2 = 0
Combo1.Clear
Do
    SMS_LSXH = InStr((i - 1), SMS_ALL, "+CMGL:")
    SMS_LSBZ = InStr(SMS_LSXH + 7, SMS_ALL, ",,")
    If SMS_LSXH <> 0 Then '有短信息
        '读出索引和状态信息类型
        INDEX_SMS = Mid(SMS_ALL, SMS_LSXH + 7, SMS_LSBZ - SMS_LSXH - 9) '索引
        If INDEX_SMS = "1" Then
          INDEX_SMS = INDEX_SMS
        End If
        STA_SMS = Mid(SMS_ALL, SMS_LSBZ - 1, 1)    '状态
        '读出0B81 0D91 0B  0D 的位置
        SMS_LSXX = InStr(SMS_LSXH, SMS_ALL, "0891")
        SMS_LSBZ = 0
        SMS_LSBZ1 = 0
        If InStr(SMS_LSXX, SMS_ALL, "0B") > 0 Then
            SMS_LSBZ = InStr(SMS_LSXX, SMS_ALL, "0B")
        End If
        If InStr(SMS_LSXX, SMS_ALL, "0D") > 0 Then
            SMS_LSBZ1 = InStr(SMS_LSXX, SMS_ALL, "0D")
        End If
        If SMS_LSBZ > 0 Then
            If (SMS_LSBZ - SMS_LSBZ1 > 0) And SMS_LSBZ1 > 0 Then
                SMS_LSBZ = SMS_LSBZ1
            End If
        ElseIf SMS_LSBZ = 0 Then
            SMS_LSBZ = SMS_LSBZ1
        End If
        If Mid(SMS_ALL, SMS_LSBZ, 2) = "0B" Then
            NO_SMS = Mid(SMS_ALL, SMS_LSBZ + 4, 12)
            SMS_LSCR = Mid(SMS_ALL, SMS_LSBZ + 18, 2) '读出代码格式 08 unicode 00 GSM 字符
           If STA_SMS = "3" Or STA_SMS = "2" Then
                '读出有效期　和　电话号码
                DATE_SMS = Mid(SMS_ALL, SMS_LSBZ + 20, 2) '有效期
                SMS_LSNRB = SMS_LSBZ + 24
            ElseIf STA_SMS = "1" Or STA_SMS = "0" Then
                DATE_SMS = Mid(SMS_ALL, SMS_LSBZ + 20, 6) '日期
                TIME_SMS = Mid(SMS_ALL, SMS_LSBZ + 26, 6)
                SMS_LSNRB = SMS_LSBZ + 36
            End If
        ElseIf Mid(SMS_ALL, SMS_LSBZ, 2) = "0D" Then
            NO_SMS = Mid(SMS_ALL, SMS_LSBZ + 6, 12)
            SMS_LSCR = Mid(SMS_ALL, SMS_LSBZ + 20, 2) '读出代码格式 08 unicode 00 GSM 字符
           If STA_SMS = "3" Or STA_SMS = "2" Then
                '读出日期时间　和　电话号码
                DATE_SMS = Mid(SMS_ALL, SMS_LSBZ + 22, 2)
                SMS_LSNRB = SMS_LSBZ + 26
           ElseIf STA_SMS = "1" Or STA_SMS = "0" Then
                DATE_SMS = Mid(SMS_ALL, SMS_LSBZ + 22, 6) '日期
                TIME_SMS = Mid(SMS_ALL, SMS_LSBZ + 28, 6)
                SMS_LSNRB = SMS_LSBZ + 38
            End If
        End If
        If STA_SMS = "1" Or STA_SMS = "0" Then
                DATE_SMS = SMS_CODE(DATE_SMS)
        
                TIME_SMS = SMS_CODE(TIME_SMS)
        End If
        
        SMS_LSNRE = InStr(SMS_LSNRB, SMS_ALL, Chr$(13))
        SMS_NR = Mid(SMS_ALL, SMS_LSNRB, SMS_LSNRE - SMS_LSNRB)
        'SMS_NR_A = Mid(SMS_ALL, SMS_LSXH, SMS_LSNRE - SMS_LSXH)
        NO_SMS = SMS_CODE(NO_SMS)
        '读出解析短信息内容
            
            If SMS_LSCR = "00" Then
                SMS_NR = S_SMS_TO_UNICODE(SMS_NR, 0)
                
            ElseIf SMS_LSCR = "08" Then
                SMS_NR = S_SMS_TO_UNICODE(SMS_NR, 1)
            Else
            
            End If
        Text7.Text = Text7 & "索引: " & INDEX_SMS & " 状态: " & STA_SMS & vbCrLf
        If STA_SMS = "3" Or STA_SMS = "2" Then
           Text7.Text = Text7 & "有效期: " & DATE_SMS & vbCrLf
        Else
           Text7.Text = Text7 & "日期: " & Format(Mid(DATE_SMS, 1, 2) & "-" & Mid(DATE_SMS, 3, 2) & "-" & Mid(DATE_SMS, 5, 2), "DDDDDD AAAA") & " 时间:" & " " & Format(Mid(TIME_SMS, 1, 2) & ":" & Mid(TIME_SMS, 3, 2) & ":" & Mid(TIME_SMS, 5, 2), "HH:MM:SS") & vbCrLf
        End If
        Text7.Text = Text7 & "手机号码: " & NO_SMS & vbCrLf
        Text7.Text = Text7 & "内容: " & vbCrLf & SMS_NR & vbCrLf & vbCrLf
        SMS_ALL = Right(SMS_ALL, Len(SMS_ALL) - SMS_LSNRE)
        SMS_LSBZ2 = SMS_LSBZ2 + 1
        Combo1.AddItem INDEX_SMS
        Label2.Caption = SMS_LSBZ2
        If Len(SMS_ALL) < 30 Then Exit Do
    If Check1.Value = 1 Then
        MSComm1.Output = "AT+CMGD=" & INDEX_SMS & vbCrLf
        '确认标志设置
        CTN_SMS = False
        Dim AAA
        AAA = Timer
        Do
            DoEvents
            
            If Timer - AAA > 30 Then Exit Do
       Loop Until CTN_SMS = True
    End If
    Else
        Exit Do
    End If
Loop
Combo1.ListIndex = 0
End Sub
Private Function SMS_CODE(C_SMS As String) As String
Dim C_SMS1, L_SMS
SMS_CODE = ""
Dim i
If ((Len(C_SMS) \ 2) * 2 - Len(C_SMS)) = 0 Then

    For i = 1 To (Len(C_SMS) \ 2)
        C_SMS1 = Mid(C_SMS, 2 * (i - 1) + 1, 2)
        C_SMS1 = Right(C_SMS1, 1) & Left(C_SMS1, 1)
        SMS_CODE = SMS_CODE & C_SMS1
    Next
    SMS_CODE = Left(SMS_CODE, 11)
End If
End Function
Private Function S_SMS_TO_UNICODE(C_CODE As String, SAT_CODE As Integer) As String   '转换手机所存储的 发送短信息
'SAT_CODE=1 表示UNICODE 编码 SAT_CODE=0 表示GSM字符集
Dim LEN_C As Integer '接收的长度 '包括短信长度表示代码
Dim LEN_C_SMS As Integer '短信实际长度
S_SMS_TO_UNICODE = ""
Dim i, C_JS As Integer, C_JS1 As Integer

Dim BIN_LS As String, BIN_LS1 As String, BIN_LS2 As String
Dim SMS_CHR As String

Select Case SAT_CODE
    Case 0 'gsm 字符集
        C_JS = 0
        C_JS1 = 0
        For i = 1 To Len(C_CODE) \ 2
            C_JS = C_JS + 1
            C_JS1 = C_JS1 + 1
            BIN_LS = H_TO_B(Mid(C_CODE, 2 * (C_JS1 - 1) + 1, 2))
            BIN_LS1 = Right(BIN_LS, (8 - C_JS))
            BIN_LS1 = BIN_LS1 & BIN_LS2
            BIN_LS2 = Left(BIN_LS, C_JS)
            SMS_CHR = ChrW("&H0" & B_TO_H(BIN_LS1))
            
            If C_JS = 7 Then
                SMS_CHR = SMS_CHR & ChrW("&H0" & B_TO_H(BIN_LS2))
                BIN_LS1 = ""
                BIN_LS2 = ""
                BIN_LS = ""
                C_JS = 0
            End If
        S_SMS_TO_UNICODE = S_SMS_TO_UNICODE & SMS_CHR
        
        
        Next
        
    Case 1 'unicode 编码
        For i = 1 To Len(C_CODE) \ 4
            SMS_CHR = Mid(C_CODE, (i - 1) * 4 + 1, 4)
            SMS_CHR = ChrW("&H" & SMS_CHR)
            S_SMS_TO_UNICODE = S_SMS_TO_UNICODE & SMS_CHR
        Next
    Case Else
End Select
End Function
Private Function H_B_C(C_BIN As String, C_HEX As String) As String
'两个参数不能同时有数据
Dim C_BIN1 As String
If C_BIN = "" Then
        Select Case C_HEX
        Case "0"
            C_BIN1 = "0000"
        Case "1"
            C_BIN1 = "0001"
        Case "2"
            C_BIN1 = "0010"
        Case "3"
            C_BIN1 = "0011"
        Case "4"
            C_BIN1 = "0100"
        Case "5"
            C_BIN1 = "0101"
        Case "6"
            C_BIN1 = "0110"
        Case "7"
            C_BIN1 = "0111"
        Case "8"
            C_BIN1 = "1000"
        Case "9"
            C_BIN1 = "1001"
        Case "A"
            C_BIN1 = "1010"
        Case "B"
            C_BIN1 = "1011"
        Case "C"
            C_BIN1 = "1100"
        Case "D"
            C_BIN1 = "1101"
        Case "E"
            C_BIN1 = "1110"
        Case "F"
            C_BIN1 = "1111"
        Case Else
    End Select
    H_B_C = C_BIN1
ElseIf C_HEX = "" Then
        Select Case C_BIN
        Case "0000"
            C_BIN1 = "0"
        Case "0001"
            C_BIN1 = "1"
        Case "0010"
            C_BIN1 = "2"
        Case "0011"
            C_BIN1 = "3"
        Case "0100"
            C_BIN1 = "4"
        Case "0101"
            C_BIN1 = "5"
        Case "0110"
            C_BIN1 = "6"
        Case "0111"
            C_BIN1 = "7"
        Case "1000"
            C_BIN1 = "8"
        Case "1001"
            C_BIN1 = "9"
        Case "1010"
            C_BIN1 = "A"
        Case "1011"
            C_BIN1 = "B"
        Case "1100"
            C_BIN1 = "C"
        Case "1101"
            C_BIN1 = "D"
        Case "1110"
            C_BIN1 = "E"
        Case "1111"
            C_BIN1 = "F"
        Case Else
    End Select
    H_B_C = C_BIN1
Else
End If

End Function

Private Function H_TO_B(C_HEX As String) As String
Dim C_HEX_C As String, C_BIN1 As String, C_BIN2 As String, i

If Len(C_HEX) > 2 Then C_HEX = Left(C_HEX, 2)
If Len(C_HEX) < 2 Then GoTo ERR1
C_BIN2 = ""
For i = 1 To 2
    C_HEX_C = Mid(C_HEX, i, 1)
    C_BIN1 = H_B_C("", C_HEX_C)
    C_BIN2 = C_BIN2 & C_BIN1
Next
H_TO_B = C_BIN2
ERR1:
End Function
Private Function B_TO_H(C_BIN As String) As String
Dim C_BIN1 As String, C_BIN2 As String
If Len(C_BIN) = 7 Then
    C_BIN1 = H_B_C("0" & Left(C_BIN, 3), "")
    C_BIN2 = H_B_C(Right(C_BIN, 4), "")
    B_TO_H = C_BIN1 & C_BIN2
End If
End Function

Private Function ASCtoUNICODE(ASC_CT As String) As String
Dim LS_CT As String, DEST_CT As String, ALL_CT As String, DEST_A1 As String, DEST_A2 As String
ALL_CT = ""
Dim i
For i = 1 To Len(ASC_CT)
    LS_CT = Mid(ASC_CT, i, 1)
        DEST_CT = Hex(AscW(LS_CT)) 'CHRW 为范解释
        If Len(DEST_CT) = 2 Then
            DEST_CT = "00" & DEST_CT
        ElseIf Len(DEST_CT) = 1 Then
            DEST_CT = "000" & DEST_CT
        Else
        End If
    ALL_CT = ALL_CT & DEST_CT
Next
ASCtoUNICODE = ALL_CT

End Function
Private Function ZH_SMS_CODE(CODE_SMS As String) As String
Dim DEST_CODE As String, LS_CODE As String, L_CODE As Integer
L_CODE = Len(CODE_SMS)
DEST_CODE = ""
Dim i
If Len(CODE_SMS) \ 2 - Len(CODE_SMS) / 2 < 0 Then
    CODE_SMS = CODE_SMS & "F"
    For i = 1 To (L_CODE + 1) / 2
        LS_CODE = Mid(CODE_SMS, 2 * i - 1, 2)
        LS_CODE = Right(LS_CODE, 1) & Left(LS_CODE, 1)
        DEST_CODE = DEST_CODE & LS_CODE
    Next
    ZH_SMS_CODE = DEST_CODE
End If
End Function