vb的工作平台.txt

一个用VB编写的通信平台

  ElseIf telnum.Text = "" Then
     warning = MsgBox("请输入电话号码", vbOKOnly, "注意")
     Exit Sub
  End If
  
  If Cmdconnect.Caption = "建立连接" Then
    Cmdconnect.Caption = "挂断"
    telnumber = telnum.Text                         '建立连接
    response = "ATD" & telnumbe
    MSComm1.Output = response
    Cmdconnect.Caption = "正在连接"
    Timer1.Enabled = True
  End If
   
  If Cmdconnect.Caption = "挂断" Then
    Timer1.Enabled = False                         '挂断同时关闭串口
    Cmdconnect.Caption = "建立连接"
    MSComm1.PortOpen = False
  End If
    
  
End Sub
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

'监视串口，是否有消息传入，并且判断消息类型
Private Sub MSComm1_OnComm()
  
  Dim temp As String
  Dim tempbyte() As Byte
  Dim remessage As order
  ReDim minglingti(4) As String
  Dim response As Integer
  
  If timebln = False Then Exit Sub '判断是否超时，超时就退出
  Dim messglen As Integer
  Dim storememoryplace  As String
      
     temp = Trim(MSComm1.Input) '读入数据
     tempbyte = temp
     messglen = Len(temp)
    
     
     If Left(temp, 7) = "AT+CNMI" Then
        storememoryplace = Right(temp, 1) '消息提示
        MSComm1.Output = "AT+CMGR" & "=" & storememoryplace
        connectsuccess = True '说明连接成功
     ElseIf (Mid(temp, 12, 16) = "ERROR") Then
        response = MsgBox("出错，请重新尝试", vbOKOnly, "请注意")
     Else
     
        Dim k As Integer
        
          For k = 1 To messglen
              If Left(temp, k) = "K" Then
                 intstart = k '消息开始的字符序号
              ElseIf Left(temp, k) = "X" Then
                 intend = k '消息结束的字符序号
                 Exit For
              Else
                 If k = messglen Then Exit Sub                         '其他情况继续
              End If
              

          Next k
    End If
                 remessage.banbenhao = Mid(temp, k + 1, 1)
                 remessage.xiaoxishu = Mid(temp, k + 2, 1)
                 remessage.xiaoxixuhao = Mid(temp, k + 3, 1)
                 remessage.shebeileixing = Mid(temp, k + 4, 1)
                 remessage.minglingbianhao = Mid(temp, k + 5, 1)
                 remessage.zhukongshebeibianhao = Mid(temp, k + 6, 4)
                 remessage.beikongshebeibianhao = Mid(temp, k + 10, 1)
                 remessage.yingdabiaozhi = Mid(temp, k + 11, 1)
                 remessage.minglingchangdu = Mid(temp, k + 12, 1)
                 remessage.minglingti = Mid(temp, k + 13, Int(minglingchangdu))
                 
                                                
   
    Dim minglingdanyuan() As Byte
         minglingdanyuan() = Mid(temp, intend + 1, 2) '得到校验单元
         CRC16jiaoyan = CRC16(minglingdanyuan)        '计算校验单元

            Select Case remessage.minglingbianhao
               Case &H20
                    Chekquary(0).Value = 0
                    quary_answer(0) = Mid(remessage.minglingti, 31, 15) '监控中心PHS短信回应电话
               Case &H10                              '告警
                    Chekquary(1).Value = 0
                    
                    warning_info1 = CByte(Left(remessage.minglingti, 1))
                    warning_nifo2 = CByte(Left(remessage.minglingti, 2))
                    
                    If warning_info1 Xor 64 Then quary_answer(1) = 1 '电源掉电告警
                    If warning_info1 Xor 8 Then quary_answer(2) = 1 '过温告警
                    If warning_info1 Xor 1 Then quary_answer(3) = 1 '门襟告警
                    If warning_info2 Xor 1 Then quary_answer(4) = 1 '参数更改告警
                    If warning_info2 Xor 16 Then quary_answer(5) = 1 '下行输出过功率告警
                 
                    
               Case &H21
                    Chekquary(1).Value = 0
                    quary_answer(1) = remessage.minglingti '主控设备号码查询
               Case &H23
                    Chekquary(2).Value = 0
                    quary_answer(2) = Mid(remessage.minglingti, 19, 1) '设备参数查询
               Case &H24
                    Chekquary(4).Value = 0
                    quary_answer(3) = Mid(remessage.minglingti, 17, 26) '被获取信道基站
                    quary_answer(4) = Mid(remessage.minglingti, 17, 26) '直放站ID
                    
               Case &H30
                    If remessage.yingdabiaozhi = &HFF Then
                        Chekset(0).Value = 0
                    End If
               Case &H31
                    If remessage.yingdabiaozhi = &HFF Then
                        quary_answer(1) = 1
                        Chekset(1).Value = 0
                    End If
               Case &H32
                    If remessage.yingdabiaozhi = &HFF Then
                        quary_answer(2) = 1
                        Chekset(2).Value = 0
                        End If
               Case &H33
                    If remessage.yingdabiaozhi = &HFF Then
                        quary_answer(3) = 1
                        Chekset(3).Value = 0
                    End If
               Case &H35
                    If remessage.yingdabiaozhi = &HFF Then
                        quary_answer(4) = 1
                        Chekset(4).Value = 0

                    End If
            End Select
            
    If CRC16jiaoyan = CRCjiaoyanwei Then
       Call writeorder(temp)  '将接受的命令写入一记事本
      n = n - 1         '每接受一条信息将等待时间减三分钟
      timenum = 0       '重新开始计时
    End If
    
    If n = 0 Then
        Call showmessage    '如果收到所有的请求信息就显示信息。
    End If
