dwcom.cls

来自「本书源码主要针对目前流行的FTP、HTTP、E-mail、Telnet、ICMP」· CLS 代码 · 共 493 行 · 第 1/2 页

    timeouts.WriteTotalTimeoutConstant = 1
    SetCommTimeouts
    ' 初始化串口类
    Call dcbclass.GetCommState(Me)
   ' 设置通信事件掩膜
    Call SetCommMask(handle, CurrentEventMask)
   ' StartInput
    be_open = True
End Function

'关闭串口
Public Function CloseComm() As Long
    If handle = 0 Then Exit Function
    Set CallbackObject = Nothing
    Call CloseHandle(handle)
    handle = 0
End Function



' 获得串口状态

Public Function GetCommState() As Long
    If handle = 0 Then DeviceNotOpenedError
    GetCommState = dcbclass.GetCommState(Me)
End Function

'设置串口状态
Public Function SetCommState() As Long
    If handle = 0 Then DeviceNotOpenedError
    SetCommState = dcbclass.SetCommState(Me)
End Function


' 输出数据函数
Public Function CommOutput(outputdata As String) As Long
    Dim bytestosend&
    Dim res&
    Dim addnull As Boolean
    If handle = 0 Then DeviceNotOpenedError
    PendingOutput = PendingOutput & outputdata
    If inprogress(1) Then    ' 写操作正在进行
        CommOutput = True    '退出
        Exit Function
    End If
    ' 开始一个新的写操作
    bytestosend = LenB(StrConv(PendingOutput, vbFromUnicode)) ' Len(PendingOutput)
    '无数据输出，退出
    If bytestosend = 0 Then
        CommOutput = True
        Exit Function
    End If
    '防止缓冲区过界
    If bytestosend > ClassBufferSizes Then bytestosend = ClassBufferSizes
    ' null字符，也送
    If lstrlen(PendingOutput) < bytestosend Then
        bytestosend = lstrlen(PendingOutput)
        addnull = True '表明送出null字符
    End If
    '复制到缓冲区
    If bytestosend > 0 Then Call lstrcpyToBuffer(CurrentOutputBuffer, PendingOutput, bytestosend + 1)
    If bytestosend = LenB(StrConv(PendingOutput, vbFromUnicode)) Then
        PendingOutput = ""
    Else
        PendingOutput = Mid(PendingOutput, bytestosend + 1)
    End If
    If addnull Then bytestosend = bytestosend + 1
    '送出数据
    res = WriteFile(handle, CurrentOutputBuffer, bytestosend, DataWritten, overlaps(1))
    If res <> 0 Then
       '正常结束，处理后续
        ProcessWriteComplete
        CommOutput = True
    Else
        '函数返回时操作任在继续
        If GetLastError() = ERROR_IO_PENDING Then
            inprogress(1) = True
            CommOutput = True
            #If DEBUGMODE Then
               Debug.Print "后台正在写"
            #End If
        End If
    End If
End Function

'写后处理
Public Sub ProcessWriteComplete()
    inprogress(1) = False
    '通过CommOutput函数退出写操作
    Call CommOutput("")
End Sub

'检测所有的后台操作
Public Sub Detect()
    DetectWrite
    DetectRead
    DetectEvent
End Sub

'定时查看写操作
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
           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 copied&
    '读结束了，从重叠结构中获取所读的数目
    If inprogress(0) Then
        DataRead = overlaps(0).InternalHigh
        inprogress(0) = False
    End If
    If DataRead <> 0 Then
      #If DEBUGMODE Then
        Debug.Print "读出" & DataRead & " 字节"
      #End If
        resstring$ = String$(DataRead + 1, 0)
        copied = lstrcpyFromBuffer(resstring, CurrentInputBuffer, DataRead + 1)
        Debug.Print resstring
        '输出到界面上
        If Not (CallbackObject Is Nothing) Then
            Call CallbackObject.ShowInput(Me, Left$(resstring, DataRead))
        End If
    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
            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