module1.bas

基于RS－232的

Attribute VB_Name = "Module1"
'目标地址
Public Const T_ADDR1 As Byte = &H1& '对应多路转换开关连接的被测仪器
Public Const T_ADDR2 As Byte = &H2&
Public Const T_ADDR3 As Byte = &H3&
Public Const T_ADDR4 As Byte = &H4&
Public Const T_ADDR5 As Byte = &H5&
Public Const T_ADDR6 As Byte = &H6&
Public Const T_ADDR7 As Byte = &H7&
Public Const T_ADDR8 As Byte = &H8&
Public Const T_ADDR9 As Byte = &H9&
Public Const T_ADDR10 As Byte = &HA&
Public Const T_ADDR11 As Byte = &HB&
Public Const T_ADDR12 As Byte = &HC&
Public Const T_ADDR13 As Byte = &HD&
Public Const T_ADDR14 As Byte = &HE&
Public Const T_ADDR15 As Byte = &HF&
Public Const T_ADDR16 As Byte = &H10&

Public Const PC_ADDR0 As Byte = &H11& 'PC机A
Public Const PC_ADDR1 As Byte = &H12& 'PC机B
Public Const DLZ_ADDR As Byte = &H13&  '多路转换开关地址

Public Const PO7D_ADDR As Byte = &H21& 'PO7D设备地址
Public Const CNT81_ADDR As Byte = &H22& 'CNT81的设备地址
Public Const XN_ADDR As Byte = &H23& '虚拟测量设备地址

'包头 包尾
Public Const PKStart As Byte = &H7E&
Public Const PKEND As Byte = &H7E&

'下位机应答包标志位
Public Const ACK_OK As Byte = &H1&
Public Const ACK_FAIL As Byte = &H2&
Public Const ACK_OVERTIME As Integer = 1000 '超时时间1秒

'当前发送的命令
Public COMM_CurCmd As Byte

'当前连接的测量仪器地址
Public COMM_SurveyADDR As Byte

'包头包尾判别标志
Public COMM_PKStartFlag As Boolean, COMM_PKEndFlag As Boolean

'收到包的个数
Public COMM_RcvDataNum As Integer, RcvData() As Byte '收到数据

Public COMM_SendPacket() As Byte '当前发送的包
Public COMM_ReSendTimes As Integer '记录重传次数
Public COMM_isSendOverFlag As Boolean '发送是否结束
Public COMM_isACKFlag As Boolean '检测是否有应答
Private overtime_timer As Timer '超时时钟
Private COMM_RcVMSCOMM As MSComm, COMM_SendMSCOMM As MSComm '使用的发送控件
Public Const HISPACKETNUM As Integer = 3 '历史包的总包数
Public COMM_CurHisPackIndex As Integer   '当前发送的历史包序列号
Public COMM_CurDestADDR As Byte  '当前访问下位机的地址
Private RcvDataByteIndex As Integer '接收字节的索引号


Public Sub COMM_PacketData(cmd As Byte, ADDR As Byte, ADDR2 As Byte, Data() As Byte, senddata() As Byte)

 'cmd  为要连接的被测设备

 'addr 为下传的地址
 
 'addr2 测量仪器

 'data 为需下传的原始数据

 'senddata 为打包好的数据

 


Dim start As String

Dim ub, lb, num As Integer

ReDim senddata(5) As Byte

      senddata(0) = PKStart '包头

      senddata(1) = DLZ_ADDR '目标地址

      senddata(2) = PC_ADDR0 '源地址

      senddata(3) = 0 '标志位

      senddata(4) = COMM_SurveyADDR '测量设备地址
      
      senddata(5) = cmd '连接端口地址
      

      COMM_CurCmd = cmd '当前包类型

      ReDim Preserve senddata(0 To 7) As Byte

      COMM_Add7DFlag senddata, 1, 7 ' 1-7之间数据寻找7D7EFF做转换（除去包头）

      

      ub = UBound(senddata)

      senddata(ub - 1) = COMM_GenerateCRC(senddata, 1, ub - 2) '生成校验码

      senddata(ub) = PKEND '添加包尾

      COMM_Add7DFlag senddata, ub - 1, ub - 1 '对校验码进行寻找7D7EFF做转换

   End Sub
Public Sub COMM_Init(ovtime As Timer, rcvComm As MSComm, sendComm As MSComm)


