module1.bas

手机短心控制接收发射程序,通过串口与手机连接,

Attribute VB_Name = "Module1"
Option Explicit

Public mSN As String ' = "IMEI352495000428231"
Public Const vSn = "jinliucmCuiMingSuZhou"

Public frmSentB As Boolean
Public frmPhoneB As Boolean
Public SentB As Boolean
Public opId As Integer
Public comPId As Integer
Public myDb As Database, myRs As Recordset, SentSms As Recordset, ReadSms As Recordset
Declare Function GetTickCount Lib "kernel32" () As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Sub Main()
On Error Resume Next
    Set myDb = DBEngine.Workspaces(0).OpenDatabase(App.Path & "\mytel97.MDB")
    Set myRs = myDb.OpenRecordset("phonebook", dbOpenDynaset)
    Set SentSms = myDb.OpenRecordset("SentSms", dbOpenDynaset)
    Set ReadSms = myDb.OpenRecordset("ReadSms", dbOpenDynaset)
    frmMain.Show
    frmTip.Show 1
End Sub

'对数据表(电话簿)进行编辑
Public Function dbPhoneBook(dOperate As String, dName As String, dTelNum As String, Optional dClassify As String, Optional py As String) As Boolean
    Dim txtTmp As String
    Dim i As Integer
    Set myRs = myDb.OpenRecordset("phonebook", dbOpenDynaset)
    Select Case dOperate
        Case "add"
            If DupCheck("phonebook", "telnum", dTelNum, "tel") = True Then Exit Function
            myRs.AddNew
            If dName <> "" Then myRs("name") = dName
            If dTelNum <> "" Then myRs("telnum") = dTelNum
            If dName <> "" Then
                For i = 1 To Len(dName)
                    txtTmp = txtTmp & pinYin(Mid(dName, i, 1))
                Next i
            End If
            If txtTmp <> "" Then myRs("mem") = txtTmp
        Case "del"
        Case "edit"
            myRs.Edit
    End Select
        myRs.Update
        myRs.Clone
End Function

'对数据表(短信)进行编辑
Public Function smsADD(pTableName As String, pTable As Recordset, dDate As String, dTelNum As String, dSms As String) As Boolean

    'If DupCheck(pTableName, "sms", dDate, "sms") = True Then Exit Function
    pTable.AddNew
        If dDate <> "" Then pTable("date") = dDate
        If dTelNum <> "" Then pTable("telnum") = dTelNum
        If dSms <> "" Then pTable("sms") = dSms
    pTable.Update
End Function

'检查电话号码是否正确
Public Function checkTelNum(telN As String) As Boolean
    Dim i As String
    i = Mid(telN, 1, 1)
    If i = "+" Then
        telN = Right(telN, Len(telN) - 1)
        If IsNumeric(telN) = True Then
            checkTelNum = True
        Else
            checkTelNum = False
        End If
    Else
        If IsNumeric(telN) = True Then
            checkTelNum = True
        Else
            checkTelNum = False
        End If
    End If
End Function

'根据电话号码从数据表(电话簿)查姓名
'原理:先根据短信中的电话号码查姓名,如为空则删除短信号码中的"+XX"("+86)继续查,如仍为空则显示"未知"
Public Function findName(telN As String) As String
    Set myRs = myDb.OpenRecordset("select * from phonebook where telnum='" & telN & "'", dbOpenDynaset)
    findName = DataRec(myRs, "name")
    If findName = "" Then Set myRs = myDb.OpenRecordset("select * from phonebook where telnum='" & delPrefix(telN) & "'", dbOpenDynaset)
    findName = DataRec(myRs, "name")
    If findName = "" Then findName = "未知"
    myRs.Close
End Function

'如手机号码中有"+XX"("+86")字样则删除
Public Function delPrefix(telN As String) As String
    Dim i As Integer
    i = InStr(1, telN, "+")
    If i > 0 Then
        delPrefix = Right(telN, Len(telN) - 3)
    Else
        delPrefix = telN
    End If
End Function

'UnCode转换成Text
Public Function chrConvert(unCodeStr As String) As String
Dim i As Integer
On Error Resume Next
    Dim txtNumber As Integer
    txtNumber = Len(unCodeStr) / 4
    For i = 0 To txtNumber - 1
        chrConvert = chrConvert & ChrW("&h" & Mid(unCodeStr, 4 * i + 1, 4))
    Next i
