form1.frm

WAP新闻系统,使用感觉还可以,比较合适改写

    Next i
    
    '----------------逐条取出短信的具体内容--------------------
    For i = 1 To num
        Text2.Text = Text2.Text & Chr(13) + Chr(10) & accept_info(i)
        phone_num = Mid(accept_info(i), 27, 12)
        phone_num = Mid(phone_num, 2, 1) & Mid(phone_num, 1, 1) & _
            Mid(phone_num, 4, 1) & Mid(phone_num, 3, 1) & _
            Mid(phone_num, 6, 1) & Mid(phone_num, 5, 1) & _
            Mid(phone_num, 8, 1) & Mid(phone_num, 7, 1) & _
            Mid(phone_num, 10, 1) & Mid(phone_num, 9, 1) & _
            Mid(phone_num, 12, 1) '& Mid(phone_num, 11, 1)
        dx_info = Right(accept_info(i), Len(accept_info(i)) - 58)
        If InStr(accept_info(i), "000830") > 0 Then '中文短信
            dx_info = uc_to_chinese(dx_info) '转换成汉字
        Else
            dx_info = uc_to_english(dx_info) '英文短信
        End If
        accept_date = Mid(accept_info(i), 45, 4)
        accept_date = Mid(accept_date, 2, 1) & _
            Mid(accept_date, 1, 1) & "-" & _
            Mid(accept_date, 4, 1) & Mid(accept_date, 3, 1)
        accept_time = Mid(accept_info(i), 49, 6)
        accept_time = Mid(accept_time, 2, 1) & _
            Mid(accept_time, 1, 1) & ":" & _
            Mid(accept_time, 4, 1) & _
            Mid(accept_time, 3, 1) & ":" & _
            Mid(accept_time, 6, 1) & Mid(accept_time, 5, 1)
        
        '--------------根据手机号码找出发信人姓名以及发给何人----------
        flag_find = False
        For j = 1 To user_num
            If myuser(j).gsm_num = phone_num Then
                accept_name = myuser(j).name
                accept_bh = myuser(j).bh
                send_name = myuser(j).father_name
                flag_find = True
                Exit For
            End If
        Next j
        If flag_find = False Then
            accept_name = "无名"
            accept_bh = "无号"
        End If
        
        '---------------------插入到短信接收库中---------------
        sql_insert = "insert into accept_info " & _
            "(接收人编号学号,接收人姓名,短信内容,发信人姓名," & _
            "发信手机号码,接收日期,接收时间) values ( '" & _
            accept_bh & "','" & accept_name & "','" & _
            dx_info & "' ,'" & send_name & "','" & _
            phone_num & "','" & Date & "','" & Time & "')"
        Debug.Print sql_insert
        rs_myinsert.Open sql_insert, adoCn, adOpenStatic, adLockReadOnly, 1
                
    
        Text2.Text = Text2.Text & Chr(13) + Chr(10) & _
            phone_num & Space(5) & accept_name & Space(5) & _
            accept_bh & dx_info & Space(5) & accept_date & _
            Space(5) & accept_time
    
        out = "at+cmgd=" & CStr(i) '删除该条短信
        MSComm1.Output = out
        DoEvents
        start = Timer
        pause = 1
        While Timer < start + pause '延时1秒
            DoEvents
        Wend
    Next i
End Sub




Private Sub Form_Load()
'Public xxzx As String '短信服务中心号码
'Public ucs2 As String '要发送的信息的ｕｃｓ２编码
'Public len_ucs2 As String  '要发送的信息的ｕｃｓ２编码的长度的十六进制表示
'Public sjhma_ys As String '原始手机号码
'Public sjhma_bh As String  '变换后的手机号码
'Public geshi1 As String '固定格式１
'Public geshi2 As String '固定格式２
'xxzx = "0891683110301405F0" '常州联通短信服务中心
xxzx = "0891683108509105F0" '常州移动短信服务中心

geshi1 = "11000D91"
geshi2 = "000800"

  MSComm1.CommPort = 1
    MSComm1.PortOpen = True
    MSComm1.InBufferCount = 0
    MSComm1.OutBufferCount = 0
        MSComm1.Output = "AT+CMGF=0" + vbCr '以Pdu模式发送短信
        DoEvents
    MSComm1.InputLen = 0

Call init_user
Call init_font
End Sub
Public Function uc_to_chinese(mystr As String)
Dim l As Integer
Dim temp_chinese As String
Dim temp_str As String
Dim out As String
Dim flag_find As Boolean
l = Len(mystr)
Dim i As Integer
For i = 1 To l Step 4
    temp_str = Mid(mystr, i, 4)
    flag_find = False
    For j = 1 To font_num
        If myfont(j).ucs2 = temp_str Then
        temp_chinese = myfont(j).chinese
        flag_find = True
        Exit For
        End If
        
    Next j
    
    If flag_find = True Then
    out_str = out_str + temp_chinese
    Else
    out_str = out_str + "*"
    End If
    
Next i
uc_to_chinese = out_str
End Function
Public Function uc_to_english(mystr As String)
Dim l As Integer
Dim temp_chinese As String
Dim temp_str As String
Dim out As String
Dim flag_find As Boolean
l = Len(mystr)
Dim i As Integer
For i = 1 To l Step 2
    temp_str = "FF" & Mid(mystr, i, 2)
    flag_find = False
    For j = 1 To font_num
        If myfont(j).ucs2 = temp_str Then
        temp_chinese = myfont(j).chinese
        flag_find = True
        Exit For
        End If
        
    Next j
    
    If flag_find = True Then
    out_str = out_str + temp_chinese
    Else
    out_str = out_str + "*"
    End If
    
