dwcom.cls

一个水情自动测报系统的接收例程

'定时查看写操作
Public Sub DetectWrite()
    Dim res&
    If Not inprogress(1) Then Exit Sub
    '检查事件
    res = WaitForSingleObject(overlaps(1).hEvent, 0)
    ' 如果没有结束信号，就退出
    If res = WAIT_TIMEOUT Then Exit Sub
    '否则数据已经写出，调用写后处理
    ProcessWriteComplete
End Sub

' 控制数据的传递
Private Sub StartInput()
    Dim res&
    Dim s%
    ' 写操作正在进行，退出
    If inprogress(0) Then Exit Sub
    If handle = 0 Then DeviceNotOpenedError
    '读数据
    res = ReadFile(handle, CurrentInputBuffer, ClassBufferSizes, DataRead, overlaps(0))
    If res <> 0 Then
        '读后处理
        ProcessReadComplete
    Else
       '如果函数返回时操作任在继续
       s = GetLastError()
      ' MsgBox "s=" & s
      ' Debug.Print "s=" & s
        If s = ERROR_IO_PENDING Then
            inprogress(0) = True
            '#If DEBUGMODE Then
            '   Debug.Print "后台正在读"
            '#End If
        '如果出错
        Else
        be_open = False
           'Err.Raise vbObjectError + ERR_READFAIL, CLASS_NAME, "串口读操作失败"
        End If
    End If
End Sub

Public Sub DetectRead()
    Dim res&
    If Not inprogress(0) Then
        StartInput
        Exit Sub
    End If
        
    '检查读事件
    res = WaitForSingleObject(overlaps(0).hEvent, 0)
    ' 如果上次读操作还没结束，则退出
    If res = WAIT_TIMEOUT Then Exit Sub
    ' 读后处理
    ProcessReadComplete
End Sub
' 读后处理
Public Sub ProcessReadComplete()
    'Dim resstring$
    Dim d() As Byte
    Dim copied&
    '读结束了，从重叠结构中获取所读的数目
    If inprogress(0) Then
        DataRead = overlaps(0).InternalHigh
        inprogress(0) = False
    End If
    If DataRead <> 0 Then
       ReDim d(1 To DataRead) As Byte
       copied = lstrcpyFromBuffer(d(1), CurrentInputBuffer, DataRead)
         Call ShowInput(d(1), DataRead)
    End If
End Sub
'检测串口错误
Private Sub StartEventWatch()
    Dim res&
    Dim s%
    ' 如果检测已经在进行，则退出本次检测
    If inprogress(2) Then Exit Sub
    If handle = 0 Then DeviceNotOpenedError
    EventResults = 0
    '检测串口
    res = WaitCommEvent(handle, EventResults, overlaps(2))
    If res <> 0 Then
         '返回正确时
        ProcessEventComplete
    Else
        '判断有没有后台I/O正在进行
        s = GetLastError()
        'Debug.Print "s=" & s
        'Debug.Print "ERROR_IO_PENDING=" & ERROR_IO_PENDING
        If s = ERROR_IO_PENDING Then
            inprogress(2) = True
           ' #If DEBUGMODE Then
           '    Debug.Print "后台正在等待事件"
           ' #End If
        '出错
        Else
        be_open = False
            'Err.Raise vbObjectError + ERR_EVENTFAIL, CLASS_NAME, "串口设备出错"
        End If
    End If
End Sub
'事件结束
Private Sub ProcessEventComplete()
    Dim errors&
    If inprogress(2) Then ' Was overlapped
        inprogress(2) = False
    End If
    
    If EventResults <> 0 Then
        '#If DEBUGMODE Then
        ' Debug.Print "事件值 " & Hex$(EventResults)
        ' #End If
        'If Not (CallbackObject Is Nothing) Then
            Call ClearCommError(handle, errors, 0)
           '输出到界面的文本框
            'If (errors And CE_RXOVER) <> 0 Then Call CallbackObject.CommEvent(Me, "接受缓冲区满错误")
            'If (errors And CE_OVERRUN) <> 0 Then Call CallbackObject.CommEvent(Me, "接受超载出错")
            'If (errors And CE_RXPARITY) <> 0 Then Call CallbackObject.CommEvent(Me, "奇偶检验出错")
            'If (errors And CE_FRAME) <> 0 Then Call CallbackObject.CommEvent(Me, "帧出错")
            'If (errors And CE_BREAK) <> 0 Then Call CallbackObject.CommEvent(Me, "探测到中断")
            'If (errors And CE_TXFULL) <> 0 Then Call CallbackObject.CommEvent(Me, "输出满")
        'End If
    End If
End Sub

Private Sub DetectEvent()
    Dim res&
    If Not inprogress(2) Then
        StartEventWatch
        Exit Sub
    End If
        
    '后台操作时，检测串口事件有没有结束
    res = WaitForSingleObject(overlaps(2).hEvent, 0)
    '没有结束,退出
    If res = WAIT_TIMEOUT Then Exit Sub
    ' '事件结束
    ProcessEventComplete