End Sub
Private Sub writeorder(remessagetpye As Variant)
   Open App.Path & "\orderhistoy.txt" For Append As #2 '将每条命令都写入记事本
      Write #2, remessagetpye
   Close #2
End Sub
'发送信息
Private Sub Fnsendmessage(message As order, i As Integer, n As Integer)

Dim minglingti As Variant
Dim minglingtibyte() As Byte
Dim jiaoyandanyuan As String

message.banbenhao = 1
message.shebeileixing = 1
message.beikongshebeibianhao = &HFF
message.zhukongshebeibianhao = &H1000109
message.yingdabiaozhi = &H0

message.xiaoxishu = n '消息总数
message.xiaoxixuhao = i + 1
message.minglingbianhao = &H20
message.minglingchangdu = &H0

 minglingti = message.banbenhao & message.xiaoxixuhao & message.xiaoxixuhao & message.shebeileixing & message.minglingbianhao & message.zhukongshebeibianhao & message.beikongshebeibianhao & message.yingdabiaozhi & message.minglingbianhao & message.minglingti
 '命令体
 minglingtibyte() = minglingti
 jiaoyandanyuan = CRC16(minglingtibyte())     '校验单元

MSComm1.Output = "AT+CMGS" & "小灵通号码(请添加）" & "V" & odermessage & jiaoyandanyuan & "X"

Timer1.Enabled = True  '判断回应是否超时

End Sub
Private Sub showmessage()

Dim i As Integer

Load Frmanswer
Frmanswer.Show

Select Case ordertype
       Case "order_quary"
            For i = 0 To 4
                Frmanswer.Txtshow(i) = quary_answer(i)
            Next i
            
            If Form1.Chekquary(0).Value = 1 Then Frmanswer.Txtshow(0).Text = "查询失败，请重试！"
            If Form1.Chekquary(2).Value = 1 Then Frmanswer.Txtshow(1).Text = "查询失败，请重试！"
            If Form1.Chekquary(3).Value = 1 Then Frmanswer.Txtshow(2).Text = "查询失败，请重试！"
            
            If Form1.Chekquary(4).Value = 1 Then
                Frmanswer.Txtshow(3).Text = "查询失败，请重试！"
                Frmanswer.Txtshow(4).Text = "查询失败，请重试！"
            End If
                    

            
       Case "order_set"
           For i = 0 To 4
               If quary_answer(i) = "1" Then Frmanswer.Labshowalam(i).ForeColor = &HFF&
           Next i
End Select

n = 0
timenum = 0
            
End Sub

'如果连接失败再次请求
Private Sub recall()
    telnumber = telnum.Text                         '建立连接
    response = "ATD" & telnumbe
    MSComm1.Output = response
    Lablwaiting.Caption = "正在连接..."
    Timer1.Enabled = True
End Sub
 
'CRC校验
Function CRC16(data() As Byte) As String

      Dim CRC16Lo As Byte, CRC16Hi As Byte      'CRC寄存器
      Dim CL As Byte, CH As Byte                '多项式码&HA001
      Dim SaveHi As Byte, SaveLo As Byte
      Dim i As Integer
      Dim Flag As Integer
      CRC16Lo = &HFF
      CL = &H1
      CRC16Hi = &HFF
      CL = &H1
      CH = &HA0
      For i = 0 To UBound(data)
        CRC16Lo = CRC16Lo Xor data(i) '每一个数据与CRC寄存器进行异或
        For Flag = 0 To 7
          SaveHi = CRC16Hi
          SaveLo = CRC16Lo
          CRC16Hi = CRC16Hi \ 2            '高位右移一位
          CRC16Lo = CRC16Lo \ 2            '低位右移一位
          If ((SaveHi And &H1) = &H1) Then '如果高位字节最后一位为1
            CRC16Lo = CRC16Lo Or &H80      '则低位字节右移后前面补1
          End If                           '否则自动补0
          If ((SaveLo And &H1) = &H1) Then '如果LSB为1，则与多项式码进行异或
            CRC16Hi = CRC16Hi Xor CH
            CRC16Lo = CRC16Lo Xor CL
          End If
        Next Flag
      Next i
      Dim ReturnData(1) As Byte
      ReturnData(0) = CRC16Hi              'CRC高位
      ReturnData(1) = CRC16Lo              'CRC低位
      CRC16 = ReturnData
    End Function
Private Sub Cmdexit_Click()
  End                                       '退出程序
End Sub