PC Plus SuperCD (UK) 2002 September/PCPlus_193_Laplink2000.iso/Prog/vb/comm/CommControl.vb

Text File | 2002-04-29 | 14.6 KB | 383 lines

Imports System.Runtime.InteropServices
Imports System.Threading
Public Class CommControl
    Inherits System.Windows.Forms.UserControl

#Region " Windows Form Designer generated code "

    Public Sub New()
        MyBase.New()

        'This call is required by the Windows Form Designer.
        InitializeComponent()

        'Add any initialization after the InitializeComponent() call

    End Sub

    'UserControl overrides dispose to clean up the component list.
    Protected Overloads Overrides Sub Dispose(ByVal disposing As Boolean)
        If disposing Then
            If Not (components Is Nothing) Then
                components.Dispose()
            End If
        End If
        MyBase.Dispose(disposing)
    End Sub

    'Required by the Windows Form Designer
    Private components As System.ComponentModel.IContainer

    'NOTE: The following procedure is required by the Windows Form Designer
    'It can be modified using the Windows Form Designer.
    'Do not modify it using the code editor.
    <System.Diagnostics.DebuggerStepThrough()> Private Sub InitializeComponent()
        '
        'CommControl
        '
        Me.Name = "CommControl"

    End Sub

#End Region

    Private Sub CommControl_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load

        GCHandle.Alloc(o, GCHandleType.Pinned)
        GCHandle.Alloc(bytesWritten, GCHandleType.Pinned)
        GCHandle.Alloc(bytesRead, GCHandleType.Pinned)
        GCHandle.Alloc(readBuffer, GCHandleType.Pinned)

    End Sub

    Private o As OVERLAPPED
    Private evtMask As Integer ' event mask
    Private h As Integer ' port handle
    Private bytesRead As Integer ' number of bytes in read
    Private bytesWritten As Integer ' number of bytes written
    Private readBuffer(1000) As Byte ' main read buffer
    Private readBufferPosition As Integer ' position in main read buffer
    Event commEvent(ByVal m As Integer)
    Private CTS_State As Boolean ' CTS property value
    Private DTR_State As Boolean ' DTR property value
    Private write_in_progress As Boolean

    Structure SECURITY_ATTRIBUTES
        Public nLength As Integer
        Public lpSecurityDescriptor As Integer
        Public bInheritHandle As Integer
    End Structure

    Structure OVERLAPPED
        Private Internal As Integer
        Private InternalHigh As Integer
        Private offset As Integer
        Private OffsetHigh As Integer
        Public hEvent As Integer
    End Structure

    Public Structure DCB
        Public DCBlength As Integer
        Public BaudRate As Integer
        Public fBitFields As Integer
        Private wReserved As Short
        Public XonLim As Short
        Public XoffLim As Short
        Public ByteSize As Byte
        Public Parity As Byte
        Public StopBits As Byte
        Public XonChar As Byte
        Public XoffChar As Byte
        Public ErrorChar As Byte
        Public EofChar As Byte
        Public EvtChar As Byte
        Private wReserved1 As Short
    End Structure

    Public Structure COMMTIMEOUTS
        Public ReadIntervalTimeout As Integer
        Public ReadTotalTimeoutMultiplier As Integer
        Public ReadTotalTimeoutConstant As Integer
        Public WriteTotalTimeoutMultiplier As Integer
        Public WriteTotalTimeoutConstant As Integer
    End Structure

    Const GENERIC_WRITE As Integer = &H40000000
    Const GENERIC_READ As Integer = &H80000000
    Const CREATE_ALWAYS As Integer = 2
    Const OPEN_EXISTING As Integer = 3
    Const FILE_FLAG_NO_BUFFERING As Integer = &H20000000
    Const FILE_FLAG_WRITE_THROUGH As Integer = &H80000000
    Const FILE_FLAG_DELETE_ON_CLOSE As Integer = &H4000000
    Const FILE_FLAG_OVERLAPPED As Integer = &H40000000
    Const ERROR_IO_INCOMPLETE As Integer = 996
    Const ERROR_IO_PENDING As Integer = 997
    Const INFINITE = &HFFFFFFFF ' infinite timeout

    Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Integer, ByVal dwShareMode As Integer, ByVal lpSecurityAttributes As Integer, ByVal dwCreationDisposition As Integer, ByVal dwFlagsAndAttributes As Integer, ByVal hTemplateFile As Integer) As Integer
    Declare Function GetLastError Lib "kernel32" Alias "GetLastError" () As Integer
    Declare Function ReadFile Lib "kernel32" (ByVal hFile As Integer, ByRef lpBuffer As Byte, ByVal nNumberOfBytesToRead As Integer, ByRef lpNumberOfBytesRead As Integer, ByRef lpOverlapped As OVERLAPPED) As Integer
    Declare Function WriteFile Lib "kernel32" (ByVal hFile As Integer, ByVal lpBuffer() As Byte, ByVal nNumberOfBytesToWrite As Integer, ByRef lpNumberofBytesWritten As Integer, ByRef lpOverlapped As OVERLAPPED) As Integer
    Declare Function CloseHandle Lib "kernel32" (ByVal hFile As Integer) As Integer
    Declare Function SetCommState Lib "kernel32" Alias "SetCommState" (ByVal hFile As Integer, ByRef lpDCB As DCB) As Integer
    Declare Function EscapeCommFunction Lib "kernel32" Alias "EscapeCommFunction" (ByVal hFile As Integer, ByVal nFunc As Integer) As Integer
    Declare Function GetCommModemStatus Lib "kernel32" Alias "GetCommModemStatus" (ByVal hFile As Integer, ByRef lpModemStat As Integer) As Integer
    Declare Function SetCommMask Lib "kernel32" Alias "SetCommMask" (ByVal hFile As Integer, ByVal dwEvtMask As Integer) As Integer
    Declare Function WaitCommEvent Lib "kernel32" Alias "WaitCommEvent" (ByVal hFile As Integer, ByRef lpEvtMask As Integer, ByRef lpOverlapped As OVERLAPPED) As Integer
    Declare Function CreateEvent Lib "kernel32" Alias "CreateEventW" (ByRef lpEventAttributes As SECURITY_ATTRIBUTES, ByVal bManualReset As Integer, ByVal bInitialState As Integer, ByVal lpName As String) As Integer
    Declare Function WaitForSingleObject Lib "kernel32" Alias "WaitForSingleObject" (ByVal hHandle As Integer, ByVal dwMilliseconds As Integer) As Integer
    Declare Function GetOverlappedResult Lib "kernel32" Alias "GetOverlappedResult" (ByVal hFile As Integer, ByRef lpOverlapped As OVERLAPPED, ByRef lpNumberOfBytesTransferred As Integer, ByVal bWait As Integer) As Integer
    Declare Function ResetEvent Lib "kernel32" Alias "ResetEvent" (ByVal hEvent As Integer) As Integer
    Declare Function SetCommTimeouts Lib "kernel32" Alias "SetCommTimeouts" (ByVal hFile As Integer, ByRef lpCommTimeouts As COMMTIMEOUTS) As Integer

    Public Const EV_RXCHAR = &H1                '  character received
    Public Const EV_TXEMPTY = &H4              '  Write completed
    Public Const EV_RLSD = &H20                 '  RLSD changed state
    Public Const EV_CTS = &H8                   '  CTS changed state
    Public Const EV_DSR = &H10                  '  DSR changed state
    Public Const EV_RING = &H100                '  Ring signal detected

    Const SETRTS = 3 '  Set RTS high
    Const CLRRTS = 4 '  Set RTS low
    Const SETDTR = 5 '  Set DTR high
    Const CLRDTR = 6 '  Set DTR low

    Const MS_CTS_ON = &H10
    Const MS_DSR_ON = &H20
    Const MS_RING_ON = &H40
    Const MS_RLSD_ON = &H80

    Const WAIT_OBJECT_0 = &H0
    Const WAIT_TIMEOUT = &H102

    WriteOnly Property DTR() As Boolean
        Set(ByVal Value As Boolean)
            Dim r As Integer
            If Value = True Then
                r = EscapeCommFunction(h, SETDTR)
            Else
                r = EscapeCommFunction(h, CLRDTR)
            End If
            If r <> 1 Then
                r = GetLastError()
                Throw New System.Exception("Failed to set/clear DTR")
            End If
        End Set
    End Property
    WriteOnly Property RTS() As Boolean
        Set(ByVal Value As Boolean)
            Dim r As Integer
            If Value = True Then
                r = EscapeCommFunction(h, SETRTS)
            Else
                r = EscapeCommFunction(h, CLRRTS)
            End If
            If r <> 1 Then
                r = GetLastError()
                Throw New System.Exception("Failed to set/clear RTS")
            End If
        End Set
    End Property
    ReadOnly Property DSR() As Boolean
        Get
            Dim r As Integer
            Dim modem_status As Integer

            r = GetCommModemStatus(h, modem_status)
            If r <> 1 Then
                r = GetLastError()
                Throw New System.Exception("Failed to get DSR state")
            End If

            Return CBool(modem_status And MS_DSR_ON)

        End Get
    End Property
    ReadOnly Property CTS() As Boolean
        Get
            Dim r As Integer
            Dim modem_status As Integer

            r = GetCommModemStatus(h, modem_status)
            If r <> 1 Then
                r = GetLastError()
                Throw New System.Exception("Failed to get CTS state")
            End If

            Return CBool(modem_status And MS_CTS_ON)

        End Get
    End Property

    Public Function Open(ByVal portnumber As Integer) As Integer
        Dim r As Integer, portname As String

        portname = "COM" + portnumber.ToString
        Try
            h = CreateFile(portname, GENERIC_READ Or GENERIC_WRITE, 0, 0, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0)
            If h = -1 Then
                r = GetLastError()
                Throw New System.Exception("Port open failed")
            End If
        Finally
            r = 1
        End Try
        Open = r

    End Function
    Public Function Open(ByVal portnumber As Integer, ByVal speed As String) As Integer
        Dim r As Integer, d As DCB

        Open(portnumber)
        d.BaudRate = Int(speed)
        d.ByteSize = 8
        d.Parity = 0 ' no parity
        d.StopBits = 0 ' one stop bit
        d.fBitFields = 1 ' set binary mode
        d.DCBlength = Marshal.SizeOf(d)
        r = SetCommState(h, d)
        If r <> 1 Then
            r = GetLastError()
            Throw New System.Exception("Port open failed")
        End If
        r = 1

    End Function
    Public Function OpenWithEvents(ByVal portnumber As Integer, ByVal speed As String) As Integer
        Dim r, m As Integer
        Dim t As Thread
        Dim cto As COMMTIMEOUTS

        Open(portnumber, speed)
        o.hEvent = CreateEvent(Nothing, 1, 0, portnumber.ToString)
        m = EV_CTS Or EV_DSR Or EV_RING Or EV_RLSD Or EV_RXCHAR Or EV_TXEMPTY
        r = SetCommMask(h, m)
        If r <> 1 Then
            r = GetLastError()
            Throw New System.Exception("SetCommMask failed")
        End If

        cto.ReadIntervalTimeout = INFINITE
        cto.ReadTotalTimeoutConstant = 0
        cto.ReadTotalTimeoutMultiplier = 0
        cto.WriteTotalTimeoutConstant = 0
        cto.WriteTotalTimeoutMultiplier = 0
        r = SetCommTimeouts(h, cto)
        If r <> 1 Then
            r = GetLastError()
            Throw New System.Exception("SetCommTimeouts failed")
        End If

        t = New Thread(AddressOf eventThread)
        t.Start()

    End Function
    Public Sub Write(ByRef buf As String)
        Dim r As Integer, i As Integer
        Dim b(buf.Length - 1) As Byte

        SyncLock GetType(CommControl)
            If write_in_progress Then
                Throw New System.Exception("Write in progress")
            Else
                ' copy into byte array
                For i = 0 To buf.Length - 1
                    b(i) = Asc(buf.Chars(i))
                Next
                ' issue the write
                r = WriteFile(h, b, b.Length, bytesWritten, o)
                If r <> 1 Then
                    r = GetLastError()
                    If r <> ERROR_IO_PENDING Then
                        Throw New System.Exception("Write failed")
                    End If
                End If
                ' set the wip flag
                write_in_progress = True
            End If
        End SyncLock

    End Sub

    Public Function Read() As String
        Dim s As String
        Dim c As Char()
        Dim i As Integer

        SyncLock GetType(CommControl)
            ReDim c(readBufferPosition)
            For i = 0 To readBufferPosition - 1
                c(i) = ChrW(readBuffer(i))
            Next
            readBufferPosition = 0
            s = New String(c)
        End SyncLock
        Return s

    End Function

    Private Sub eventThread()
        Dim r As Integer

        Do
            evtMask = 0 ' clear the event mask
            r = WaitCommEvent(h, evtMask, o) ' start the wait operation
            If r <> 1 Then
                r = GetLastError()
                If r <> ERROR_IO_PENDING Then
                    Throw New System.Exception("WaitCommEvent failed")
                End If
            End If
            r = WaitForSingleObject(o.hEvent, INFINITE) ' do the waiting
            If r <> 1 Then
                r = GetLastError()
                If r <> ERROR_IO_PENDING Then
                    Throw New System.Exception("WaitForSingleObject failed")
                End If
            End If
            r = GetOverlappedResult(h, o, Nothing, 0) ' get the event mask
            If r <> 1 Then
                r = GetLastError()
                ' just in case the wait hasn't really completed
                If r = ERROR_IO_INCOMPLETE Then
                    evtMask = -1
                Else
                    Throw New System.Exception("GetOverlappedResult failed")
                End If
            End If
            r = ResetEvent(o.hEvent)
            If r <> 1 Then
                r = GetLastError()
                Throw New System.Exception("ResetEvent failed")
            End If

            ' release the wip flag if the write completed
            SyncLock GetType(CommControl)
                If evtMask And EV_TXEMPTY Then
                    write_in_progress = False
                End If
                If evtMask And EV_RXCHAR Then
                    Do
                        r = ReadFile(h, readBuffer(readBufferPosition), 1, bytesRead, Nothing)
                        If r <> 1 Then
                            r = GetLastError()
                            Throw New System.Exception("ResetEvent failed")
                        End If
                        If bytesRead <> 1 Then
                            Exit Do
                        Else
                            readBufferPosition += 1
                        End If
                    Loop
                End If
            End SyncLock
            ' only raise an event if there is somthing to do
            If evtMask > 0 Then
                RaiseEvent commEvent(evtMask)
            End If
        Loop

    End Sub

End Class