End Function

'Text转换成UnCode
Public Function ascConvert(smsg As String) As String
    Dim si, sb As Integer
    Dim stmp As Integer
    Dim stemp As String
    sb = Len(smsg)
    ascConvert = ""
    For si = 1 To sb
     stmp = AscW(Mid(smsg, si, 1))
     If Abs(stmp) < 127 Then
     stemp = "00" & Hex(stmp)
     Else
     stemp = Hex(stmp)
     End If
     ascConvert = ascConvert & stemp
    Next si
    ascConvert = Trim(ascConvert)
End Function

'读出数据
Public Function DataRec(ByVal pTable As Recordset, ByVal pField As Variant) As Variant
On Error GoTo Err
If Not IsNull(pTable(pField)) Then
    DataRec = pTable(pField)
Else
Err:
    Select Case pTable.Fields(pField).Type
        Case dbText, dbMemo:
            DataRec = ""
        Case dbDate:
            DataRec = Date
        Case dbBoolean:
            DataRec = False
        Case Else:
            DataRec = 0
    End Select
End If
End Function

'压缩数据库
Public Sub CompactMyDatabase(ByVal pPathName As String, ByVal pFileName As String)
Dim mTempName, mFilename As String
mTempName = pPathName & "Temp.MDB"
mFilename = pPathName & pFileName & ".MDB"
If Dir(mFilename) = "" Then Exit Sub
On Error GoTo ErrCpt
Call CompactDatabase(mFilename, mTempName, dbLangGeneral)
Call Kill(mFilename)
Name mTempName As mFilename
Exit Sub
ErrCpt:
End Sub

'修复数据库
Public Sub RepairMyDatabase(ByVal pPathName As String, ByVal pFileName As String)
Call RepairDatabase(pPathName & pFileName & ".MDB")
End Sub

'检查该字符串是否为空?
Function EmptyCheck(ByVal pString As String, ByVal pMess As String) As Boolean
If Len(pString) = 0 Then
    Call MsgBox(pMess & "不能为空！", vbExclamation + vbOKOnly, "提示")
    EmptyCheck = True
Else
    EmptyCheck = False
End If
End Function

'检查该字符串是否重复?
Function DupCheck(ByVal pName As String, ByVal pIndex As String, ByVal pString As String, ByVal pMess As String) As Boolean
Dim mTable As Recordset

Set mTable = myDb.OpenRecordset(pName)
mTable.Index = pIndex
mTable.Seek "=", pString
If Not mTable.NoMatch Then
    'Call MsgBox(pMess & "已经存在！", vbExclamation + vbOKOnly, "提示")
    DupCheck = True
Else
    DupCheck = False
End If
End Function
Public Sub PauseWait(HowLong As Long)
    Dim u%, tick As Long
    tick = GetTickCount()
    Do
      u% = DoEvents
    Loop Until tick + HowLong < GetTickCount
End Sub
Public Function pinYin(p As String) As String
    Dim i
    i = Asc(p)
    Select Case i
        Case -20319 To -20284:     pinYin = "A"
        Case -20283 To -19776:     pinYin = "B"
        Case -19775 To -19219:     pinYin = "C"
        Case -19218 To -18711:     pinYin = "D"
        Case -18710 To -18527:     pinYin = "E"
        Case -18526 To -18240:     pinYin = "F"
        Case -18239 To -17923:     pinYin = "G"
        Case -17922 To -17418:     pinYin = "H"
        Case -17417 To -16475:     pinYin = "J"
        Case -16474 To -16213:     pinYin = "K"
        Case -16212 To -15641:     pinYin = "L"
        Case -15640 To -15166:     pinYin = "M"
        Case -15165 To -14923:     pinYin = "N"
        Case -14922 To -14915:     pinYin = "O"
        Case -14914 To -14631:     pinYin = "P"
        Case -14630 To -14150:     pinYin = "Q"
        Case -14149 To -14091:     pinYin = "R"
        Case -14090 To -13319:     pinYin = "S"
        Case -13318 To -12839:     pinYin = "T"
        Case -12838 To -12557:     pinYin = "W"
        Case -12556 To -11848:     pinYin = "X"
        Case -11847 To -11056:     pinYin = "Y"
        Case -11055 To -2050:      pinYin = "Z"
        Case Else:                 pinYin = "("
    End Select
End Function