Next i
uc_to_chinese = out_str
End Function
Public Function get_ucs2(mystr As String)
Dim i As Integer
Dim c As String
Dim u As Integer
Dim h As String

Dim temp_str As String
Dim temp_len As Integer
mystr = Trim(mystr)
temp_len = LenB(mystr) '必须用lenb()
For i = 1 To temp_len Step 2
c = MidB$(mystr, i, 2)

u = AscW(c)
h = Hex(u)
Debug.Print c, u, h
If Len(h) < 4 Then
h = String(4 - Len(h), "0") & h '避免非汉字字符的ｕｓｃ２码，小于４
End If
Debug.Print c, u, h
Debug.Print "----------------"

temp_str = temp_str + h
Debug.Print temp_str
Next i

get_ucs2 = temp_str

End Function
Public Function get_ucs1(mystr As String)
Dim i As Integer
Dim j As Integer
Dim c As String
Dim u As Integer
Dim h As String
Dim flag As Boolean

Dim temp_str As String
Dim temp_len As Integer
mystr = Trim(mystr)
temp_len = LenB(mystr) '必须用lenB()
For i = 1 To temp_len Step 2
    c = MidB$(mystr, i, 2)
    flag = False
    For j = 1 To font_num
        If myfont(j).chinese = c Then
            'u = AscW(c)
            h = myfont(j).ucs2
            If Len(h) < 4 Then
                h = String(4 - Len(h), "0") & h '避免非汉字字符的ｕｓｃ２码，小于４
            End If
            flag = True
            Exit For
        End If
    Next j
    Debug.Print c, u, h
    Debug.Print "----------------"
    If flag = False Then
    h = "0020" '如果找不到,用空格代替
    End If
    
    temp_str = temp_str & h
   
Next i

'Debug.Print temp_str
get_ucs1 = temp_str

End Function

Private Sub MSComm1_OnComm()
Dim in_str As String

Select Case MSComm1.CommEvent
   ' Handle each event or error by placing
   ' code below each case statement

' 错误
      Case comEventBreak   ' 收到 Break。
       Case comEventCDTO   ' CD (RLSD) 超时。
      Case comEventCTSTO   ' CTS Timeout。
      Case comEventDSRTO   ' DSR Timeout。
      Case comEventFrame   ' Framing Error
      Case comEventOverrun   '数据丢失。
      Case comEventRxOver '接收缓冲区溢出。
      Case comEventRxParity ' Parity 错误。
      Case comEventTxFull   '传输缓冲区已满。
      Case comEventDCB   '获取 DCB] 时意外错误

   ' 事件
      Case comEvCD   ' CD 线状态变化。
      Case comEvCTS   ' CTS 线状态变化。
      Case comEvDSR   ' DSR 线状态变化。
      Case comEvRing   ' Ring Indicator 变化。
      Case comEvSend   ' 传输缓冲区有 Sthreshold 个字符                     '
                     '
      Case comEvEOF   ' 输入数据流中发现 EOF 字符
      Case comEvReceive   ' 收到 RThreshold # of chars.
      
      With MSComm1
      in_str = .Input
      Text2.Text = Text2.Text & Chr(10) + Chr(13) & in_str
      
      End With
               '
   End Select

End Sub
Private Sub mybackup1() '备份发布信息并修改用户信息库中发布总次数和故障次数
Dim rs_mybackup As New ADODB.Recordset
Dim rs_updata_user_info As New ADODB.Recordset
Dim sql_backup As String
Dim sql_dele As String
Dim sql_update As String

'sql_mybackup = "select 编号学号,姓名,短信内容,紧急程度,是否已发布,是否发布成功,发布日期,发布时间 from 备份"
         sql = "select 编号学号,姓名,短信内容,紧急程度,是否已发布,是否发布成功,发布日期,发布时间 from today_send_info where 是否发布成功=" & True
Debug.Print sql
adoRs.Open sql, adoCn, adOpenForwardOnly, adLockReadOnly
While Not adoRs.EOF
sql_mybackup = "insert into 备份 ( 编号学号,姓名,短信内容,紧急程度,是否已发布,是否发布成功,发布日期,发布时间) values ( '" & adoRs(0) & "','" & adoRs(1) & "','" & adoRs(2) & "' ," & adoRs(3) & "," & adoRs(4) & "," & adoRs(5) & ", '" & adoRs(6) & "','" & adoRs(7) & "')"
Debug.Print sql_mybackup
rs_mybackup.Open sql_mybackup, adoCn, adOpenStatic, adLockReadOnly, 1 '备份发布信息

'------修改用户信息库中发布总次数和故障次数
    sql_update = "update user_info set 总次数=总次数+1 where 编号学号 ='" & adoRs(0) & "'"
    If Not adoRs(5) Then sql_update = "update user_info set 总次数=总次数+1 ,故障次数=故障次数 +1 where 编号学号 ='" & adoRs(0) & "'"
    Debug.Print sql_update
    rs_updata_user_info.Open sql_update, adoCn, adOpenStatic, adLockReadOnly, 1
'---------------------------------------------
adoRs.MoveNext
Wend
sql_dele = "delete * from today_send_info where " & True ' 是否发布成功"
'adoRs.Open sql_dele,adoCn, adOpenForwardOnly, adLockReadOnly, 1 '暂时不删除，正式调试完毕后应该删除
adoRs.Close
End Sub
Private Sub mybackup2()
Dim rs_mybackup As New ADODB.Recordset
sql = "select * into 备份1 from today_send_info"
'sql = "select 编号学号,姓名,短信内容,紧急程度,是否已发布,是否发布成功,发布日期,发布时间 from 备份"
rs_mybackup.Open sql, adoCn, adOpenDynamic, adLockBatchOptimistic, 1
End Sub