frmreceive.frm

一个采用VB编写的短信发送和接收管理软件。

'发送格式卡号转化为正常SIM卡号，输入12字符，输出11位字符
'**************************************************************
Public Function SIMReceiveChange(SIMString As String) As String
    Dim I  As Integer
    
    If Len(SIMString) = 0 Then
        SIMReceiveChange = ""
        Exit Function
    End If
    
    I = 2
    Do While I <= 10
        SIMReceiveChange = SIMReceiveChange + Mid(SIMString, I, 1) + Mid(SIMString, I - 1, 1)
    I = I + 2
    Loop
    SIMReceiveChange = SIMReceiveChange + Mid(SIMString, 12, 1)
End Function

'/////////////////////////////////////////////////////////////////////
'任意长度的十六进制字符转二进制字符
'/////////////////////////////////////////////////////////////////////
Public Function HtoB_long(in_Hex As String) As String
    Dim I As Integer
    in_Hex = LTrim(RTrim(in_Hex))
    I = 1
    For I = 1 To Len(in_Hex)
        HtoB_long = HtoB_long + HtoB(Mid(in_Hex, I, 1))
    Next
End Function

'///////////////////////////////////////////////////////
'输入一位十六进制数，输出4位二进制。错误返回空字符串。
'///////////////////////////////////////////////////////
Public Function HtoB(in_Hex As String) As String
    Dim tempArray(4) As Integer
    Dim tempX As Integer
    Dim I As Integer
    Select Case UCase(in_Hex)
      Case "A"
        tempX = 10
      Case "B"
        tempX = 11
      Case "C"
        tempX = 12
      Case "D"
        tempX = 13
      Case "E"
        tempX = 14
      Case "F"
        tempX = 15
      Case Else
        If IsNumeric(in_Hex) Then
            tempX = Val(in_Hex)
        Else
            HtoB = ""
            '此处填加错误提示
            'MsgBox "HtoB函数错误！in_Hex=" & in_Hex
            Exit Function
        End If
    End Select
    I = 1
    For I = 1 To 4
      tempArray(I) = Int(tempX / (2 ^ (4 - I)))
      tempX = tempX Mod 2 ^ (4 - I)
    Next
    HtoB = LTrim(Str(tempArray(1))) + LTrim(Str(tempArray(2))) + LTrim(Str(tempArray(3))) + LTrim(Str(tempArray(4)))
End Function

'///////////////////////////////////////////////////////////
'二进制字符串转化为十进制字符串
'///////////////////////////////////////////////////////////
Public Function BtoD(str_input As String) As String
    Dim tempBtoD As Long
    Dim I As Integer
    I = 1
    For I = 1 To Len(str_input)
        tempBtoD = Val(Mid(str_input, I, 1)) * 2 ^ (Len(str_input) - I) + tempBtoD
    Next
    BtoD = Format(tempBtoD, "0")
End Function

'////////////////////////////////////////
'两字符十六进制数转化为十进制数
'////////////////////////////////////////
Public Function HtoD_2byte(ByVal in_Hex As String) As Double
    HtoD_2byte = Val(HtoD_1byte(Mid(in_Hex, 1, 2))) * 256 + Val(HtoD_1byte(Mid(in_Hex, 3, 2)))
End Function

'/////////////////////////////////////////////////////////
'单字符型十六进制数转化为十进制数
'/////////////////////////////////////////////////////////
Private Function HtoD_1byte(in_Hex As String) As String
    Dim dec_temp As Integer
    Dim N As Integer
    Dim Temp As Integer
    Dim Temp1 As String
    N = 1
    Do While N <= 2
        Temp1 = Mid(in_Hex, N, 1)
        Select Case Temp1
            Case "A"
                Temp = 10
            Case "B"
                Temp = 11
            Case "C"
                Temp = 12
            Case "D"
                Temp = 13
            Case "E"
                Temp = 14
            Case "F"
                Temp = 15
            Case Else
                Temp = Val(Temp1)
        End Select
        If N = 1 Then
            dec_temp = Temp * 16
        Else
            dec_temp = dec_temp + Temp
        End If
        N = N + 1
    Loop
    HtoD_1byte = LTrim(Str(dec_temp))
