modmain.bas

短信与酒店管理系统

Attribute VB_Name = "modMain"
'这个函数主要应用到VB自带的一个格式转换函数：ChrW（）将中文转换为Unicode码。
Dim start As Date

Public mOK As String
Public mErr As String
Public mResult As String, txtOut As String, sData As String
Dim doit As Boolean, MsgArrive As Boolean

Public Sub setDoit(mdoit As Boolean)
   doit = mdoit
End Sub

'手机短信的接收,将UNICODE转换中文
Public Function Unicode2AscII(ByVal s As String)
    On Error Resume Next
    Dim i As Integer
    Dim R As String
    For i = 1 To Len(s) Step 4
        R = R + ChrB("&H" & Mid(s, i + 2, 2)) & ChrB("&H" & Mid(s, i, 2))
    Next
    Unicode2AscII = R
End Function

'同上,为了发送以PDU模式发送短消息,必须将手机号码和对方手机号码也转换为PDU格式,下面的函数就是为了实现这种转换：
Public Function telc(num As String) As String
    Dim tl As Integer
    Dim ltem As String, rtem As String, ttem As String
    Dim ti As Integer
    ttem = ""
    tl = Len(num)
    If tl <> 11 And tl <> 13 Then
        MsgBox "号码错误:" & tl
        Exit Function
    End If
    If tl = 11 Then
        tl = tl + 2
        num = "86" & num
    End If
    For ti = 1 To tl Step 2
        ltem = Mid(num, ti, 1)
        rtem = Mid(num, ti + 1, 1)
        If ti = tl Then rtem = "F"
        ttem = ttem & rtem & ltem
    Next ti
    telc = ttem
End Function
' 将一个字符串两两转换
Public Function ExChange(ByVal num As String) As String
    Dim tl, ti As Integer
    Dim ltem As String, rtem As String, ttem As String
    tl = Len(num)
    For ti = 1 To tl - 1 Step 2
        ltem = Mid(num, ti, 1)
        rtem = Mid(num, ti + 1, 1)
        ExChange = ExChange & rtem & ltem
    Next ti
End Function

'Unicode码解码函数
Public Function Ascg(sMsg As String) As String
    Dim si As Integer, sb As Integer
    Dim stmp As Integer
    Dim stemp As String
    sb = Len(sMsg)
    Ascg = ""
    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
     Ascg = Ascg & stemp
    Next si
    Ascg = Trim(Ascg)
End Function

Public Sub Delay(pause As Double)
    start = Timer
    While Timer < start + pause
        DoEvents
    Wend
End Sub

Public Function getScsa(ByVal s As String)
    s1 = ""
    If Len(s) > 0 Then
        p = InStr(s, Chr(34))
        s1 = Mid(s, p + 1)
        p1 = InStr(s1, Chr(34))
        If p > 0 Then
            s1 = Mid(s1, 1, p1 - 1)
        End If
    End If
    getScsa = s1
End Function

Public Function sendIt(ByVal s As String, ByVal ok As String, ByVal eror As String, Optional ByVal TOut = 2) As Boolean
    mOK = ok
    mErr = eror
    'LstState.AddItem "正在发送..." & s
    If SeverFrm.MSComm1.PortOpen = False Then
        sendIt = False
        Exit Function
    End If
    SeverFrm.MSComm1.Output = s & Chr(13)
    Dim p As Double, p1 As Double, p2 As Double
    p = 0.0001 * TOut
    p2 = 0#
    doit = False
    sData = ""
    Dim dt1 As Date, dt2 As Date
    dt1 = Now
    s1 = ""
    While doit = False
        dt2 = Now
        p1 = (dt2 - dt1)
        'p2 = p1 * 10000#
        If p1 >= p Then
            doit = True
            sendIt = False
            Exit Function
        End If
        DoEvents
    Wend
    sendIt = True
End Function

Public Sub setStatus(ByVal s As String)
    SeverFrm.StatusMsg.Panels(3).Text = "" & s
End Sub