module1.bas

频率自动测量系统是一个用于测量电子元件的软硬件综合系统。本系统由几个部分组成

 '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 Function ConvertChar1(dat() As Byte) As String

Dim I As Integer, str As String

str = ""

For I = 4 To UBound(dat) - 1

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

 Next I

 ConvertChar1 = 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)

'Put #1, , "in_FUN_comm_receivedata_ overtime-timer is unenable:" & 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
  
 'For I = 0 To cLen + num - 2
 'index = 0
 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

Private Sub COMM_ReceiveDataold()
On Error Resume Next
Dim di As Variant
Dim cLen, I, num As Integer
Put #1, , "start_FUN_comm_receivedata" & Chr(13)

'Put #1, , "in_FUN_comm_receivedata_ overtime-timer is unenable:" & 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
  
 'For I = 0 To cLen + num - 2
 'index = 0
 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)

       COMM_ExtractRealData

       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 '校验错误
    Form1.Picture1.BackColor = &HFF&
    Form1.Label3.Caption = "校验错误"

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

 '重发包，3次

   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 COMM_ExtractRealData()
'直接对接收rdcdata进行处理（包括目标地址，标志位等信息）
'Put #1, , "FUN_comm_extractrealdata-" & Chr(13)
Dim cmd As Byte, ADDR As Byte, I As Integer, m As Integer

Form1.Picture1.BackColor = &HFF00&

ADDR = RcvData(2)
cmd = RcvData(3)
Dim a(3) As String

If cmd = rvCmd_False Then
   Form1.Picture1.BackColor = &HFF&
    Form1.Label3.Caption = "有端口出错了"
       
Dim status(20) As Integer
k = 1
For I = 0 To 7
r = k * (2 ^ I)
   status(19 - I) = (RcvData(6) And (r)) / (r)
Next

For I = 8 To 15
r = k * (2 ^ (I - 8))
   status(19 - I) = (RcvData(5) And (r)) / (r)
Next

For I = 16 To 19
r = k * (2 ^ (I - 16))
   status(19 - I) = (RcvData(4) And (r)) / (r)
Next
For I = 0 To 19
If status(I) = 0 Then Form1.Text3.Text = Form1.Text3.Text & (I + 1)
Next
Else
Form1.Picture1.BackColor = &HFF00&
 
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

Public Function H_To_B(ByVal Hex As String) As String
    Dim I As Long
    Dim b As String
    
    Hex = UCase(Hex)
    For I = 1 To Len(Hex)
        Select Case Mid(Hex, I, 1)
            Case "0": b = b & "0000"
            Case "1": b = b & "0001"
            Case "2": b = b & "0010"
            Case "3": b = b & "0011"
            Case "4": b = b & "0100"
            Case "5": b = b & "0101"
            Case "6": b = b & "0110"
            Case "7": b = b & "0111"
            Case "8": b = b & "1000"
            Case "9": b = b & "1001"
            Case "A": b = b & "1010"
            Case "B": b = b & "1011"
            Case "C": b = b & "1100"
            Case "D": b = b & "1101"
            Case "E": b = b & "1110"
            Case "F": b = b & "1111"
        End Select
    Next I
    H_To_B = b
End Function