mainbas.bas

来自「电梯检测系统是对电梯性能进行检测的系统。是一个用来学习的程序。」· BAS 代码 · 共 1,098 行 · 第 1/3 页

'     iLenB:欲写入寄存器的数目
'     vDataAryB:欲写入之数据
'传回:
'     True:成功
'     False:失败
'   有应答正确性检核
 
 
        Dim sTime, cTime As Single
        Dim Dummy As Integer
        Dim bHeadAry(6) As Byte
        Dim vSndAry As Variant
        Dim iSndLen As Integer
        Dim vRetAry As Variant
        Dim vCrcAry As Variant
        Dim iByteNum As Integer
        Dim i As Integer
        
        On Error GoTo WritePlcErr
        
        iByteNum = iLenB * 2
        
        bHeadAry(0) = iDeviceID
        bHeadAry(1) = &H10
        bHeadAry(2) = iAddr \ 256
        bHeadAry(3) = iAddr Mod 256
        bHeadAry(4) = iLenB \ 256
        bHeadAry(5) = iLenB Mod 256
        bHeadAry(6) = iByteNum
        iSndLen = 9 + iByteNum - 1
        ReDim vSndAry(0 To iSndLen)
        
        vSndAry = CmbAryB(bHeadAry, vDataAryB)
        vSndAry = CmbAryB(vSndAry, CrcB(vSndAry, iLenB + 7))
        
 
        'clear input/output buffer
        FrmFuncTest.ReadCom.InBufferCount = 0
        FrmFuncTest.ReadCom.OutBufferCount = 0
 
        'write to output buffer
        FrmFuncTest.ReadCom.Output = vSndAry
 
        'read from input buffer
        sTime = Timer
        bolWritePlcB_10 = True
        Do While bolWritePlcB_10
           If FrmFuncTest.ReadCom.InBufferCount >= 8 Then
              bolWritePlcB_10 = True
              Exit Do
           End If
           cTime = Timer
           If (cTime - sTime) > cTimeOut Then
              bolWritePlcB_10 = False
           Else
              If (Timer - sTime) < 0 Then sTime = Timer
           End If
           Dummy = DoEvents()
        Loop
        
        If bolWritePlcB_10 Then
           vRetAry = FrmFuncTest.ReadCom.Input
           vCrcAry = CrcB(vRetAry, 6)
           If vCrcAry(0) <> vRetAry(6) Or vCrcAry(1) <> vRetAry(7) _
              Or vSndAry(0) <> vRetAry(0) Or vSndAry(1) <> vRetAry(1) Then
              bolWritePlcB_10 = False
              Exit Function
           End If
        End If
        Exit Function
WritePlcErr:
        bolWritePlcB_10 = False
End Function
 
Public Function bolWritePlcB_0F(ByVal iDeviceID As Integer, ByVal iAddr As Integer, ByVal iLenB As Integer, vDataAryB As Variant) As Boolean
'作者:Henry
'目的:
'     写入传入字符串至Plc，可选定地址
'传入:
'     Comm:对应Plc之通迅对象
'     iPlc:欲写入之Plc Id
'     iAddr:欲写入数据的起始地址
'     iLenB:欲强制的线圈的数目
'     vDataAryB:欲写入之数据二进制数串
'传回:
'     True:成功
'     False:失败
'   有应答正确性检核
 
 
        Dim sTime, cTime As Single
        Dim Dummy As Integer
        Dim bHeadAry(6) As Byte
        Dim vSndAry As Variant
        Dim iSndLen As Integer
        Dim vRetAry As Variant
        Dim vCrcAry As Variant
        Dim iByteNum As Integer
        Dim i As Integer
        
        On Error GoTo WritePlcErr
        
        iByteNum = iLenB \ 8 + 1
        
        bHeadAry(0) = iDeviceID
        bHeadAry(1) = &HF
        bHeadAry(2) = iAddr \ 256
        bHeadAry(3) = iAddr Mod 256
        bHeadAry(4) = iLenB \ 256
        bHeadAry(5) = iLenB Mod 256
        bHeadAry(6) = iByteNum
        iSndLen = 9 + iByteNum - 1
        ReDim vSndAry(0 To iSndLen)
        
        vSndAry = CmbAryB(bHeadAry, vDataAryB)
        vSndAry = CmbAryB(vSndAry, CrcB(vSndAry, iLenB + 7))
        
 
        'clear input/output buffer
        FrmFuncTest.ReadCom.InBufferCount = 0
        FrmFuncTest.ReadCom.OutBufferCount = 0
 
        'write to output buffer
        FrmFuncTest.ReadCom.Output = vSndAry
 
        'read from input buffer
        sTime = Timer
        bolWritePlcB_0F = True
        Do While bolWritePlcB_0F
           If FrmFuncTest.ReadCom.InBufferCount >= 8 Then
              bolWritePlcB_0F = True
              Exit Do
           End If
           cTime = Timer
           If (cTime - sTime) > cTimeOut Then
              bolWritePlcB_0F = False
           Else
              If (Timer - sTime) < 0 Then sTime = Timer
           End If
           Dummy = DoEvents()
        Loop
        
        If bolWritePlcB_0F Then
           vRetAry = FrmFuncTest.ReadCom.Input
           vCrcAry = CrcB(vRetAry, 6)
           If vCrcAry(0) <> vRetAry(6) Or vCrcAry(1) <> vRetAry(7) _
              Or vSndAry(0) <> vRetAry(0) Or vSndAry(1) <> vRetAry(1) Then
              bolWritePlcB_0F = False
              Exit Function
           End If
        End If
        Exit Function
