communication.bas

基于RS－232的

Attribute VB_Name = "communication"
Option Explicit
'命令种类
Public Const NO_CMD As Byte = 0
Public Const UP_UI As Byte = &H11&
Public Const DOWN_IO As Byte = &H12&
Public Const DOWN_OCTIME As Byte = &H13&
Public Const DOWN_STDTIME As Byte = &H14&
Public Const UP_HISRECORD As Byte = &H15&
Public Const UP_TIME As Byte = &H16&
Public Const DOWN_CANBITRATE As Byte = &H17& '下传CAN总线波特率
'目标地址
Private Const T_ADDR1 As Byte = &H1&  '1号站点
Private Const T_ADDR2 As Byte = &H2&
Private Const T_ADDR3 As Byte = &H3&
Private Const T_ADDR4 As Byte = &H4&
Private Const T_ADDR5 As Byte = &H5&
Private Const T_ADDR6 As Byte = &H6&
Private Const T_ADDR7 As Byte = &H7&

Private Const PC_ADDR1 As Byte = &H8& 'PC机A
Private Const PC_ADDR2 As Byte = &H9& 'PC机B
Private Const CAN_ADDR As Byte = &HFE&  'can总线网络地址
'目标地址数组
Public COMM_MachineADDR(50) As Byte
'设置CAN总线的波特率
'10K,20K,40K,50K,80K,100K,125K,200k 对应0－7
'Public COMM_BITRATE As Variant
Public COMM_TerminateSendByForce As Boolean '强行中断传输标志，用于传送历史数据时
'包头
Private Const PKStart As Byte = &H7E&
Private Const PKEND As Byte = &H7E&
'下位机应答量
Private Const ACK_OK As Byte = &H1&
Private Const ACK_FAIL As Byte = &H2&
Private Const ACK_OVERTIME As Integer = 500 '超时时间1秒
'当前发送的命令
Private COMM_CurCmd As Byte
'当前发送包的索引号
'Public COMM_CurPacketIndex As Integer
'打包要传送的数据
'包头包尾判别标志
Private COMM_PKStartFlag As Boolean, COMM_PKEndFlag As Boolean
'收到包的个数
Private COMM_RcvDataNum As Integer, COMM_RcvData() As Byte, tmp_Rcvdata() As Byte
'Public Type SENDPACKETTYPE '发送数据时可连续打几个包
'  Dim data() As Byte
'  Dim isSendOverFlag As Boolean
'End Type
Private COMM_SendPacket() As Byte '当前发送的包
Private COMM_ReSendTimes As Integer '记录重传次数
Public COMM_isSendOverFlag As Boolean   '发送是否结束
Private COMM_isACKFlag As Boolean '检测是否有应答
Private overtime_timer As Timer '超时时钟
Private COMM_RcVMSCOMM As MSComm, COMM_SendMSCOMM As MSComm
Private Const HISPACKETNUM As Integer = 100 '历史包的总包数(待定)
Private COMM_CurHisPackIndex As Integer   '当前发送的历史包序列号
Private COMM_CurDestADDR As Byte  '当前访问下位机的地址
Private Const logfileName = "d:\testcom.log" '日志文件
'Private DataBaseObj As Database '用于访问数据及设置参数的数据库对象
'Private tmpdata() As Byte
Private RcvDataByteIndex As Integer '接收字节的索引号
Private WaitSendFlagNum As Double '等待发送标志计数
Private MyMachineAdd As Byte
'Private waitSendFlagTimer As Timer
Type COMM_CmdMessageType
 cmd As Byte
 station As Integer
 BeenUsedFlag As Boolean
End Type

Private COMM_CMDGroup() As COMM_CmdMessageType  '消息队列

Public Sub COMM_Init(ovtime As Timer, rcvComm As MSComm, sendComm As MSComm, MyAdd As Byte)  ', dbobj As Database)

If MyAdd = 1 Then
  MyMachineAdd = PC_ADDR1 'A本机地址
ElseIf MyAdd = 2 Then
  MyMachineAdd = PC_ADDR2 'B本机地址
End If

