dwcomm.cls

主要对win2000传真猫的监测

' Close the comm port
Public Function CloseComm() As Long
    ' Already closed, just exit
    If handle = 0 Then Exit Function
    Set CallbackObject = Nothing
    Call CloseHandle(handle)
    handle = 0
End Function



' This is another entry to retreive the comm state
' Note how it handles the problem of DCB needing the
' dwComm object parameter
Public Function GetCommState() As Long
    If handle = 0 Then DeviceNotOpenedError
    GetCommState = DCB.GetCommState(Me)
End Function

' This is another entry to retrieve the comm state
' Note how it handles the problem of DCB needing the
' dwComm object parameter
Public Function SetCommState() As Long
    If handle = 0 Then DeviceNotOpenedError
    SetCommState = DCB.SetCommState(Me)
End Function

' Here are some easy functions to determine the current
' modem status

Public Property Get CTS_ON()
    Dim modemstatus&
    Dim res&
    If handle = 0 Then DeviceNotOpenedError
    res = GetCommModemStatus(handle, modemstatus)
    If res = 0 Then ModemStatusError
    CTS_ON = (modemstatus And MS_CTS_ON) <> 0
End Property


Public Property Get DSR_ON()
    Dim modemstatus&
    Dim res&
    If handle = 0 Then DeviceNotOpenedError
    res = GetCommModemStatus(handle, modemstatus)
    If res = 0 Then ModemStatusError
    DSR_ON = (modemstatus And MS_DSR_ON) <> 0

End Property


Public Property Get RING_ON()
    Dim modemstatus&
    Dim res&
    If handle = 0 Then DeviceNotOpenedError
    res = GetCommModemStatus(handle, modemstatus)
    If res = 0 Then ModemStatusError
    RING_ON = (modemstatus And MS_RING_ON) <> 0

End Property


Public Property Get RLSD_ON()
    Dim modemstatus&
    Dim res&
    If handle = 0 Then DeviceNotOpenedError
    res = GetCommModemStatus(handle, modemstatus)
    If res = 0 Then ModemStatusError
    RLSD_ON = (modemstatus And MS_RLSD_ON) <> 0
End Property



' Data output 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    ' Write operation is in progress
        CommOutput = True
        Exit Function
    End If
    ' Start a new output operation
    bytestosend = Len(PendingOutput)
    ' No data to send, just exit
    If bytestosend = 0 Then
        CommOutput = True
        Exit Function
    End If
    ' Don't overflow our buffer
    If bytestosend > ClassBufferSizes Then bytestosend = ClassBufferSizes
    ' If there is a null character, just send up to the null
    If lstrlen(PendingOutput) < bytestosend Then
        ' but mark that we should send the null as well
        bytestosend = lstrlen(PendingOutput)
        addnull = True
    End If
    
    If bytestosend > 0 Then Call lstrcpyToBuffer(CurrentOutputBuffer, PendingOutput, bytestosend + 1)
    If bytestosend = Len(PendingOutput) 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 "Pended write"
            #End If
        End If
    End If
End Function

' Restart the next output operation if necessary
Public Sub ProcessWriteComplete()
    inprogress(1) = False
    Call CommOutput("")
End Sub

' Called periodically
Public Sub PollWrite()
    Dim res&
    If Not inprogress(1) Then Exit Sub
    ' Check the event
    res = WaitForSingleObject(overlaps(1).hEvent, 0)
    ' If not yet signaled, just exit
    If res = WAIT_TIMEOUT Then Exit Sub
    ' Data was written - Try writing any pending data
    ProcessWriteComplete
End Sub

' This function enables or disables data transfer
Private Sub StartInput()
    Dim res&
    ' Read already in progress
    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
        If GetLastError() = ERROR_IO_PENDING Then
            inprogress(0) = True
            #If DEBUGMODE Then
               Debug.Print "pended read"
            #End If
        Else
            Err.Raise vbObjectError + ERR_READFAIL, CLASS_NAME, "Failure on Comm device read operation"
        End If
    End If
End Sub

Public Sub PollRead()
    Dim res&
    If Not inprogress(0) Then
        StartInput
        Exit Sub
    End If
        
    ' Check the event
    res = WaitForSingleObject(overlaps(0).hEvent, 0)
    ' If not yet signaled, just exit
    If res = WAIT_TIMEOUT Then Exit Sub
    ' Data was written - Try writing any pending data
    ProcessReadComplete
End Sub

Public Sub ProcessReadComplete()
    Dim resstring$
    Dim copied&
    If inprogress(0) Then ' Was overlapped
        DataRead = overlaps(0).InternalHigh
        inprogress(0) = False
    End If
    If DataRead <> 0 Then
      #If DEBUGMODE Then
        Debug.Print "Read " & DataRead & " bytes"
      #End If
        resstring$ = String$(DataRead + 1, 0)
        copied = lstrcpyFromBuffer(resstring, CurrentInputBuffer, DataRead + 1)
        If Not (CallbackObject Is Nothing) Then
            Call CallbackObject.CommInput(Me, Left$(resstring, DataRead))
        End If
    End If
End Sub

Private Sub StartEventWatch()
    Dim res&
    ' Read already in progress
    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
        If GetLastError() = ERROR_IO_PENDING Then
            inprogress(2) = True
            #If DEBUGMODE Then
               Debug.Print "pended event"
            #End If
        Else
            Err.Raise vbObjectError + ERR_EVENTFAIL, CLASS_NAME, "Failure on Comm device event test operation"
        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 "Event value " & 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, "Receive Queue Full Error")
            If (errors And CE_OVERRUN) <> 0 Then Call CallbackObject.CommEvent(Me, "Receive Overrun Error")
            If (errors And CE_RXPARITY) <> 0 Then Call CallbackObject.CommEvent(Me, "Receive Parity Error")
            If (errors And CE_FRAME) <> 0 Then Call CallbackObject.CommEvent(Me, "Frame Error")
            If (errors And CE_BREAK) <> 0 Then Call CallbackObject.CommEvent(Me, "Break Detected")
            If (errors And CE_TXFULL) <> 0 Then Call CallbackObject.CommEvent(Me, "Transmit Queue Full")
        End If
    End If
End Sub

Private Sub PollEvent()
    Dim res&
    If Not inprogress(2) Then
        StartEventWatch
        Exit Sub
    End If
        
    ' Check the event
    res = WaitForSingleObject(overlaps(2).hEvent, 0)
    ' If not yet signaled, just exit
    If res = WAIT_TIMEOUT Then Exit Sub
    ' Data was written - Try writing any pending data
    ProcessEventComplete
End Sub

' Test results on all background processes
Public Sub Poll()
    PollWrite
    PollRead
    PollEvent
End Sub