现有一VBA源码程序供你参考。
现有一VBA源程序供你参考。下面是其用户程序的一部分，如果需要请给我联系。
Option Explicit
Dim TXOK As Boolean
Dim ARR() As Byte
Dim CRCCAL, CRCR As Long
Dim Dummy, SBCS, IBYTE As Integer
Dim BUFFER, OUTBUF As Variant
Dim A%, B%, C%, D%, E!, F!
Private Sub timer1_Timer()
Dim TXI, TXJ, ZH As Integer
Dim FC(4) As Byte
Timer1.Enabled = False
If Minute(Now()) = 0 And BZ = False Then
BZ = True
SJ_CC
End If
If Minute(Now()) <> 0 Then
BZ = False
End If
With Sheets("CJ")
For TXJ = 5 To 27
ZH = 0
Select Case TXJ
Case 5 To 12
IBYTE = 37
ZH = Val(.Cells(TXJ, 4).Value)
Case 16 To 18
IBYTE = 37
ZH = Val(.Cells(TXJ, 4).Value)
Case 22 To 23
IBYTE = 17
ZH = Val(.Cells(TXJ, 4).Value)
Case 27
IBYTE = 17
ZH = Val(.Cells(TXJ, 4).Value)
End Select
If ZH <> 0 Then
GoSub OK
End If
Next TXJ
End With
Timer1.Enabled = False
Timer1.Interval = 500
Timer1.Enabled = True
Exit Sub
OK:
With Sheets("CJ")
FC(0) = ZH
FC(1) = 3
CRCR = 65535
For TXI = 0 To 1
CRCCAL = FC(TXI) Xor CRCR And 255
CRCCAL = CRC(CRCCAL)
CRCR = (CRCR And 65280) / 256
CRCR = CRCR Xor CRCCAL
Next TXI
FC(2) = (CRCR And 255)
FC(3) = (CRCR And 65280) / 256
OUTBUF = FC
SBCS = 0
TXOK = False
MSComm1.InputLen = 0
MSComm1.RThreshold = IBYTE
MSComm1.InBufferCount = 0
MSComm1.NullDiscard = False
MSComm1.Output = OUTBUF
Timer2.Enabled = False
Timer2.Interval = 500
Timer2.Enabled = True
Do
Dummy = DoEvents()
If TZ = True Then ''''停止退出
Timer1.Enabled = False
Timer2.Enabled = False
Exit Sub
End If
If (MSComm1.InBufferCount = IBYTE) Then
BUFFER = MSComm1.Input
ARR = BUFFER
CRCR = 65535
For TXI = 0 To IBYTE - 3
CRCCAL = ARR(TXI) Xor CRCR And 255
CRCCAL = CRC(CRCCAL)
CRCR = (CRCR And 65280) / 256
CRCR = CRCR Xor CRCCAL
Next TXI
If (ARR(IBYTE - 2) = (CRCR And 255)) Then
If (ARR(IBYTE - 1) = (CRCR And 65280) / 256) Then
Timer2.Enabled = False
If ZH = ARR(0) And IBYTE = 37 Then
.Cells(TXJ, 9).Value = ""
For TXI = 0 To 6
A = ARR(TXI * 4 + 3)
B = ARR(TXI * 4 + 4)
C = ARR(TXI * 4 + 5)
D = ARR(TXI * 4 + 6)
F = READCARD(A, B, C, D, E)
Select Case TXI
Case 0
.Cells(TXJ, 9).Value = Format(E, "#0")
Case 1
If Val(.Cells(TXJ, 11).Value) > E + 1 Then
.Cells(TXJ, 10).Value = Val(.Cells(TXJ, 10).Value) + 1
End If
.Cells(TXJ, 11).Value = Format(E, "#0")
.Cells(TXJ, 5).Value = Val(.Cells(TXJ, 10).Value) * 100000 + Val(.Cells(TXJ, 11).Value)
Case 3
.Cells(TXJ, 6).Value = Format(E, "#0.00")
Case 5
.Cells(TXJ, 7).Value = Format(E, "#0.00")
Case 6
.Cells(TXJ, 8).Value = Format(E, "#0.00")
End Select
Next TXI
Exit Do
End If
If ZH = ARR(0) And IBYTE = 17 Then
.Cells(TXJ, 7).Value = ""
For TXI = 0 To 2
A = ARR(TXI * 4 + 3)
B = ARR(TXI * 4 + 4)
C = ARR(TXI * 4 + 5)
D = ARR(TXI * 4 + 6)
F = READCARD(A, B, C, D, E)
Select Case TXI
Case 0
.Cells(TXJ, 7).Value = Format(E, "#0")
Case 1
If Val(.Cells(TXJ, 11).Value) > E + 1 Then
.Cells(TXJ, 10).Value = Val(.Cells(TXJ, 10).Value) + 1
End If
.Cells(TXJ, 11).Value = Format(E, "#0")
.Cells(TXJ, 5).Value = Val(.Cells(TXJ, 10).Value) * 100000 + Val(.Cells(TXJ, 11).Value)
Case 2
.Cells(TXJ, 6).Value = Format(E, "#0.00")
End Select
Next TXI
Exit Do
End If
End If
End If
End If
If SBCS > 3 Then ''''通讯失败
.Cells(TXJ, 6).Value = ""
.Cells(TXJ, 7).Value = ""
.Cells(TXJ, 8).Value = ""
.Cells(TXJ, 9).Value = ""
Timer2.Enabled = False
Exit Do
End If
Loop
End With
Return
End Sub
Private Sub timer2_Timer() ''''重发请求
Timer2.Enabled = False
SBCS = SBCS + 1
If SBCS > 3 Then
Exit Sub
End If
MSComm1.InputLen = 0
MSComm1.RThreshold = IBYTE
MSComm1.InBufferCount = 0
MSComm1.NullDiscard = False
MSComm1.Output = OUTBUF
Timer2.Enabled = False
Timer2.Interval = 500
Timer2.Enabled = True
End Sub
[此贴子已经被作者于2004-7-16 9:24:05编辑过]