'包头包尾标志，接收包时对完整包进行判别
COMM_PKStartFlag = False
COMM_PKEndFlag = False
'接收属于包内数据的个数，即COMM_RCVDATA的个数
COMM_RcvDataNum = 0
COMM_ReSendTimes = 0 '重传次数尾0
COMM_isACKFlag = False '下位机是否应答标志
'超时时钟间隔
COMM_TerminateSendByForce = False '强行中断发送命令
Set overtime_timer = ovtime
overtime_timer.interval = ACK_OVERTIME
overtime_timer.Enabled = False
RcvDataByteIndex = 0 '接收字节索引号
'发送及接收通信串口
ReDim COMM_RcvData(400): ReDim tmp_Rcvdata(400)
Set COMM_RcVMSCOMM = rcvComm
Set COMM_SendMSCOMM = sendComm

'Set waitSendFlagTimer = checkSendflagtime
'Set DataBaseObj = dbobj
'初始化发送和接收串口设置
 Dim recordDb As Recordset
 On Error Resume Next
 Set recordDb = db.OpenRecordset("文件路径")
COMM_RcVMSCOMM.Settings = "19200,n,8,1"
 'COMM_RcVMSCOMM.Settings = "9600,n,8,1"
 COMM_RcVMSCOMM.commport = recordDb.Fields("通信端口").Value
 COMM_RcVMSCOMM.InBufferCount = 0                         ' 清接收缓冲区
 COMM_RcVMSCOMM.RThreshold = 1                            ' 接收数据长度
 COMM_RcVMSCOMM.OutBufferCount = 0
 COMM_RcVMSCOMM.InputMode = comInputModeBinary
 If COMM_RcVMSCOMM.PortOpen = False Then
 COMM_RcVMSCOMM.PortOpen = True
 End If
 Set COMM_SendMSCOMM = COMM_RcVMSCOMM
 'COMM_SendMSCOMM.Settings = "9600,n,8,1"
 'COMM_SendMSCOMM.commport = recordDB.Fields("通信端口").Value
 'COMM_SendMSCOMM.InBufferCount = 0                         ' 清接收缓冲区
 'COMM_SendMSCOMM.RThreshold = 1                            ' 接收数据长度
 'COMM_SendMSCOMM.OutBufferCount = 0
 'COMM_SendMSCOMM.InputMode = comInputModeBinary
 'If COMM_SendMSCOMM.PortOpen = False Then
 'COMM_SendMSCOMM.PortOpen = True
 'End If
 recordDb.Close
 Set recordDb = Nothing
COMM_isSendOverFlag = True

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

'可访问各机地址
COMM_MachineADDR(0) = T_ADDR1
COMM_MachineADDR(1) = T_ADDR2
COMM_MachineADDR(2) = T_ADDR3
COMM_MachineADDR(3) = T_ADDR4
COMM_MachineADDR(4) = T_ADDR5
COMM_MachineADDR(5) = T_ADDR6
COMM_MachineADDR(6) = T_ADDR7
For I = 7 To StioNum
COMM_MachineADDR(I) = &H20& + I - 7 '多余站点地址从20开始
Next I
COMM_MachineADDR(48) = PC_ADDR1
COMM_MachineADDR(49) = PC_ADDR2
COMM_MachineADDR(50) = CAN_ADDR
'COMM_MachineADDR = Array(T_ADDR1, T_ADDR2, T_ADDR3, T_ADDR4, T_ADDR5, T_ADDR6, T_ADDR7, PC_ADDR1, PC_ADDR2, CAN_ADDR)
'If StioNum > 6 Then '增加下位机地址
'   Dim num As Integer
'   num = UBound(COMM_MachineADDR)
'   ReDim Preserve COMM_MachineADDR(num + StioNum - 6)
'   Dim I As Integer
'   For I = 1 To StioNum - 6
'     COMM_MachineADDR(num + I) = &H15& + I
'   Next I
'End If
Open logfileName For Binary As #1
'存储和提取数据模块的初始化
SED_Init 'DataBaseObj
'WaitSendFlagNum = 0 '等待发送标志计数值
ReDim COMM_CMDGroup(0) '0号单元不用

End Sub

Private Sub COMM_PacketData(cmd As Byte, ADDR As Byte, data() As Byte, senddata() As Byte)
 'cmd  为下传命令
 'addr 为下传的地址
 'data 为需下传的原始数据
 'senddata 为打包好的数据
 'Put #1, , "start_FUN_comm_packetdata: cmd: " & Hex(cmd) & vbCr & vbLf