WritePlcErr:
        bolWritePlcB_0F = False
End Function
 

Public Function bolWritePlcB(ByVal iCommIndex As Integer, ByVal iDeviceID As Integer, ByVal iAddr As Integer, ByVal iLenB As Integer, vDataAryB As Variant) As Boolean
'作者:Henry
'目的:
'     写入传入字符串至Plc，可选定地址
'传入:
'     Comm:对应Plc之通迅对象
'     iPlc:欲写入之Plc Id
'     iAddr:欲写入数据的起始地址
'     iLenB:欲写入之数据长度(以Byte为单位)
'     vDataAryB:欲写入之数据字符串
'传回:
'     True:成功
'     False:失败
'   有应答正确性检核
 
 
        Dim sTime, cTime As Single
        Dim Dummy As Integer
        Dim bHeadAry(6) As Byte
        Dim vSndAry As Variant
        Dim iSndLen As Integer
        Dim vRetAry As Variant
        Dim vCrcAry As Variant
        Dim i As Integer
        
        On Error GoTo WritePlcErr
        
        'WritePlcB = True
        
        bHeadAry(0) = iDeviceID
        bHeadAry(1) = 16
        bHeadAry(2) = iAddr \ 256
        bHeadAry(3) = iAddr Mod 256
        bHeadAry(4) = 0
        bHeadAry(5) = iLenB / 2
        bHeadAry(6) = iLenB
                        
        iSndLen = 9 + iLenB - 1
        ReDim vSndAry(0 To iSndLen)
        
        vSndAry = CmbAryB(bHeadAry, vDataAryB)
        vSndAry = CmbAryB(vSndAry, CrcB(vSndAry, iLenB + 7))
        
 
        'clear input/output buffer
        FrmFuncTest.ReadCom.InBufferCount = 0
        FrmFuncTest.ReadCom.OutBufferCount = 0
 
        'write to output buffer
        FrmFuncTest.ReadCom.Output = vSndAry
 
        'read from input buffer
        sTime = Timer
        bolWritePlcB = True
        Do While bolWritePlcB
           If FrmFuncTest.ReadCom.InBufferCount >= 8 Then
              bolWritePlcB = True
              Exit Do
           End If
           cTime = Timer
           If (cTime - sTime) > cTimeOut Then
              bolWritePlcB = False
           Else
              If (Timer - sTime) < 0 Then sTime = Timer
           End If
           Dummy = DoEvents()
        Loop
        
        If bolWritePlcB Then
           vRetAry = FrmFuncTest.ReadCom.Input
           vCrcAry = CrcB(vRetAry, 6)
           If vCrcAry(0) <> vRetAry(6) Or vCrcAry(1) <> vRetAry(7) _
              Or vSndAry(0) <> vRetAry(0) Or vSndAry(1) <> vRetAry(1) Then
              bolWritePlcB = False
              Exit Function
           End If
        End If
        
        Exit Function