'包头包尾标志，接收包时对完整包进行判别
COMM_PKStartFlag = False
COMM_PKEndFlag = False
'接收属于包内数据的个数，即RCVDATA的个数
COMM_RcvDataNum = 0
COMM_ReSendTimes = 0 '重传次数为0
COMM_isACKFlag = False '下位机是否应答标志
'超时时钟间隔
Set overtime_timer = ovtime
overtime_timer.Interval = ACK_OVERTIME
overtime_timer.Enabled = False
RcvDataByteIndex = 0 '接收字节索引号
'发送及接收通信串口
Set COMM_RcVMSCOMM = rcvComm
Set COMM_SendMSCOMM = sendComm
COMM_isSendOverFlag = True

COMM_CurHisPackIndex = 0 '上传历史包号
BITRATE = Array(0, 1, 2, 3, 4, 5, 6, 7)

End Sub
Private Function COMM_GenerateCRC(Data() As Byte, indexS As Integer, indexE As Integer) As Byte '添加校验码的函数,防止数据在传输途中丢失
Dim tmp As Integer, I As Integer, length As Integer, zerobyte As Byte
   Dim i1 As Integer, i2 As Integer, i3 As Integer
   
   zerobyte = 0
   tmp = 0
   For I = indexS To indexE Step 1
   tmp = (tmp + Data(I)) And 255
   Next I
   i1 = zerobyte
   i2 = tmp
   COMM_GenerateCRC = (0 - i2) And 255

    
End Function


Private Function COMM_CheckCRC(Data() As Byte) As Byte '检验所收数据的校验码,判断数据是否完整
 Dim tmp As Integer, I As Integer
 tmp = 0
 For I = 0 To UBound(Data) Step 1
  tmp = (tmp + Data(I)) And 255
 Next I
 COMM_CheckCRC = tmp
 'Put #1, , "FUN_comm_checkcrc: " & (COMM_CheckCRC) & Chr(13)
End Function
Private Sub COMM_Add7DFlag(dataArray() As Byte, indexS As Integer, indexE As Integer) '进行7D7EFF转换的函数防止数据失真

'index表明从dataarray数组的第及位开始查找

Dim istart, iend As Integer, I, K As Integer

istart = LBound(dataArray)

iend = UBound(dataArray)






For K = indexS To indexE Step 1  '排除包头和包尾

 If dataArray(indexS) = &H7E& Then

   iend = iend + 1

   ReDim Preserve dataArray(istart To iend) As Byte

   For I = iend To indexS + 2 Step -1

     dataArray(I) = dataArray(I - 1)

   Next I

     dataArray(indexS) = &H7D&

     dataArray(indexS + 1) = &H5E&

     indexS = indexS + 2

     

 ElseIf dataArray(indexS) = &H7D& Then

   iend = iend + 1

   ReDim Preserve dataArray(istart To iend) As Byte

   For I = iend To indexS + 2 Step -1

     dataArray(I) = dataArray(I - 1)

   Next I

     dataArray(indexS) = &H7D&

     dataArray(indexS + 1) = &H5D&

     indexS = indexS + 2


 ElseIf dataArray(indexS) = &H7F& Then

   iend = iend + 1

   ReDim Preserve dataArray(istart To iend) As Byte

   For I = iend To indexS + 2 Step -1

     dataArray(I) = dataArray(I - 1)

   Next I

     dataArray(indexS) = &H7D&

     dataArray(indexS + 1) = &H5F&

     indexS = indexS + 2
     

 Else

     indexS = indexS + 1

 End If

 

 Next K

End Sub

Private Sub COMM_Del7DFlag(dataArray() As Byte, indexS As Integer, indexE As Integer) '祛除7D5D7D5E7D5F数据,还原初始命令数据

'index表明从dataarray数组的第及位开始查找

Dim istart, iend As Integer, I, K, num As Integer

istart = LBound(dataArray)

iend = UBound(dataArray)



'Put #1, , "start_FUN_comm_del7dflag" & Chr(13)

'For K = indexS To indexE Step 1

If indexE = iend Then indexE = indexE - 1

If indexS = iend Then indexS = indexS - 1



num = indexE - indexS

K = istart

Do Until num < 0

 If dataArray(indexS) = &H7D& And dataArray(indexS + 1) = &H5F& Then

   dataArray(indexS) = &H7F&

   For I = indexS + 1 To iend - 1 Step 1

     dataArray(I) = dataArray(I + 1)

   Next I

   iend = iend - 1

   ReDim Preserve dataArray(istart To iend) As Byte

   indexS = indexS + 1

    num = num - 2

 ElseIf dataArray(indexS) = &H7D& And dataArray(indexS + 1) = &H5E& Then

   dataArray(indexS) = &H7E&

   For I = indexS + 1 To iend - 1 Step 1

     dataArray(I) = dataArray(I + 1)

   Next I

   iend = iend - 1

   ReDim Preserve dataArray(istart To iend) As Byte
  indexS = indexS + 1
     num = num - 2
