module1.bas

来自「手机短信收发.rar ,用VB编写的手机发送.」· BAS 代码 · 共 116 行

Attribute VB_Name = "Module1"
Option Explicit

Const prex = "0891"
Const midx = "11000D91"
Const sufx = "000800"

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Function telc(num As String) As String

    Dim tl As Integer
    Dim ltem, rtem, ttem As String
    Dim ti As Integer
    tl = Len(num)
    
    If tl <> 11 And tl <> 13 Then
        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 chg(rmsg As String) As String

    Dim tep As String
    Dim temp As String
    Dim i As Integer
    Dim b As Integer
    tep = rmsg
    i = Len(tep)
    b = i / 4
    If i = b * 4 Then
        b = b - 1
        tep = Left(tep, b * 4)
    Else
        tep = Left(tep, b * 4)
    End If
    
    For i = 1 To b
        temp = "H" & Mid(tep, (i - 1) * 4 + 1, 4)
        chg = chg & ChrW(CInt(Val(temp)))
    Next i

End Function

Public Function Sendsms(csca As String, num As String, msg As String) As Boolean
    Dim pdu, psmsc, pnum, pmsg As String
    Dim leng As String
    Dim length As Integer

    length = Len(msg)
    length = 2 * length
    leng = Hex(length)
    If length < 16 Then leng = "0" & leng
    psmsc = Trim(telc(csca))
    pnum = Trim(telc(num))
    pmsg = Trim(ascg(msg))
    pdu = prex & psmsc & midx & pnum & sufx & leng & pmsg
    Sleep (1)
    Form1.MSComm1.Output = "AT+CMGF=0" + vbCr
    Form1.MSComm1.Output = "AT+CMGS=" & Str(15 + length) + vbCr
    Form1.MSComm1.Output = pdu & Chr$(26)
    Sleep (1)
    Sendsms = True
End Function

'解码
Public Function ascg(smsg As String) As String

  Dim si, 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 Function sms(csca As String, num As String, msg As String) As String
    Dim pdu, psmsc, pnum, pmsg As String
    Dim leng As String
    Dim length As Integer

    length = Len(msg)
    length = 2 * length
    leng = Hex(length)
    If length < 16 Then leng = "0" & leng
    psmsc = Trim(telc(csca))
    pnum = Trim(telc(num))
    pmsg = Trim(ascg(msg))
    pdu = prex & psmsc & midx & pnum & sufx & leng & pmsg
    
    sms = pdu
End Function