mdlcommon.bas

这是一个通过手机串口实现短信发送的实例

    Dim strFileName As String
    Dim strAppend As String
    
On Error GoTo ErrorSave
    
    nFileNo = FreeFile()
    If InfoFileName = "" Then InfoFileName = "SendReord.txt"
    strFileName = App.Path & "\" & InfoFileName 'SendReord.txt"
    
    strAppend = "==========================================" & vbCrLf & _
                SaveString ' & vbCrLf

    Open strFileName For Append Access Write Shared As #nFileNo
        Print #nFileNo, strAppend
    Close #nFileNo
    Form1.Caption = "保存完毕"
    
    Exit Sub
ErrorSave:
    MsgBox "Error:" & Err & "." & vbCrLf & Err.Description
End Sub

Public Sub SaveInitSettings()
    
    Dim iFileNo As Integer
    Dim strFileName As String, strTmp As String, strTmp1 As String
    
'On Error Resume Next

    iFileNo = FreeFile()
    strFileName = App.Path & "\sys.set"
    If Dir(strFileName) <> "" Then Kill (strFileName)
    Open strFileName For Binary Access Write As #iFileNo
        Put #iFileNo, , g_SysInfo
    Close #iFileNo
    
End Sub


Public Function LoadInitSettings() As Boolean
    Dim iFileNo As Integer
    Dim strFileName As String, strTmp As String, strExprmtName As String
    Dim n As Long

On Error GoTo ErrorLoadIni

    LoadInitSettings = False
    iFileNo = FreeFile()
    strFileName = App.Path & "\sys.set"
    If Dir(strFileName) <> "" Then
        If FileLen(strFileName) > 0 Then
            Open strFileName For Binary Access Read As #iFileNo
                '-------
                Get #iFileNo, , g_SysInfo
                LoadInitSettings = True
                Err.Clear
ErrorLoadIni:
            If Err <> 0 Then MsgBox Err.Description
            Close #iFileNo
        End If
    End If
        
End Function


Public Function PickAllSMS(ByRef InputString As String, RetSMS() As SMSDef) As String

    Dim i As Integer, iTmp As Integer, iLen As Integer, iNext As Integer, iCr As Integer
    
    Dim n As Long
    
    Dim strTmp As String, strTmp1 As String, strTmp2 As String
    
    Dim btTmp() As Byte, btTmp2() As Byte
    
    Dim blRet As Boolean
    
