ab.bas

本人网上收集

Option Explicit
Dim tns%, comunicating

Private Sub CalcCRC (mes$)
Dim byt%, res&

  'Calculate CRC checksum for message then add
  'to end of message. Check for 10h byte 'DLE'
  'within message and change to 'DLE DLE'.
  
  byt% = 3
  Do
   res& = res& Xor Asc(Mid(mes$, byt%, 1))
   rotate res&
   'test for 'DLE' and double up to DLE DLE
   If Asc(Mid(mes$, byt%, 1)) = 16 Then
    'add extra DLE
    mes$ = Left$(mes$, byt%) + Chr(16) + Right$(mes$, Len(mes$) - byt%)
    byt% = byt% + 1 'don't include in CRC
   End If
   byt% = byt% + 1
  Loop While (byt% <= Len(mes$) - 2)
  res& = res& Xor 3 'ETX byte
  rotate res&

  'add CRC checksum to message
  mes$ = mes$ + Chr(res& Mod 256) + Chr(Int(res& / 256))

End Sub

Function ReadTable (start, n%())
Dim st, com$

  'read from PLC CIF data table, Micrologix=N7 SLC500=N9
  'the length of the block read is determined by the size
  'of the array passed.

  If comunicating Then Exit Function

  comunicating = True

  'clear buffer
  ab.Comm1.InputLen = 0
  com$ = ab.Comm1.Input
  
  'construct message
  com$ = Chr(16) + Chr(2) + Chr(0) + Chr(0)
  com$ = com$ + Chr(1) + Chr(0) + Chr(tns%) + Chr(0)
  com$ = com$ + Chr(start) + Chr(0) + Chr(UBound(n%) * 2)
  com$ = com$ + Chr(16) + Chr(3)
  
 'calc crc checksum and add to command
  CalcCRC com$
  
  'increment transaction number and check for rollover
  tns% = tns% + 1
  If tns% = 256 Then tns% = 0
  
  'send command
  ab.Comm1.Output = com$

  'wait for acknowledgment
  st = Timer
  Do
   DoEvents
  Loop While st + 3 > Timer And ab.Comm1.InBufferCount < 2

 'remove acknowledgment from buffer
  ab.Comm1.InputLen = 2
  com$ = ab.Comm1.Input
  
  'check for good acknowledgement
  If com$ <> Chr(16) + Chr(6) Then
   comunicating = False
   Exit Function
  End If

  'wait for response
  st = Timer
  Do
   DoEvents
  Loop While st + 3 > Timer And ab.Comm1.InBufferCount < 12 + (UBound(n%) * 2)

  'if timeout then exit
  If ab.Comm1.InBufferCount < 12 + (UBound(n%) * 2) Then
   comunicating = False
   Exit Function
  End If
  
  'send acknowledgment
  ab.Comm1.Output = Chr(16) + Chr(6)

  'get response
  ab.Comm1.InputLen = 0
  com$ = ab.Comm1.Input
  
  'remove surplus 'DLE's
  st = 3
  Do
   If Mid(com$, st, 1) = Chr(16) Then
    com$ = Left(com$, st) + Right(com$, Len(com$) - 1 - st)
   End If
  st = st + 1
  Loop While st < Len(com$) - 4

  'store results
  For st = 0 To UBound(n%) - 1
   n%(st) = 256 * Asc(Mid(com$, 2 * st + 10, 1)) + Asc(Mid(com$, 2 * st + 9, 1))
  Next st

  ReadTable = True

  comunicating = False

End Function

Private Sub rotate (res&)
Dim bitout%, shift%

  'Rotate result 8 times and combine with const.
  For shift% = 1 To 8
   bitout% = res& Mod 2 'test if bit will be shifted out
   res& = Int(res& / 2) 'shift right
   If bitout% Then
    res& = res& Xor &H1000A001 'xor with constant
    res& = res& - &H10000000 'clear top word
   End If
  Next shift%

End Sub

Function WriteTable (start, n%())
Dim st, com$

  'Write to PLC CIF data table, Micrologix=N7 SLC500=N9
  'the length of the block read is determined by the size
  'of the array passed.
  
  If comunicating Then Exit Function

  comunicating = True

  'clear buffer
  ab.Comm1.InputLen = 0
  com$ = ab.Comm1.Input
  
  'construct message
  com$ = Chr(16) + Chr(2) + Chr(0) + Chr(0)
  com$ = com$ + Chr(8) + Chr(0) + Chr(tns%) + Chr(0)
  com$ = com$ + Chr(start) + Chr(0)
  'add data
  For st = 0 To UBound(n%)
   com$ = com$ + Chr(n%(st) Mod 256) + Chr(Int(n%(st) / 256))
  Next st
  com$ = com$ + Chr(16) + Chr(3)
  
  'increment transaction number and check for rollover
  tns% = tns% + 1
  If tns% = 256 Then tns% = 0

  'calc crc checksum and add to command
  CalcCRC com$
  
  'send command
  ab.Comm1.Output = com$

  'wait for acknowledgment
  st = Timer
  Do
   DoEvents
  Loop While st + 3 > Timer And ab.Comm1.InBufferCount < 2

 'remove acknowledgment from buffer
  ab.Comm1.InputLen = 2
  com$ = ab.Comm1.Input
  
  'check for good acknowledgement
  If com$ <> Chr(16) + Chr(6) Then
   comunicating = False
   Exit Function
  End If

  'wait for response
  st = Timer
  Do
   DoEvents
  Loop While st + 3 > Timer And ab.Comm1.InBufferCount < 12

  'send acknowledgment
  ab.Comm1.Output = Chr(16) + Chr(6)
 
  'if timeout then exit
  If ab.Comm1.InBufferCount < 12 Then
   comunicating = False
   Exit Function
  End If
  
  'send acknowledgment
  ab.Comm1.Output = Chr(16) + Chr(6)

  WriteTable = True
  
  comunicating = False

End Function