End Function

'/////////////////////////////////////////////////////
'检验输入字符串是否是十六进制字符串，返回逻辑值。
'/////////////////////////////////////////////////////
Private Function IsHexStr(ByVal vInputStr As String) As Boolean
    Dim I As Integer
    Dim Str As String
    
    IsHexStr = True
    If vInputStr = "" Then
        IsHexStr = False
        Exit Function
    End If
    
    For I = 1 To Len(vInputStr)
        Str = UCase(Mid(vInputStr, I, 1))
        If Not (IsNumeric(Str) Or Str = "A" Or Str = "B" Or Str = "C" Or Str = "D" Or Str = "E" Or Str = "F") Then
            IsHexStr = False
            Exit For
        End If
    Next
End Function

'////////////////////////////////////////////
'处理短信
'////////////////////////////////////////////
Private Sub SMSTrac(ByVal vInputStr As String)
    Dim StartPosition As Integer
    Dim SMSContentLen As Integer
    Dim SMSContent As String
    Dim PubSimNumber As String
    Dim SMSStr As String
    Dim UnZipStr As String
    Dim I As Integer
    Dim tmpStr As String
    If Len(vInputStr) = 0 Then
        Exit Sub
    End If
        If InStr(vInputStr, "08916831") <> 0 Then
            StartPosition = InStr(vInputStr, "08916831")
            If StartPosition - 4 > 0 Then
                PubSimNumber = SIMReceiveChange(Mid(vInputStr, StartPosition + 26, 12))
                If Mid(vInputStr, StartPosition + 40, 2) = "00" Then
                    ''短信按英文方式处理 注:SMSContentLen是整条短信的长度。
                     'SMSContentLen = Val(HtoD_1byte(Mid(vInputStr, StartPosition + 56, 2))) * 2
                    SMSContentLen = Val(Mid(vInputStr, StartPosition - 5, 3)) - 20
                    SMSContent = (Mid(vInputStr, StartPosition + 58, SMSContentLen * 2))
                    UnZipStr = PubUnZip_English(SMSContent)
                    PubStatus "收到" & PubSimNumber & "发来短信。", True
                    'PubStatus "短信内容：" & SMSContent
                     '//////////////
                     '//存入数据库
                    '///////////////
                    SmsSaveDataBase Now, PubSimNumber, UnZipStr
                    PubStatus "发来内容：" & UnZipStr
                    'APIBeep 2000, 3000
                ElseIf Mid(vInputStr, StartPosition + 40, 2) = "08" Then
                    '短信按中文方式处理 注:SMSContentLen是整条短信的长度。
                    PubStatus "短信内容：" & vInputStr
                    SMSContentLen = Val(HtoD_1byte(Mid(vInputStr, StartPosition + 56, 2))) * 2
                    SMSContent = Mid(vInputStr, StartPosition + 58, SMSContentLen)
                    UnZipStr = PubUnZip_Chinese(SMSContent)
                    PubStatus "收到" & PubSimNumber & "发来短信。", True
                    'PubStatus "短信内容：" & SMSContent
                      '////////////
                      '//存入数据库
                      '/////////////
                    SmsSaveDataBase Now, PubSimNumber, UnZipStr
                    PubStatus "发来内容：" & UnZipStr
                   ' APIBeep 2000, 3000
                
                Else
                    PubStatus "不可识别的信息类型：" & Mid(vInputStr, StartPosition + 40, 2)
                    '保存不可识别信息到通讯文本文件
                    'SmsSaveDataBase Now, "", ""
                    PubStatus "收到不可识别的信息类型，信息内容：" & vInputStr, True
                End If
            Else
                PubStatus "短信长度非法。"
            End If
        End If
