//*************************************************************************************** // 20060225: Updated by Frank Voorburg - Feaser // // - When using ReadXxx the windows messages are now being processed // - When using ReadXxx the loop will stop (FCancel) upon disconnect //*************************************************************************************** //------------------------------------------------------------------------ // UNIT : CPDrv.pas // CONTENTS : TCommPortDriver component // VERSION : 2.1 // TARGET : (Inprise's) Borland Delphi 4.0 // AUTHOR : Marco Cocco // STATUS : Freeware // INFOS : Implementation of TCommPortDriver component: // - non multithreaded serial I/O // KNOWN BUGS : none // COMPATIBILITY : Windows 95/98/NT/2000 // REPLACES : TCommPortDriver v2.00 (Delphi 4.0) // TCommPortDriver v1.08/16 (Delphi 1.0) // TCommPortDriver v1.08/32 (Delphi 2.0/3.0) // BACK/COMPAT. : partial - a lot of properties have been renamed // RELEASE DATE : 06/06/2000 // (Replaces v2.0 released on 30/NOV/1998) //------------------------------------------------------------------------ // FOR UPDATES : - sorry, no home page - // BUGS REPORT : mail to : mcocco@libero.it // or: ditrek@tiscalinet.it //------------------------------------------------------------------------ // // Copyright (c) 1996-2000 by Marco Cocco. All rights reseved. // Copyright (c) 1996-2000 by d3k Software Company. All rights reserved. // //****************************************************************************** //* Permission to use, copy, modify, and distribute this software and its * //* documentation without fee for any purpose is hereby granted, * //* provided that the above copyright notice appears on all copies and that * //* both that copyright notice and this permission notice appear in all * //* supporting documentation. * //* * //* NO REPRESENTATIONS ARE MADE ABOUT THE SUITABILITY OF THIS SOFTWARE FOR ANY * //* PURPOSE. IT IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED WARRANTY. * //* NEITHER MARCO COCCO OR D3K SHALL BE LIABLE FOR ANY DAMAGES SUFFERED BY * //* THE USE OF THIS SOFTWARE. * //****************************************************************************** unit CPDrv; interface uses // Delphi units Windows, Messages, SysUtils, Classes, Forms // ComDrv32 units ; //------------------------------------------------------------------------ // Property types //------------------------------------------------------------------------ type // Baud Rates (custom or 110...256k bauds) TBaudRate = ( brCustom, br110, br300, br600, br1200, br2400, br4800, br9600, br14400, br19200, br38400, br56000, br57600, br115200, br128000, br256000 ); // Port Numbers ( custom or COM1..COM16 ) TPortNumber = ( pnCustom, pnCOM1, pnCOM2, pnCOM3, pnCOM4, pnCOM5, pnCOM6, pnCOM7, pnCOM8, pnCOM9, pnCOM10, pnCOM11, pnCOM12, pnCOM13, pnCOM14, pnCOM15, pnCOM16 ); // Data bits ( 5, 6, 7, 8 ) TDataBits = ( db5BITS, db6BITS, db7BITS, db8BITS ); // Stop bits ( 1, 1.5, 2 ) TStopBits = ( sb1BITS, sb1HALFBITS, sb2BITS ); // Parity ( None, odd, even, mark, space ) TParity = ( ptNONE, ptODD, ptEVEN, ptMARK, ptSPACE ); // Hardware Flow Control ( None, None + RTS always on, RTS/CTS ) THwFlowControl = ( hfNONE, hfNONERTSON, hfRTSCTS ); // Software Flow Control ( None, XON/XOFF ) TSwFlowControl = ( sfNONE, sfXONXOFF ); // What to do with incomplete (incoming) packets ( Discard, Pass ) TPacketMode = ( pmDiscard, pmPass ); //------------------------------------------------------------------------ // Event types //------------------------------------------------------------------------ type // RX event ( packet mode disabled ) TReceiveDataEvent = procedure( Sender: TObject; DataPtr: pointer; DataSize: DWORD ) of object; // RX event ( packed mode enabled ) TReceivePacketEvent = procedure( Sender: TObject; Packet: pointer; DataSize: DWORD ) of object; //------------------------------------------------------------------------ // Other types //------------------------------------------------------------------------ type // Line status ( Clear To Send, Data Set Ready, Ring, Carrier Detect ) TLineStatus = ( lsCTS, lsDSR, lsRING, lsCD ); // Set of line status TLineStatusSet = set of TLineStatus; //------------------------------------------------------------------------ // Constants //------------------------------------------------------------------------ const RELEASE_NOCLOSE_PORT = HFILE(INVALID_HANDLE_VALUE-1); //------------------------------------------------------------------------ // TCommPortDriver component //------------------------------------------------------------------------ type TCommPortDriver = class( TComponent ) protected // Device Handle ( File Handle ) FHandle : HFILE; // # of the COM port to use, or pnCustom to use custom port name FPort : TPortNumber; // Custom port name ( usually '\\.\COMn', with n = 1..x ) FPortName : string; // COM Port speed (brXXX) FBaudRate : TBaudRate; // Baud rate ( actual numeric value ) FBaudRateValue : DWORD; // Data bits size (dbXXX) FDataBits : TDataBits; // How many stop bits to use (sbXXX) FStopBits : TStopBits; // Type of parity to use (ptXXX) FParity : TParity; // Type of hw handshaking (hw flow control) to use (hfXXX) FHwFlow : THwFlowControl; // Type of sw handshaking (sw flow control) to use (sFXXX) FSwFlow : TSwFlowControl; // Size of the input buffer FInBufSize : DWORD; // Size of the output buffer FOutBufSize : DWORD; // Size of a data packet FPacketSize : smallint; // ms to wait for a complete packet (<=0 = disabled) FPacketTimeout : integer; // What to do with incomplete packets (pmXXX) FPacketMode : TPacketMode; // Event to raise on data reception (asynchronous) FOnReceiveData : TReceiveDataEvent; // Event to raise on packet reception (asynchronous) FOnReceivePacket : TReceivePacketEvent; // ms of delay between COM port pollings FPollingDelay : word; // Specifies if the DTR line must be enabled/disabled on connect FEnableDTROnOpen : boolean; // Output timeout - milliseconds FOutputTimeout : word; // Timeout for ReadData FInputTimeout : DWORD; // Set to TRUE to prevent hangs when no device connected or // device is OFF FCkLineStatus : boolean; // This is used for the timer FNotifyWnd : HWND; // Temporary buffer (RX) - used internally FTempInBuffer : pointer; // Time of the first byte of current RX packet FFirstByteOfPacketTime : DWORD; // Number of RX polling timer pauses FRXPollingPauses : integer; FCancel : Boolean; // Sets the COM port handle procedure SetHandle( Value: HFILE ); // Selects the COM port to use procedure SetPort( Value: TPortNumber ); // Sets the port name procedure SetPortName( Value: string ); // Selects the baud rate procedure SetBaudRate( Value: TBaudRate ); // Selects the baud rate ( actual baud rate value ) procedure SetBaudRateValue( Value: DWORD ); // Selects the number of data bits procedure SetDataBits( Value: TDataBits ); // Selects the number of stop bits procedure SetStopBits( Value: TStopBits ); // Selects the kind of parity procedure SetParity( Value: TParity ); // Selects the kind of hardware flow control procedure SetHwFlowControl( Value: THwFlowControl ); // Selects the kind of software flow control procedure SetSwFlowControl( Value: TSwFlowControl ); // Sets the RX buffer size procedure SetInBufSize( Value: DWORD ); // Sets the TX buffer size procedure SetOutBufSize( Value: DWORD ); // Sets the size of incoming packets procedure SetPacketSize( Value: smallint ); // Sets the timeout for incoming packets procedure SetPacketTimeout( Value: integer ); // Sets the delay between polling checks procedure SetPollingDelay( Value: word ); // Applies current settings to open COM port function ApplyCOMSettings: boolean; // Polling proc procedure TimerWndProc( var msg: TMessage ); public // Constructor constructor Create( AOwner: TComponent ); override; // Destructor destructor Destroy; override; // Opens the COM port and takes of it. Returns false if something // goes wrong. function Connect: boolean; // Closes the COM port and releases control of it procedure Disconnect; // Returns true if COM port has been opened function Connected: boolean; // Returns the current state of CTS, DSR, RING and RLSD (CD) lines. // The function fails if the hardware does not support the control-register // values (that is, returned set is always empty). function GetLineStatus: TLineStatusSet; // Returns true if polling has not been paused function IsPolling: boolean; // Pauses polling procedure PausePolling; // Re-starts polling (after pause) procedure ContinuePolling; // Flushes the rx/tx buffers function FlushBuffers( inBuf, outBuf: boolean ): boolean; // Returns number of received bytes in the RX buffer function CountRX: integer; // Returns the output buffer free space or 65535 if not connected function OutFreeSpace: word; // Sends binary data function SendData( DataPtr: pointer; DataSize: DWORD ): DWORD; // Sends binary data. Returns number of bytes sent. Timeout overrides // the value specifiend in the OutputTimeout property function SendDataEx( DataPtr: pchar; DataSize, Timeout: DWORD ): DWORD; // Sends a byte. Returns true if the byte has been sent function SendByte( Value: byte ): boolean; // Sends a char. Returns true if the char has been sent function SendChar( Value: char ): boolean; // Sends a pascal string (NULL terminated if $H+ (default)) function SendString( s: string ): boolean; // Sends a C-style strings (NULL terminated) function SendZString( s: pchar ): boolean; // Reads binary data. Returns number of bytes read function ReadData( DataPtr: pchar; MaxDataSize: DWORD ): DWORD; // Reads a byte. Returns true if the byte has been read function ReadByte( var Value: byte ): boolean; // Reads a char. Returns true if char has been read function ReadChar( var Value: char ): boolean; // Set DTR line high (onOff=TRUE) or low (onOff=FALSE). // You must not use HW handshaking. procedure ToggleDTR( onOff: boolean ); // Set RTS line high (onOff=TRUE) or low (onOff=FALSE). // You must not use HW handshaking. procedure ToggleRTS( onOff: boolean ); // Make the Handle of the COM port public (for TAPI...) [read/write] property Handle: HFILE read FHandle write SetHandle; published // # of the COM Port to use ( or pnCustom for port by name ) property Port: TPortNumber read FPort write SetPort default pnCOM2; // Name of COM port property PortName: string read FPortName write SetPortName; // Speed ( Baud Rate ) property BaudRate: TBaudRate read FBaudRate write SetBaudRate default br9600; // Speed ( Actual Baud Rate value ) property BaudRateValue: DWORD read FBaudRateValue write SetBaudRateValue default 9600; // Data bits to use (5..8, for the 8250 the use of 5 data bits with 2 stop // bits is an invalid combination, as is 6, 7, or 8 data bits with 1.5 stop // bits) property DataBits: TDataBits read FDataBits write SetDataBits default db8BITS; // Stop bits to use (1, 1.5, 2) property StopBits: TStopBits read FStopBits write SetStopBits default sb1BITS; // Kind of Parity to use (none,odd,even,mark,space) property Parity: TParity read FParity write SetParity default ptNONE; // Kind of Hardware Flow Control to use: // hfNONE none // hfNONERTSON no flow control but keep RTS line on // hfRTSCTS Request-To-Send/Clear-To-Send property HwFlow: THwFlowControl read FHwFlow write SetHwFlowControl default hfNONERTSON; // Kind of Software Flow Control to use: // sfNONE none // sfXONXOFF XON/XOFF property SwFlow: TSwFlowControl read FSwFlow write SetSwFlowControl default sfNONE; // Input Buffer size ( suggested - driver might ignore this setting ! ) property InBufSize: DWORD read FInBufSize write SetInBufSize default 2048; // Output Buffer size ( suggested - driver usually ignores this setting ! ) property OutBufSize: DWORD read FOutBufSize write SetOutBufSize default 2048; // RX packet size ( this value must be less than InBufSize ) // A value <= 0 means "no packet mode" ( i.e. standard mode enabled ) property PacketSize: smallint read FPacketSize write SetPacketSize default -1; // Timeout (ms) for a complete packet (in RX) property PacketTimeout: integer read FPacketTimeout write SetPacketTimeout default -1; // What to do with incomplete packets (in RX) property PacketMode: TPacketMode read FPacketMode write FPacketMode default pmDiscard; // ms of delay between COM port pollings property PollingDelay: word read FPollingDelay write SetPollingDelay default 50; // Set to TRUE to enable DTR line on connect and to leave it on until disconnect. // Set to FALSE to disable DTR line on connect. property EnableDTROnOpen: boolean read FEnableDTROnOpen write FEnableDTROnOpen default true; // Output timeout (milliseconds) property OutputTimeout: word read FOutputTimeOut write FOutputTimeout default 500; // Input timeout (milliseconds) property InputTimeout: DWORD read FInputTimeOut write FInputTimeout default 200; // Set to TRUE to prevent hangs when no device connected or device is OFF property CheckLineStatus: boolean read FCkLineStatus write FCkLineStatus default false; // Event to raise when there is data available (input buffer has data) // (called only if PacketSize <= 0) property OnReceiveData: TReceiveDataEvent read FOnReceiveData write FOnReceiveData; // Event to raise when there is data packet available (called only if PacketSize > 0) property OnReceivePacket: TReceivePacketEvent read FOnReceivePacket write FOnReceivePacket; end; function BaudRateOf( bRate: TBaudRate ): DWORD; function DelayForRX( bRate: TBaudRate; DataSize: DWORD ): DWORD; implementation const Win32BaudRates: array[br110..br256000] of DWORD = ( CBR_110, CBR_300, CBR_600, CBR_1200, CBR_2400, CBR_4800, CBR_9600, CBR_14400, CBR_19200, CBR_38400, CBR_56000, CBR_57600, CBR_115200, CBR_128000, CBR_256000 ); const dcb_Binary = $00000001; dcb_ParityCheck = $00000002; dcb_OutxCtsFlow = $00000004; dcb_OutxDsrFlow = $00000008; dcb_DtrControlMask = $00000030; dcb_DtrControlDisable = $00000000; dcb_DtrControlEnable = $00000010; dcb_DtrControlHandshake = $00000020; dcb_DsrSensivity = $00000040; dcb_TXContinueOnXoff = $00000080; dcb_OutX = $00000100; dcb_InX = $00000200; dcb_ErrorChar = $00000400; dcb_NullStrip = $00000800; dcb_RtsControlMask = $00003000; dcb_RtsControlDisable = $00000000; dcb_RtsControlEnable = $00001000; dcb_RtsControlHandshake = $00002000; dcb_RtsControlToggle = $00003000; dcb_AbortOnError = $00004000; dcb_Reserveds = $FFFF8000; function GetWinPlatform: string; var ov: TOSVERSIONINFO; begin ov.dwOSVersionInfoSize := sizeof(ov); if GetVersionEx( ov ) then begin case ov.dwPlatformId of VER_PLATFORM_WIN32s: // Win32s on Windows 3.1 Result := 'W32S'; VER_PLATFORM_WIN32_WINDOWS: // Win32 on Windows 95/98 Result := 'W95'; VER_PLATFORM_WIN32_NT: // Windows NT Result := 'WNT'; end; end else Result := '??'; end; function GetWinVersion: DWORD; var ov: TOSVERSIONINFO; begin ov.dwOSVersionInfoSize := sizeof(ov); if GetVersionEx( ov ) then Result := MAKELONG( ov.dwMinorVersion, ov.dwMajorVersion ) else Result := $00000000; end; function BaudRateOf( bRate: TBaudRate ): DWORD; begin if bRate = brCustom then Result := 0 else Result := Win32BaudRates[ bRate ]; end; function DelayForRX( bRate: TBaudRate; DataSize: DWORD ): DWORD; begin Result := round( DataSize / (BaudRateOf(bRate) / 10) * 1000 ); end; constructor TCommPortDriver.Create( AOwner: TComponent ); begin inherited Create( AOwner ); // Initialize to default values ----------------------- // not canceled FCancel := false; // Not connected FHandle := INVALID_HANDLE_VALUE; // COM 2 FPort := pnCOM2; FPortName := '\\.\COM2'; // 9600 bauds FBaudRate := br9600; FBaudRateValue := BaudRateOf( br9600 ); // 8 data bits FDataBits := db8BITS; // 1 stop bit FStopBits := sb1BITS; // no parity FParity := ptNONE; // No hardware flow control but RTS on FHwFlow := hfNONERTSON; // No software flow control FSwFlow := sfNONE; // Input buffer of 2048 bytes FInBufSize := 2048; // Output buffer of 2048 bytes FOutBufSize := 2048; // Don't pack data FPacketSize := -1; // Packet timeout disabled FPacketTimeout := -1; // Discard incomplete packets FPacketMode := pmDiscard; // Poll COM port every 50ms FPollingDelay := 50; // Output timeout of 500ms FOutputTimeout := 500; // Timeout for ReadData(), 200ms FInputTimeout := 200; // DTR high on connect FEnableDTROnOpen := true; // Time not valid ( used by the packing routines ) FFirstByteOfPacketTime := DWORD(-1); // Don't check of off-line devices FCkLineStatus := false; // Init number of RX polling timer pauses - not paused FRXPollingPauses := 0; // Temporary buffer for received data FTempInBuffer := AllocMem( FInBufSize ); // Allocate a window handle to catch timer's notification messages if not (csDesigning in ComponentState) then FNotifyWnd := AllocateHWnd( TimerWndProc ); end; destructor TCommPortDriver.Destroy; begin // Be sure to release the COM port Disconnect; // Free the temporary buffer FreeMem( FTempInBuffer, FInBufSize ); // Destroy the timer's window if not (csDesigning in ComponentState) then DeallocateHWnd( FNotifyWnd ); // Call inherited destructor inherited Destroy; end; // The COM port handle made public and writeable. // This lets you connect to external opened com port. // Setting ComPortHandle to INVALID_PORT_HANDLE acts as Disconnect. procedure TCommPortDriver.SetHandle( Value: HFILE ); begin // If same COM port then do nothing if FHandle = Value then exit; // If value is RELEASE_NOCLOSE_PORT then stop controlling the COM port // without closing in if Value = RELEASE_NOCLOSE_PORT then begin // Stop the timer if Connected then KillTimer( FNotifyWnd, 1 ); // No more connected FHandle := INVALID_HANDLE_VALUE; end else begin // Disconnect Disconnect; // If Value is INVALID_HANDLE_VALUE then exit now if Value = INVALID_HANDLE_VALUE then exit; // Set COM port handle FHandle := Value; // Start the timer ( used for polling ) SetTimer( FNotifyWnd, 1, FPollingDelay, nil ); end; end; // Selects the COM port to use procedure TCommPortDriver.SetPort( Value: TPortNumber ); begin // Be sure we are not using any COM port if Connected then exit; // Change COM port FPort := Value; // Update the port name if FPort <> pnCustom then FPortName := Format( '\\.\COM%d', [ord(FPort)] ); end; // Sets the port name procedure TCommPortDriver.SetPortName( Value: string ); begin // Be sure we are not using any COM port if Connected then exit; // Change COM port FPort := pnCustom; // Update the port name FPortName := Value; end; // Selects the baud rate procedure TCommPortDriver.SetBaudRate( Value: TBaudRate ); begin // Set new COM speed FBaudRate := Value; if FBaudRate <> brCustom then FBaudRateValue := BaudRateOf( FBaudRate ); // Apply changes if Connected then ApplyCOMSettings; end; // Selects the baud rate ( actual baud rate value ) procedure TCommPortDriver.SetBaudRateValue( Value: DWORD ); begin // Set new COM speed FBaudRate := brCustom; FBaudRateValue := Value; // Apply changes if Connected then ApplyCOMSettings; end; // Selects the number of data bits procedure TCommPortDriver.SetDataBits( Value: TDataBits ); begin // Set new data bits FDataBits := Value; // Apply changes if Connected then ApplyCOMSettings; end; // Selects the number of stop bits procedure TCommPortDriver.SetStopBits( Value: TStopBits ); begin // Set new stop bits FStopBits := Value; // Apply changes if Connected then ApplyCOMSettings; end; // Selects the kind of parity procedure TCommPortDriver.SetParity( Value: TParity ); begin // Set new parity FParity := Value; // Apply changes if Connected then ApplyCOMSettings; end; // Selects the kind of hardware flow control procedure TCommPortDriver.SetHwFlowControl( Value: THwFlowControl ); begin // Set new hardware flow control FHwFlow := Value; // Apply changes if Connected then ApplyCOMSettings; end; // Selects the kind of software flow control procedure TCommPortDriver.SetSwFlowControl( Value: TSwFlowControl ); begin // Set new software flow control FSwFlow := Value; // Apply changes if Connected then ApplyCOMSettings; end; // Sets the RX buffer size procedure TCommPortDriver.SetInBufSize( Value: DWORD ); begin // Do nothing if connected if Connected then exit; // Free the temporary input buffer FreeMem( FTempInBuffer, FInBufSize ); // Set new input buffer size if Value > 8192 then Value := 8192 else if Value < 128 then Value := 128; FInBufSize := Value; // Allocate the temporary input buffer FTempInBuffer := AllocMem( FInBufSize ); // Adjust the RX packet size SetPacketSize( FPacketSize ); end; // Sets the TX buffer size procedure TCommPortDriver.SetOutBufSize( Value: DWORD ); begin // Do nothing if connected if Connected then exit; // Set new output buffer size if Value > 8192 then Value := 8192 else if Value < 128 then Value := 128; FOutBufSize := Value; end; // Sets the size of incoming packets procedure TCommPortDriver.SetPacketSize( Value: smallint ); begin // PackeSize <= 0 if data isn't to be 'packetized' if Value <= 0 then FPacketSize := -1 // If the PacketSize if greater than then RX buffer size then // increase the RX buffer size else if DWORD(Value) > FInBufSize then begin FPacketSize := Value; SetInBufSize( FPacketSize ); end; end; // Sets the timeout for incoming packets procedure TCommPortDriver.SetPacketTimeout( Value: integer ); begin // PacketTimeout <= 0 if packet timeout is to be disabled if Value < 1 then FPacketTimeout := -1 // PacketTimeout cannot be less than polling delay + some extra ms else if Value < FPollingDelay then FPacketTimeout := FPollingDelay + (FPollingDelay*40) div 100; end; // Sets the delay between polling checks procedure TCommPortDriver.SetPollingDelay( Value: word ); begin // Make it greater than 4 ms if Value < 5 then Value := 5; // If new delay is not equal to previous value... if Value <> FPollingDelay then begin // Stop the timer if Connected then KillTimer( FNotifyWnd, 1 ); // Store new delay value FPollingDelay := Value; // Restart the timer if Connected then SetTimer( FNotifyWnd, 1, FPollingDelay, nil ); // Adjust the packet timeout SetPacketTimeout( FPacketTimeout ); end; end; // Apply COM settings function TCommPortDriver.ApplyCOMSettings: boolean; var dcb: TDCB; begin // Do nothing if not connected Result := false; if not Connected then exit; // ** Setup DCB (Device Control Block) fields ****************************** // Clear all fillchar( dcb, sizeof(dcb), 0 ); // DCB structure size dcb.DCBLength := sizeof(dcb); // Baud rate dcb.BaudRate := FBaudRateValue; // Set fBinary: Win32 does not support non binary mode transfers // (also disable EOF check) dcb.Flags := dcb_Binary; // Enables the DTR line when the device is opened and leaves it on if EnableDTROnOpen then dcb.Flags := dcb.Flags or dcb_DtrControlEnable; // Kind of hw flow control to use case FHwFlow of // No hw flow control hfNONE:; // No hw flow control but set RTS high and leave it high hfNONERTSON: dcb.Flags := dcb.Flags or dcb_RtsControlEnable; // RTS/CTS (request-to-send/clear-to-send) flow control hfRTSCTS: dcb.Flags := dcb.Flags or dcb_OutxCtsFlow or dcb_RtsControlHandshake; end; // Kind of sw flow control to use case FSwFlow of // No sw flow control sfNONE:; // XON/XOFF sw flow control sfXONXOFF: dcb.Flags := dcb.Flags or dcb_OutX or dcb_InX; end; // Set XONLim: specifies the minimum number of bytes allowed in the input // buffer before the XON character is sent (or CTS is set). if (GetWinPlatform = 'WNT') and (GetWinVersion >= $00040000) then begin // WinNT 4.0 + Service Pack 3 needs XONLim to be less than or // equal to 4096 bytes. Win95/98 doesn't have such limit. if FInBufSize div 4 > 4096 then dcb.XONLim := 4096 else dcb.XONLim := FInBufSize div 4; end else dcb.XONLim := FInBufSize div 4; // Specifies the maximum number of bytes allowed in the input buffer before // the XOFF character is sent (or CTS is set low). The maximum number of bytes // allowed is calculated by subtracting this value from the size, in bytes, of // the input buffer. dcb.XOFFLim := dcb.XONLim; // How many data bits to use dcb.ByteSize := 5 + ord(FDataBits); // Kind of parity to use dcb.Parity := ord(FParity); // How many stop bits to use dcb.StopBits := ord(FStopbits); // XON ASCII char - DC1, Ctrl-Q, ASCII 17 dcb.XONChar := #17; // XOFF ASCII char - DC3, Ctrl-S, ASCII 19 dcb.XOFFChar := #19; // Apply new settings Result := SetCommState( FHandle, dcb ); if not Result then exit; // Flush buffers Result := FlushBuffers( true, true ); if not Result then exit; // Setup buffers size Result := SetupComm( FHandle, FInBufSize, FOutBufSize ); end; function TCommPortDriver.Connect: boolean; var tms: TCOMMTIMEOUTS; begin // not canceled FCancel := false; // Do nothing if already connected Result := Connected; if Result then exit; // Open the COM port FHandle := CreateFile( pchar(FPortName), GENERIC_READ or GENERIC_WRITE, 0, // Not shared nil, // No security attributes OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0 // No template ) ; Result := Connected; if not Result then exit; // Apply settings Result := ApplyCOMSettings; if not Result then begin Disconnect; exit; end; // Set ReadIntervalTimeout: Specifies the maximum time, in milliseconds, // allowed to elapse between the arrival of two characters on the // communications line. // We disable timeouts because we are polling the com port! tms.ReadIntervalTimeout := 1; // Set ReadTotalTimeoutMultiplier: Specifies the multiplier, in milliseconds, // used to calculate the total time-out period for read operations. tms.ReadTotalTimeoutMultiplier := 0; // Set ReadTotalTimeoutConstant: Specifies the constant, in milliseconds, // used to calculate the total time-out period for read operations. tms.ReadTotalTimeoutConstant := 1; // Set WriteTotalTimeoutMultiplier: Specifies the multiplier, in milliseconds, // used to calculate the total time-out period for write operations. tms.WriteTotalTimeoutMultiplier := 0; // Set WriteTotalTimeoutConstant: Specifies the constant, in milliseconds, // used to calculate the total time-out period for write operations. tms.WriteTotalTimeoutConstant := 10; // Apply timeouts SetCommTimeOuts( FHandle, tms ); // Start the timer (used for polling) SetTimer( FNotifyWnd, 1, FPollingDelay, nil ); end; procedure TCommPortDriver.Disconnect; begin // not canceled FCancel := true; if Connected then begin // Stop the timer (used for polling) KillTimer( FNotifyWnd, 1 ); // Release the COM port CloseHandle( FHandle ); // No more connected FHandle := INVALID_HANDLE_VALUE; end; end; // Returns true if connected function TCommPortDriver.Connected: boolean; begin Result := FHandle <> INVALID_HANDLE_VALUE; end; // Returns CTS, DSR, RING and RLSD (CD) signals status function TCommPortDriver.GetLineStatus: TLineStatusSet; var dwS: DWORD; begin Result := []; if not Connected then exit; // Retrieves modem control-register values. // The function fails if the hardware does not support the control-register // values. if not GetCommModemStatus( FHandle, dwS ) then exit; if dwS and MS_CTS_ON <> 0 then Result := Result + [lsCTS]; if dwS and MS_DSR_ON <> 0 then Result := Result + [lsDSR]; if dwS and MS_RING_ON <> 0 then Result := Result + [lsRING]; if dwS and MS_RLSD_ON <> 0 then Result := Result + [lsCD]; end; // Returns true if polling has not been paused function TCommPortDriver.IsPolling: boolean; begin Result := FRXPollingPauses <= 0; end; // Pauses polling procedure TCommPortDriver.PausePolling; begin // Inc. RX polling pauses counter inc( FRXPollingPauses ); end; // Re-starts polling (after pause) procedure TCommPortDriver.ContinuePolling; begin // Dec. RX polling pauses counter dec( FRXPollingPauses ); end; // Flush rx/tx buffers function TCommPortDriver.FlushBuffers( inBuf, outBuf: boolean ): boolean; var dwAction: DWORD; begin // Do nothing if not connected Result := false; if not Connected then exit; // Flush the RX data buffer dwAction := 0; if outBuf then dwAction := dwAction or PURGE_TXABORT or PURGE_TXCLEAR; // Flush the TX data buffer if inBuf then dwAction := dwAction or PURGE_RXABORT or PURGE_RXCLEAR; Result := PurgeComm( FHandle, dwAction ); // Used by the RX packet mechanism if Result then FFirstByteOfPacketTime := DWORD(-1); end; // Returns number of received bytes in the RX buffer function TCommPortDriver.CountRX: integer; var stat: TCOMSTAT; errs: DWORD; begin // Do nothing if port has not been opened Result := 65535; if not Connected then exit; // Get count ClearCommError( FHandle, errs, @stat ); Result := stat.cbInQue; end; // Returns the output buffer free space or 65535 if not connected function TCommPortDriver.OutFreeSpace: word; var stat: TCOMSTAT; errs: DWORD; begin if not Connected then Result := 65535 else begin ClearCommError( FHandle, errs, @stat ); Result := FOutBufSize - stat.cbOutQue; end; end; // Sends binary data. Returns number of bytes sent. Timeout overrides // the value specifiend in the OutputTimeout property function TCommPortDriver.SendDataEx( DataPtr: pchar; DataSize, Timeout: DWORD ): DWORD; var nToSend, nSent, t1: DWORD; begin // Do nothing if port has not been opened Result := 0; if not Connected then exit; // Current time t1 := GetTickCount; // Loop until all data sent or timeout occurred while DataSize > 0 do begin // Get TX buffer free space nToSend := OutFreeSpace; // If output buffer has some free space... if nToSend > 0 then begin // Check signals if FCkLineStatus and (GetLineStatus = []) then exit; // Don't send more bytes than we actually have to send if nToSend > DataSize then nToSend := DataSize; // Send WriteFile( FHandle, DataPtr^, nToSend, nSent, nil ); nSent := abs( nSent ); if nSent > 0 then begin // Update number of bytes sent Result := Result + nSent; // Decrease the count of bytes to send DataSize := DataSize - nSent; // Inc. data pointer DataPtr := DataPtr + nSent; // Get current time t1 := GetTickCount; // Continue. This skips the time check below (don't stop // trasmitting if the Timeout is set too low) continue; end; end; // Buffer is full. If we are waiting too long then exit if DWORD(GetTickCount-t1) > Timeout then exit; end; end; // Send data (breaks the data in small packets if it doesn't fit in the output // buffer) function TCommPortDriver.SendData( DataPtr: pointer; DataSize: DWORD ): DWORD; begin Result := SendDataEx( DataPtr, DataSize, FOutputTimeout ); end; // Sends a byte. Returns true if the byte has been sent function TCommPortDriver.SendByte( Value: byte ): boolean; begin Result := SendData( @Value, 1 ) = 1; end; // Sends a char. Returns true if the char has been sent function TCommPortDriver.SendChar( Value: char ): boolean; begin Result := SendData( @Value, 1 ) = 1; end; // Sends a pascal string (NULL terminated if $H+ (default)) function TCommPortDriver.SendString( s: string ): boolean; var len: DWORD; begin len := length( s ); {$IFOPT H+} // New syle pascal string (NULL terminated) Result := SendData( pchar(s), len ) = len; {$ELSE} // Old style pascal string (s[0] = length) Result := SendData( pchar(@s[1]), len ) = len; {$ENDIF} end; // Sends a C-style string (NULL terminated) function TCommPortDriver.SendZString( s: pchar ): boolean; var len: DWORD; begin len := strlen( s ); Result := SendData( s, len ) = len; end; // Reads binary data. Returns number of bytes read function TCommPortDriver.ReadData( DataPtr: pchar; MaxDataSize: DWORD ): DWORD; var nToRead, nRead, t1: DWORD; begin // Do nothing if port has not been opened Result := 0; if not Connected then exit; // Pause polling PausePolling; // Current time t1 := GetTickCount; // Loop until all requested data read or timeout occurred while MaxDataSize > 0 do begin Application.ProcessMessages; // ##Vg process these messages if FCancel then exit; // Get data bytes count in RX buffer nToRead := CountRX; // If input buffer has some data... if nToRead > 0 then begin // Don't read more bytes than we actually have to read if nToRead > MaxDataSize then nToRead := MaxDataSize; // Read ReadFile( FHandle, DataPtr^, nToRead, nRead, nil ); // Update number of bytes read Result := Result + nRead; // Decrease the count of bytes to read MaxDataSize := MaxDataSize - nRead; // Inc. data pointer DataPtr := DataPtr + nRead; // Get current time t1 := GetTickCount; // Continue. This skips the time check below (don't stop // reading if the FInputTimeout is set too low) continue; end; // Buffer is empty. If we are waiting too long then exit if (GetTickCount-t1) > FInputTimeout then break; end; // Continue polling ContinuePolling; end; // Reads a byte. Returns true if the byte has been read function TCommPortDriver.ReadByte( var Value: byte ): boolean; begin Result := ReadData( @Value, 1 ) = 1; end; // Reads a char. Returns true if char has been read function TCommPortDriver.ReadChar( var Value: char ): boolean; begin Result := ReadData( @Value, 1 ) = 1; end; // Set DTR line high (onOff=TRUE) or low (onOff=FALSE). // You must not use HW handshaking. procedure TCommPortDriver.ToggleDTR( onOff: boolean ); const funcs: array[boolean] of integer = (CLRDTR,SETDTR); begin if Connected then EscapeCommFunction( FHandle, funcs[onOff] ); end; // Set RTS line high (onOff=TRUE) or low (onOff=FALSE). // You must not use HW handshaking. procedure TCommPortDriver.ToggleRTS( onOff: boolean ); const funcs: array[boolean] of integer = (CLRRTS,SETRTS); begin if Connected then EscapeCommFunction( FHandle, funcs[onOff] ); end; // COM port polling proc procedure TCommPortDriver.TimerWndProc( var msg: TMessage ); var nRead, nToRead, dummy: DWORD; comStat: TCOMSTAT; begin if (msg.Msg = WM_TIMER) and Connected then begin // Do nothing if RX polling has been paused if FRXPollingPauses > 0 then exit; // If PacketSize is > 0 then raise the OnReceiveData event only if the RX // buffer has at least PacketSize bytes in it. ClearCommError( FHandle, dummy, @comStat ); if FPacketSize > 0 then begin // Complete packet received ? if DWORD(comStat.cbInQue) >= DWORD(FPacketSize) then begin repeat // Read the packet and pass it to the app nRead := 0; if ReadFile( FHandle, FTempInBuffer^, FPacketSize, nRead, nil ) then if (nRead <> 0) and Assigned(FOnReceivePacket) then FOnReceivePacket( Self, FTempInBuffer, nRead ); // Adjust time //if comStat.cbInQue >= FPacketSize then FFirstByteOfPacketTime := FFirstByteOfPacketTime + DelayForRX( FBaudRate, FPacketSize ); comStat.cbInQue := comStat.cbInQue - WORD(FPacketSize); if comStat.cbInQue = 0 then FFirstByteOfPacketTime := DWORD(-1); until DWORD(comStat.cbInQue) < DWORD(FPacketSize); // Done exit; end; // Handle packet timeouts if (FPacketTimeout > 0) and (FFirstByteOfPacketTime <> DWORD(-1)) and (GetTickCount - FFirstByteOfPacketTime > DWORD(FPacketTimeout)) then begin nRead := 0; // Read the "incomplete" packet if ReadFile( FHandle, FTempInBuffer^, comStat.cbInQue, nRead, nil ) then // If PacketMode is not pmDiscard then pass the packet to the app if (FPacketMode <> pmDiscard) and (nRead <> 0) and Assigned(FOnReceivePacket) then FOnReceivePacket( Self, FTempInBuffer, nRead ); // Restart waiting for a packet FFirstByteOfPacketTime := DWORD(-1); // Done exit; end; // Start time if (comStat.cbInQue > 0) and (FFirstByteOfPacketTime = DWORD(-1)) then FFirstByteOfPacketTime := GetTickCount; // Done exit; end; // Standard data handling nRead := 0; nToRead := comStat.cbInQue; if (nToRead > 0) and ReadFile( FHandle, FTempInBuffer^, nToRead, nRead, nil ) then if (nRead <> 0) and Assigned(FOnReceiveData) then FOnReceiveData( Self, FTempInBuffer, nRead ); end // Let Windows handle other messages else Msg.Result := DefWindowProc( FNotifyWnd, Msg.Msg, Msg.wParam, Msg.lParam ) ; end; end.