WritePlcErr:
        bolWritePlcB = False
End Function
 

Public Function bolWritePlcB_06(ByVal iDeviceID As Integer, ByVal iAddr As Integer, ByVal iSetValue As Integer) As Boolean
'作者:Henry
'目的:
'     写入传入字符串至Plc，可选定地址
'传入:
'     iFuncIndex:功能号
'     iAddr:欲写入数据的起始地址
'     iSetValue:欲写入的数据
'传回:
'     True:成功
'     False:失败
'   有应答正确性检核
 
 
        Dim sTime, cTime As Single
        Dim Dummy As Integer
        Dim vSndAry As Variant
        Dim iSndLen As Integer
        Dim vRetAry As Variant
        Dim vCrcAry As Variant
        Dim bHeadAry(5) As Byte
        Dim i As Integer
        Dim k As Long, m As Long
        On Error GoTo WritePlcErr
        
        bHeadAry(0) = iDeviceID
        bHeadAry(1) = 6
        bHeadAry(2) = iAddr \ 256
        bHeadAry(3) = iAddr Mod 256
        bHeadAry(4) = iSetValue \ 256
        bHeadAry(5) = iAddr Mod 256
                        
        iSndLen = 8 '9 + iLenB - 1
        ReDim vSndAry(0 To iSndLen - 1)
        
        vSndAry = CmbAryB(bHeadAry, CrcB(bHeadAry, 6))
        If FrmFuncTest.ReadCom.PortOpen = False Then
            FrmFuncTest.ReadCom.PortOpen = True
        End If

        'clear input/output buffer
        FrmFuncTest.ReadCom.InBufferCount = 0
        FrmFuncTest.ReadCom.OutBufferCount = 0
 
        'write to output buffer
        FrmFuncTest.ReadCom.Output = vSndAry
 
        'read from input buffer
        sTime = Timer
        bolWritePlcB_06 = True
        Do While bolWritePlcB_06
           If FrmFuncTest.ReadCom.InBufferCount >= 8 Then
              bolWritePlcB_06 = True
              Exit Do
           End If
           cTime = Timer
           If (cTime - sTime) > cTimeOut Then
              bolWritePlcB_06 = False
           Else
              If (Timer - sTime) < 0 Then sTime = Timer
           End If
           Dummy = DoEvents()
        Loop
        
        If bolWritePlcB_06 Then
           vRetAry = FrmFuncTest.ReadCom.Input
           vCrcAry = CrcB(vRetAry, 6)
           If vCrcAry(0) <> vRetAry(6) Or vCrcAry(1) <> vRetAry(7) _
              Or vSndAry(0) <> vRetAry(0) Or vSndAry(1) <> vRetAry(1) Then
              bolWritePlcB_06 = False
              Exit Function
           End If
        End If
        Exit Function
       
      
        
WritePlcErr:
        bolWritePlcB_06 = False
End Function
 
Function CrcB(ByVal vBAry As Variant, ByVal iLen As Integer) As Variant
'作者:Henry
'目的:
'     计算Byte数组中选定长度数据的Crc检查码，并传回
'传入:
'     vBAry:欲计算之Byte数组
'     iLen:欲计算之长度(以Byte为单位)
'传回:
'     数值数组的Crc Check码
'注:计算由0开始至iLen-1的元素为止
 
Dim i, j As Integer
Dim bbL, ddL, bbH, ddH, tta, ttb, ttc As Integer
 
        bbL = 255
        ddL = 255
        bbH = 255
        ddH = 255
        
        For i = 0 To iLen - 1
 
            tta = vBAry(i)
            bbL = bbL Xor bbL
            ddL = ddL Xor tta
            ttc = 0
            For j = 0 To 7
                If ((ddL And (2 ^ j)) <> 0) Then ttc = ttc + 1
            Next j
            If ((ttc And 1) <> 0) Then bbL = 7
 
            bbH = ddL
 
            If ((bbL And 1) <> 0) Then
               tta = 1
            Else
               tta = 0
            End If
 
            If ((bbH And 1) <> 0) Then
               ttb = 1
            Else
               ttb = 0
            End If