End Sub
'//保存到数据库
Private Sub SmsSaveDataBase(ByVal ReceiveTime As Date, ByVal SendSim As String, ByVal Sendstr As String)
Dim tb_Sms As New ADODB.Recordset
tb_Sms.Open "select*from receiveSms where 接收时间>#" & Now & "# ", Cn, adOpenKeyset, adLockPessimistic
    With tb_Sms
    .AddNew
    .Fields!接收时间 = ReceiveTime
    .Fields!手机号 = SendSim & " "
    .Fields!接收内容 = Sendstr & " "
    .Fields!是否提示 = "否"
    .Update
    End With
tb_Sms.Close
End Sub
Private Sub SetNoInt()
  G18.Output = "at+cnma" & Chr(13)
End Sub

'////////////////////////////////////////////
'处理状态报告
'////////////////////////////////////////////
Private Sub RpTrac(ByVal vInputStr As String)
    Dim StartPosition As Integer
    Dim SMSContentLen As Integer
    Dim SMSContent As String
    Dim PubSimNumber As String
    Dim FlagStr As String
    Dim tb_SQ As New ADODB.Recordset
    If Len(vInputStr) = 0 Then
        Exit Sub
    End If
        If InStr(vInputStr, "08916831") <> 0 Then
            StartPosition = InStr(vInputStr, "08916831")
            Debug.Print Mid(vInputStr, StartPosition + 68)
            FlagStr = Mid(vInputStr, StartPosition + 68, 2)
            If StartPosition - 4 > 0 Then
                PubSimNumber = SIMReceiveChange(Mid(vInputStr, StartPosition + 28, 12))
                With tb_SQ
                    .Open "select * from SendQueue where 发送标志='已发'and 手机号='" & PubSimNumber & "'", Cn, adOpenDynamic, adLockOptimistic
                 If Not .EOF Then
                    If FlagStr = "00" Then
                      .Fields!发送标志 = "成功"
                       PubStatus "收到向" & PubSimNumber & "发送短信成功的状态报告"
                      ' APIBeep 500, 3000
                     Else
                       .Fields!发送标志 = "失败2"
                       PubStatus "收到向" & PubSimNumber & "发送短信失败的状态报告"
                       'APIBeep 1000, 3000
                    End If
                    .Update
                 End If
                    .Close
                End With
                Else
                    PubStatus "收到不可识别的信息类型，信息内容：" & vInputStr, True
                End If
            Else
                PubStatus "短信长度非法。"
        End If
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Static Message As Long
Static RR As Boolean
    Message = X / Screen.TwipsPerPixelX
    
    If RR = False Then
        RR = True
        Select Case Message
            Case WM_LBUTTONDBLCLK
                    Me.Show
                    TrayIcon.cbSize = Len(TrayIcon)
                    TrayIcon.hWnd = Me.hWnd
                    TrayIcon.uId = vbNull
                    Call Shell_NotifyIcon(NIM_DELETE, TrayIcon)
           Case WM_RBUTTONUP
        End Select
        RR = False
    End If
End Sub
Private Sub addicon()
    TrayIcon.cbSize = Len(TrayIcon)
    TrayIcon.hWnd = Me.hWnd
    TrayIcon.uId = vbNull
    TrayIcon.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
    TrayIcon.ucallbackMessage = WM_MOUSEMOVE
    TrayIcon.hIcon = Me.Icon
    TrayIcon.szTip = Trim("Sms Receive and Send")
    Call Shell_NotifyIcon(NIM_ADD, TrayIcon)
    App.TaskVisible = False
    Me.Hide
End Sub
Private Sub txtStatus_DblClick()
Me.Hide
addicon
End Sub

Private Sub ShowForm()
Me.Show
TrayIcon.cbSize = Len(TrayIcon)
TrayIcon.hWnd = Me.hWnd
TrayIcon.uId = vbNull
Call Shell_NotifyIcon(NIM_DELETE, TrayIcon)
End Sub