ElseIf dataArray(indexS) = &H7D& And dataArray(indexS + 1) = &H5D& Then
   dataArray(indexS) = &H7D&
   For I = indexS + 1 To iend - 1 Step 1
     dataArray(I) = dataArray(I + 1)
   Next I
   iend = iend - 1
   ReDim Preserve dataArray(istart To iend) As Byte
     indexS = indexS + 1

     num = num - 2

 Else

     indexS = indexS + 1

     num = num - 1

 End If

 Loop

 

End Sub

Public Sub COMM_StartSendData() '传送数据模块

Dim num, I, K As Integer

 num = UBound(COMM_SendPacket)


 COMM_isSendOverFlag = False

 COMM_isACKFlag = False '下位机应答初始化为无

 overtime_timer.Interval = ACK_OVERTIME '超时判断

 overtime_timer.Enabled = True

 COMM_SendMSCOMM.Output = COMM_SendPacket '发送数据

 Form1.Text1.Text = ConvertChar(COMM_SendPacket)

 Do

    K = DoEvents()

 Loop Until COMM_SendMSCOMM.OutBufferCount = 0

 'Put #1, , COMM_SendPacket



End Sub

Public Sub overtime_timer_timer() '超时处理模块

'Put #1, , "start_fun_overtime_timer_timer" & Chr(13)

'Put #1, , "start_fun_overtime_timer_timer-comm_isackflag:--" & COMM_isACKFlag & Chr(13)

  If COMM_isACKFlag = False Then

    Dim tmp As Variant

    ReDim RcvData(0) '清空接收缓冲区

    tmp = COMM_RcVMSCOMM.InputLen

    RcvDataByteIndex = 0 '接收的字节数复位

    If COMM_ReSendTimes < 2 Then

    COMM_ReSendTimes = COMM_ReSendTimes + 1

    COMM_StartSendData

    'Put #1, , "start_fun_overtime_timer_timer-resend:--" & COMM_ReSendTimes & Chr(13)

    Else

    'Put #1, , "start_fun_overtime_timer_timer-over" & Chr(13)

    COMM_isSendOverFlag = True '复位发送完标志

    COMM_ReSendTimes = 0

    overtime_timer.Enabled = False

    End If

  Else

    

  End If

End Sub
Public Sub COMM_End() '程序结束模块

'Put #1, , "start_fun_comm_end" & Chr(13)

If COMM_RcVMSCOMM.PortOpen = True Then COMM_RcVMSCOMM.PortOpen = False

If COMM_SendMSCOMM.PortOpen = True Then COMM_SendMSCOMM.PortOpen = False

End Sub
Private Function ConvertChar(dat() As Byte) As String '提取数据模块

Dim I As Integer, str As String

str = ""

For I = 0 To UBound(dat)

  str = str & Format(Hex(dat(I)), "0#")

 Next I

 ConvertChar = str

End Function

Private Sub COMM_ReceiveData() '接收模块

On Error Resume Next

Dim di As Variant

Dim cLen, I, num As Integer

Put #1, , "start_FUN_comm_receivedata" & Chr(13)

cLen = COMM_RcVMSCOMM.InBufferCount

 Put #1, , "in_FUN_comm_receivedata_orgdata number:" & cLen & Chr(13)

di = COMM_RcVMSCOMM.Input



Dim tmp() As Byte

ReDim tmp(0 To cLen - 1)

For I = 0 To cLen - 1

tmp(I) = di(I)

Next I



  Put #1, , "in_FUN_comm_receivedata_orgdata:" & ConvertChar(tmp) & Chr(13)

  Erase tmp

 If COMM_PKStartFlag = False And COMM_PKEndFlag = False Then

     RcvDataByteIndex = 0 '接收字节索引号

  End If

 I = 0

 Do Until COMM_PKEndFlag = True Or I > cLen - 1

    

  If di(I) = PKStart And RcvDataByteIndex = 0 Then

        ReDim RcvData(0)

        RcvData(0) = PKStart

  ElseIf di(I) <> PKStart And RcvData(0) = PKStart Then

       ReDim RcvData(0)

       RcvDataByteIndex = 0

       COMM_PKStartFlag = True

       RcvData(RcvDataByteIndex) = di(I)

  ElseIf di(I) = PKEND And RcvData(RcvDataByteIndex) <> PKEND Then

       COMM_PKEndFlag = True

       RcvDataByteIndex = 0

            

  ElseIf COMM_PKStartFlag = True And COMM_PKEndFlag = False Then

       

       RcvDataByteIndex = RcvDataByteIndex + 1

       ReDim Preserve RcvData(RcvDataByteIndex)

       RcvData(RcvDataByteIndex) = di(I)

  End If

  I = I + 1