Dim start As String, I, K As Integer
Dim ub, lb, num As Integer, t As Byte
Dim LenIn As Integer, LenOut As Integer, RealLen As Integer
ReDim senddata(100) As Byte

      senddata(0) = PKStart
      senddata(1) = ADDR
      
      senddata(2) = MyMachineAdd 'PC_ADDR1 '本机地址
      senddata(3) = 0
      senddata(4) = cmd
      COMM_CurCmd = cmd '当前包类型
    If (cmd = UP_UI Or cmd = UP_TIME) Then
      '上传
   
      LenIn = 5
       
    ElseIf cmd = UP_HISRECORD Then
      '上传历史数据＋包号，共280记录
    
      
      t = (COMM_CurHisPackIndex And &HFF00&) / 256
      senddata(5) = t ' 取高位???
      t = (COMM_CurHisPackIndex And &HFF&)
      senddata(6) = t '取地位?????????
      LenIn = 7
     
     
    
    ElseIf (cmd = DOWN_IO Or cmd = DOWN_OCTIME Or cmd = DOWN_STDTIME Or cmd = DOWN_CANBITRATE) Then
      '下传
      
      ub = UBound(data)
      lb = LBound(data)
      num = ub - lb + 1
      
      K = 0
      For I = 5 To 4 + num Step 1
      senddata(I) = data(lb + K)
      K = K + 1
      Next
      LenIn = 5 + num
        
    End If
    
     COMM_Add7DFlag senddata, 1, LenIn, LenOut ' 1-4之间数据寻找7D7E做转换（除去包头）
      
     senddata(LenOut) = COMM_GenerateCRC(senddata, 1, LenOut - 1)
     COMM_Add7DFlag senddata, LenOut, LenOut + 1, RealLen
     senddata(RealLen) = PKEND
      
     
     ReDim Preserve senddata(RealLen)
     Put #1, , "FUN_comm_packetdata_down" & ConvertChar(senddata) & vbCr & vbLf


End Sub


Private Sub COMM_Add7DFlag(dataArray() As Byte, indexS As Integer, LenIn As Integer, LenOut As Integer)
'index表明从dataarray数组的第及位开始查找
Dim istart, iend As Integer, I, K As Integer
'istart = LBound(dataArray)
'iend = UBound(dataArray)
Dim dat() As Byte
ReDim dat(200) As Byte
'Put #1, , "start_FUN_comm_add7dflag" & vbCr & vbLf

For K = 0 To indexS - 1
dat(K) = dataArray(K)
Next K
Dim Pos As Integer
Pos = indexS
'If Pos < 0 Then Pos = 0

For K = indexS To LenIn - 1 Step 1 '排除包头和包尾
   
 If dataArray(K) = &H7E& Then
   dat(Pos) = &H7D&: dat(Pos + 1) = &H5E&
   Pos = Pos + 2
 ElseIf dataArray(K) = &H7D& Then
   dat(Pos) = &H7D&: dat(Pos + 1) = &H5D&
   Pos = Pos + 2
 ElseIf dataArray(K) = &HFF& Then
   dat(Pos) = &H7D&: dat(Pos + 1) = &H5F&
   Pos = Pos + 2
 Else
   dat(Pos) = dataArray(K)
   Pos = Pos + 1
 End If
Next K


For K = 0 To Pos - 1
dataArray(K) = dat(K)
Next K
LenOut = Pos
Erase dat
End Sub



Private Sub COMM_Add7DFlag_old(dataArray() As Byte, indexS As Integer, indexE As Integer)
'index表明从dataarray数组的第及位开始查找
Dim istart, iend As Integer, I, K As Integer
istart = LBound(dataArray)
iend = UBound(dataArray)

'Put #1, , "start_FUN_comm_add7dflag" & vbCr & vbLf

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
 'OXFF---7d5F
 ElseIf dataArray(indexS) = &HFF& 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)
'index表明从dataarray数组的第及位开始查找
Dim istart, iend As Integer, I, K, num As Integer
istart = LBound(dataArray)
iend = RcvDataByteIndex  'UBound(dataArray)