On Error Resume Next
    
    strTmp = ""
    btTmp = InputString
    
    '======== 将短消息中的双引号去除 ========
    iTmp = 0
    For i = 0 To UBound(btTmp)
        strTmp1 = Chr(btTmp(i))
        If strTmp1 <> """" And btTmp(i) <> 0 And strTmp1 <> vbLf Then
            ReDim Preserve btTmp2(0 To iTmp + 1)
            btTmp2(iTmp) = btTmp(i)
            btTmp2(iTmp + 1) = 0
            iTmp = iTmp + 2
        End If
    Next i
    InputString = btTmp2
    
    n = 0
    i = 1
    Do
        iTmp = InStr(i, InputString, "+CMGL:")
        iCr = InStr(iTmp, InputString, vbCr)
        
        If iTmp > 0 Then
            If iCr - iTmp + 1 > 0 Then n = n + 1
        ElseIf iTmp = 0 Then
            Exit Do
        End If
        i = iTmp + 7
    Loop
    
    If n > 0 Then
        ReDim RetSMS(1 To n)
    Else
        ReDim RetSMS(0 To 0)
    End If
    
    '======== 逐条保存到数据库中 ========
    For i = 1 To n
        iTmp = InStr(InputString, "+CMGL:")
        iCr = InStr(InputString, vbCr)
        
        If iCr > 0 And iTmp > 0 Then
            InputString = Right(InputString, Len(InputString) - iTmp + 1)
            iTmp = InStr(InputString, "+CMGL:")
            iNext = InStr(iTmp + 7, InputString, "+CMGL:")
            
            If iNext > 0 Then
                strTmp = Mid(InputString, iTmp, iNext - iTmp)
                InputString = Right(InputString, Len(InputString) - iNext + 1)
            Else
                iCr = InStr(iTmp, InputString, vbCr)
                iCr = InStr(iCr + 1, InputString, vbCr)
                strTmp = Mid(InputString, iTmp, iCr - iTmp)
                InputString = Right(InputString, Len(InputString) - iCr + 1)
            End If
            
            blRet = PickOneSMS(strTmp, RetSMS(i), True)
            If blRet Then
'                RetSMS(i).SmsIndex = i
                On Error GoTo ErrorNode
ErrorNode:
            End If
        End If
    Next i

    PickAllSMS = "共有" & n & "条短信"
End Function

Public Function PickOneSMS(strInputData As String, RetSMS As SMSDef, ByVal blIsList As Boolean) As Boolean
    
    Dim blRetFunc       As Boolean
    
    Dim i As Integer, iLen As Integer, iCr As Integer
    Dim nD As Long, nRet As Long
    
    Dim strTmp As String, strTmp1 As String, strTmp2 As String, strTmp3 As String
    
    Dim MyStr()         As String
    Dim aryTmp()        As String
    
On Error GoTo ErrorSave
    
'+CMGL: 24,"REC READ","[phone]",,"04/06/03,22:35:35+32"
'4F608D767D27776189C95427002C621177E590534E86002C665A5B89
    
    '======== 取出短信息头部 ========
    
    iCr = InStr(strInputData, vbCr)
    iLen = Len(strInputData)
    If iCr > 0 And iCr <= iLen Then
        strTmp2 = Left(strInputData, iCr - 1)
        strInputData = Right(strInputData, iLen - iCr)
    End If
    
    '======== 取出短信息内容 ========
    iCr = InStr(strInputData, vbCr)
    
    iLen = Len(strInputData)
    
    If iCr > 0 Then
        If iCr <= iLen Then
            strTmp3 = Left(strInputData, iCr - 1)
            strInputData = Right(strInputData, iLen - iCr)
        End If
    Else
        If iCr < iLen Then
            strTmp3 = strInputData
        End If
    End If
    
On Error GoTo ErrorDecode
    '======== 分解短消息，以逗号(,)作为分隔符 ========
    Dim myFunc As New myVBDll
    blRetFunc = False
    blRetFunc = myFunc.String2Array(strTmp2, ",", nD, aryTmp, True)
    
ErrorDecode:
    Set myFunc = Nothing
    
    If blRetFunc Then
        '======== 如果传过来的短消息格式是"CMGL" ========
        If blIsList Then
            ReDim MyStr(0 To nD - 1)
            For i = 0 To nD - 2
                MyStr(i) = aryTmp(i + 1)
            Next i
        '======== 否则，传送过来的消息格式是"CMGR"，这两者是有区别的。 ========
        Else
            ReDim MyStr(0 To nD - 1)
            For i = 0 To nD - 1
                MyStr(i) = aryTmp(i)
            Next i
        End If
        iLen = InStr(aryTmp(0), ":")
        If iLen > 0 Then
            strTmp = Trim(Right(aryTmp(0), Len(aryTmp(0)) - iLen))
            If IsNumeric(strTmp) Then
                RetSMS.SmsIndex = CLng(strTmp)
            End If
        End If
        RetSMS.ListOrRead = blIsList
        
        '======== 如果对方的SIM号码前面有"+86"，则剔除掉 ========
        On Error Resume Next
        If Left(MyStr(1), 3) = "+86" Then
            MyStr(1) = Right(MyStr(1), Len(MyStr(1)) - 3)
        End If
        
        '======== 如果时间中含有时区，则去除 ========
        iLen = InStr(MyStr(3), "+")
        If iLen > 0 Then MyStr(3) = Left(MyStr(3), iLen - 1)
        iLen = InStr(MyStr(3), "-")
        If iLen > 0 Then MyStr(3) = Left(MyStr(3), iLen - 1)
        
        '======== 取出短信中的用户数据UD ========
        iCr = InStr(strTmp3, vbCr)
        If iCr > 0 Then
            strTmp3 = Left(strTmp3, iCr - 1)
        End If
        
        '======== 分别提取短消息的详细内容 ========
        RetSMS.SmsMain = DecodeUnicode(strTmp3)
        RetSMS.SourceNo = MyStr(1)
        RetSMS.ReachDate = MyStr(2)
        RetSMS.ReachTime = MyStr(3)
        
        If Err = 0 Then PickOneSMS = True
    End If
    
    Exit Function
    
ErrorSave:
    PickOneSMS = False
End Function

Public Function DecodeUnicode(ByVal UnicodeString As String) As String
    Dim strUnicode As String
    Dim objDll As New myVBDll
    
On Error GoTo ErrorUnicode
    
    strUnicode = UnicodeString
    DecodeUnicode = objDll.Unicode2GB(strUnicode)
    
    Set objDll = Nothing
    
    Exit Function

ErrorUnicode:
    Set objDll = Nothing
    MsgBox "Error:" & Err & "." & vbCrLf & Err.Description
End Function

Public Function AddTask(ByRef TaskWord As Long, _
                        TaskTable() As String, _
                        ByVal WorkTask As Long, _
                        ByVal TaskID As Long, _
                        ByVal WillDo As String) As Boolean
    
    On Error GoTo ErrorAdd
    
    TaskWord = TaskWord Or WorkTask
    TaskTable(TaskID) = WillDo
    AddTask = True
    Exit Function
ErrorAdd:
    AddTask = False
End Function