Loop

If COMM_PKEndFlag = True Then

   COMM_isACKFlag = True

   overtime_timer.Enabled = False '超时无效

   COMM_PKStartFlag = False

   COMM_PKEndFlag = False

 Put #1, , "in_FUN_comm_receivedata_comm_realdata:" & ConvertChar(RcvData) & Chr(13)
   
   Form1.Text2.Text = ConvertChar(RcvData) '显示接受正确的数据
   
   ProcessRcvData
   

End If


End Sub


Public Sub ProcessRcvData() '接受数据错误的处理

Dim CRC As Byte, num, I As Integer

'Put #1, , "start_FUN_comm_processrcvdata" & Chr(13)

COMM_Del7DFlag RcvData, UBound(RcvData), UBound(RcvData) '过滤校验位的特殊字符



CRC = COMM_CheckCRC(RcvData)



If CRC = 0 Then '校验正确

  

 'Put #1, , "start_FUN_comm_processrcvdata" & "crc_ok" & Chr(13)

  COMM_Del7DFlag RcvData, 0, UBound(RcvData) '过滤数据中的特殊字符

  Dim sourceADDR As Byte, CorrectFlag As Byte

  sourceADDR = RcvData(1) '下位机地址

  CorrectFlag = RcvData(2) '标志位，01正确，02错误

  

  If CorrectFlag = ACK_OK Then '下位机正确接收

          'Put #1, , "FUN_comm_processrcvdata" & "ack_ok_UP_no _data" & Chr(13)

      

       COMM_ReSendTimes = 0 '重传次数复位

       COMM_isSendOverFlag = True

       COMM_CurCmd = NO_CMD

       'Put #1, , "FUN_comm_processrcvdata" & "ack_ok_up_nodata_reset" & Chr(13)

       Form1.Picture1.BackColor = &HFF00&
       Form1.Label3.Caption = "一切正常"
       COMM_CurHisPackIndex = COMM_CurHisPackIndex + 1
       
       
   Else
  '重发，3次

   Form1.Picture1.BackColor = &HFF&
   Form1.Label3.Caption = "发送错误数据"
    If COMM_ReSendTimes < 2 Then

      'Put #1, , "FUN_comm_processrcvdata" & "ack_fail_resend_times-" & COMM_ReSendTimes & Chr(13)

       COMM_ReSendTimes = COMM_ReSendTimes + 1 '起始值为0

       COMM_StartSendData '继续该命令的传送

 Else

      'Put #1, , "FUN_comm_processrcvdata" & "ack_fail_resend_times >2 and_reset" & Chr(13)

      COMM_isSendOverFlag = True

      COMM_ReSendTimes = 0 '重传 次数复位

      COMM_CurCmd = NO_CMD '重传，及命令复位

    End If

    

    

          

  End If ' end of ack-ok
 Else '校验错误

'Put #1, , "_FUN_comm_processrcvdata" & "crc_fail" & Chr(13)

 '重发包，3次
 Form1.Picture1.BackColor = &HFF&
 Form1.Label3.Caption = "校验错误"
 

   If COMM_ReSendTimes < 2 Then

       COMM_StartSendData '继续该命令的传送

       Put #1, , "FUN_comm_processrcvdata" & "crc_fail_resend_times-" & COMM_ReSendTimes & Chr(13)

    Else

       COMM_isSendOverFlag = True

       COMM_ReSendTimes = 0

       COMM_CurCmd = NO_CMD ' 命令，及重发 复位

       'Put #1, , "FUN_comm_processrcvdata" & "crc_fail_resend_times >2,and reset" & Chr(13)

   End If

   COMM_ReSendTimes = COMM_ReSendTimes + 1 '起始值为0

 

End If





End Sub
Public Sub MSCommCtl_OnComm() '对于触发事件处理模块

'Put #1, , "FUN_mscommctl_oncomm" & Chr(13)
Select Case COMM_RcVMSCOMM.CommEvent
  
  Case comEvReceive
       Call COMM_ReceiveData
  Case comEvEOF
End Select
End Sub