End Sub

Private Sub ShowInput(ByRef commdata As Byte, ByVal longs As Integer)
Dim d(1 To 1024) As Byte
Dim i As Integer
CopyMem d(1), commdata, longs

For i = 1 To longs
 If Len(Hex(d(i))) = 1 Then
  CallbackObject.Text1.Text = CallbackObject.Text1.Text + "0" + Hex(d(i)) + " "
 Else
  CallbackObject.Text1.Text = CallbackObject.Text1.Text + Hex(d(i)) + " "
 End If
 
 If zijie = 4 Then
  Call return1(d(i)) '4字节
 Else
 If zijie = 8 Then
  Call return2(d(i)) '8字节
 Else
  Call return3(d(i)) '16字节SMART2000
 End If
 End If
 
Next i
End Sub




Private Sub return1(ByVal inchar As Byte)
On Error Resume Next

Select Case imm

Case 0
imm = 1
inx(1) = inchar
Exit Sub

Case 1
If pd1(inchar) Then
imm = 2
inx(2) = inchar
If Not pd3(inx(1), inx(2), zijie, ID) Then '不接收此站
imm = 1
inx(1) = inx(2)
Exit Sub
End If
Else
imm = 0
Exit Sub
End If

Case 2
If pd2(inchar) <> 0 Then '@1
  If pd2(inchar) = 1 Then '@2
     Rflx = 1 '一般数据
      If pd4(inx(1), inx(2), inchar, zijie, ID) Then '@3
      imm = 3
      inx(3) = inchar
      Else '不接收此站'@3

       If pd1(inchar) Then '@4
         imm = 2
         inx(1) = inx(2)
         inx(2) = inchar
          If Not pd3(inx(1), inx(2), zijie, ID) Then '不接收此站'@5
          imm = 1
          inx(1) = inx(2)
          End If '@5
       Else '@4
         imm = 0
       End If '@4

     End If '@3
  Else '@2
     Rflx = 2 '人工置数参数
  End If '@2



 Else '@1
  If pd1(inchar) Then
     imm = 2
     inx(1) = inx(2)
     inx(2) = inchar
  Else
     imm = 0
  End If
End If '@1

Case 3
inx(4) = inchar
If Rflx = 1 Then
Call R_Date(inx(1), inx(2), inx(3), inx(4))
imm = 0
Rflx = 0
Else
imm = imm + 1
End If


Case Else
inx(imm + 1) = inchar
imm = imm + 1
If ((imm = 11) And (Rflx = 2)) Then
'Call Man_Maker
imm = 0
Rflx = 0
End If


End Select
End Sub

Private Sub return2(ByVal inchar As Byte)
On Error Resume Next

Select Case imm2
Case 0
If inchar = QUHAO Then
imm2 = 1
inx2(1) = inchar
End If
Exit Sub

Case 1
If pd1(inchar) Then
imm2 = 2
inx2(2) = inchar
Else
If inchar = QUHAO Then
imm2 = 1
inx2(1) = inchar
End If
End If
Exit Sub

Case 2
If pd1(inchar) Then
 inx2(3) = inchar
 imm2 = 3
 If Not pd3(inx2(2), inx2(3), zijie, ID) Then '不接收此站
   If inx2(2) = QUHAO Then
    inx2(1) = inx2(2)
    inx2(2) = inx2(3)
    imm2 = 2
   Else
    If inx2(3) = QUHAO Then
    imm2 = 1
    inx2(1) = inx2(3)
    Else
    imm = 0
    End If
   End If
  Exit Sub
 End If
Else
 If inchar = QUHAO Then
  imm2 = 1
  inx2(1) = inchar
  Else
  imm2 = 0
 End If
End If
Exit Sub

Case 3
If pd1(inchar) Then
 If inchar = &HCA Or inchar = &HD1 Or inchar = &HFF Then
  imm2 = 4
  inx2(4) = inchar
 Else
   If inx2(2) = QUHAO Then
    imm2 = 3
    inx2(1) = inx2(2)
    inx2(2) = inx2(3)
    inx2(3) = inx2(4)
   Else
    If inx2(3) = QUHAO Then
     imm2 = 2
     inx2(1) = inx2(3)
     inx2(2) = inx2(4)
    Else
     If inchar = QUHAO Then
     imm2 = 1
     inx2(1) = inchar
     Else
     imm2 = 0
     End If
    End If
   End If
 End If
Else
 If inchar = QUHAO Then
  imm2 = 1
  inx2(1) = inchar
 Else
 imm2 = 0
 End If
End If
Exit Sub

Case 4
If pd1(inchar) Then
 imm2 = 5
 inx2(5) = inchar
Else
 If inchar = QUHAO Then
 imm2 = 1
 inx2(1) = inchar
 Else
 imm2 = 0
 End If
End If
Exit Sub

Case 5
If pd1(inchar) Then
 imm2 = 6
 inx2(6) = inchar