comm32.pas

一个比较好的串口控件(delphi 7.0)

unit Comm32;
//
// This Communications Component is implemented using separate Read and Write
// threads. Messages from the threads are posted to the Comm control which is
// an invisible window. To handle data from the comm port, simply
// attach a handler to 'OnReceiveData'. There is no need to free the memory
// buffer passed to this handler. If TAPI is used to open the comm port, some
// changes to this component are needed ('StartComm' currently opens the comm
// port). The 'OnRequestHangup' event is included to assist this.
//
// David Wann
// Stamina Software
// 28/02/96
// [e-mail]

interface

uses
	Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
	Misc;

const
	// messages from read/write threads
	PWM_GOTCOMMDATA = WM_USER + 1;
	PWM_REQUESTHANGUP = WM_USER + 2;

type
	ECommsError = class( Exception );

	TReadThread = class( TThread )
	protected
		procedure Execute; override;
	public
		hCommFile: 			THandle;
		hCloseEvent:		THandle;
		hComm32Window:		THandle;
		function SetupCommEvent( lpOverlappedCommEvent: POverlapped;
						var lpfdwEvtMask: DWORD ): Boolean;
		function SetupReadEvent( lpOverlappedRead: POverlapped;
						lpszInputBuffer: LPSTR; dwSizeofBuffer: DWORD;
						var lpnNumberOfBytesRead: DWORD ): Boolean;
		function HandleCommEvent( lpOverlappedCommEvent: POverlapped;
						var lpfdwEvtMask: DWORD; fRetrieveEvent: Boolean ): Boolean;
		function HandleReadEvent( lpOverlappedRead: POverlapped;
						lpszInputBuffer: LPSTR; dwSizeofBuffer: DWORD;
						var lpnNumberOfBytesRead: DWORD ): Boolean;
		function HandleReadData( lpszInputBuffer: LPCSTR; dwSizeofBuffer: DWORD ): Boolean;
		function ReceiveData( lpNewString: LPSTR; dwSizeofNewString: DWORD ): BOOL;
		procedure PostHangupCall;
	end;

	TWriteThread = class( TThread )
	protected
		procedure Execute; override;
		function HandleWriteData( lpOverlappedWrite: POverlapped;
				pDataToWrite: PChar; dwNumberOfBytesToWrite: DWORD): Boolean;
	public
		hCommFile: 			THandle;
		hCloseEvent:		THandle;
		hComm32Window:		THandle;
		function WriteComm( pDataToWrite: LPCSTR; dwSizeofDataToWrite: DWORD ): Boolean;
		procedure PostHangupCall;
	end;

	TReceiveDataEvent = procedure( Buffer: Pointer; BufferLength: Word ) of object;

	TComm32 = class( TComponent )
	private
		{ Private declarations }
		ReadThread:				TReadThread;
		WriteThread:			TWriteThread;
		FCommsLogFileName,
		FCommPort:				string;
		hCommFile: 				THandle;
		hCloseEvent:			THandle;
		FOnReceiveData: 		TReceiveDataEvent;
		FOnRequestHangup:		TNotifyEvent;
		FHWnd:					THandle;
		FBaudRate:			DWORD;

		procedure SetCommsLogFileName( LogFileName: string );
		function GetReceiveDataEvent: TReceiveDataEvent;
		procedure SetReceiveDataEvent( AReceiveDataEvent: TReceiveDataEvent );
		function GetRequestHangupEvent: TNotifyEvent;
		procedure SetRequestHangupEvent( ARequestHangupEvent: TNotifyEvent );
		procedure CommWndProc( var msg: TMessage );
	protected
		{ Protected declarations }
		procedure CloseReadThread;
		procedure CloseWriteThread;
		procedure ReceiveData( Buffer: PChar; BufferLength: Word );
		procedure RequestHangup;
	public
		{ Public declarations }
		constructor Create( AOwner: TComponent ); override;
		destructor Destroy; override;
		function StartComm: Boolean;
		procedure StopComm;
		function WriteCommData( pDataToWrite: PChar; dwSizeofDataToWrite: Word ): Boolean;
	published
		{ Published declarations }
		property BaudRate: DWORD read FBaudRate write FBaudRate;
		property CommPort: string read FCommPort write FCommPort;
		property CommsLogFileName: string read FCommsLogFileName write SetCommsLogFileName;
		property OnReceiveData: TReceiveDataEvent
				read GetReceiveDataEvent write SetReceiveDataEvent;
		property OnRequestHangup: TNotifyEvent
				read GetRequestHangupEvent write SetRequestHangupEvent;
	end;

const
// This is the message posted to the WriteThread
// When we have something to write.
	PWM_COMMWRITE = WM_USER+1;

// Default size of the Input Buffer used by this code.
	INPUTBUFFERSIZE = 2048;

var
	CommsLogFile:	Text; // means you can only debug 1 component at a time


procedure LogDebugInfo( outstr: PChar );
procedure LogDebugLastError( dwLastError: DWORD; szPrefix: LPSTR );
procedure Register;

implementation

var
	CommsLogName:	string; // used as a check if file is assigned

(******************************************************************************)
//									TCOMM32 PUBLIC METHODS
(******************************************************************************)

constructor TComm32.Create( AOwner: TComponent );
begin
	inherited Create( AOwner );
	FCommPort := 'COM2';
	FCommsLogFileName := '';
	CommsLogName := '';
	ReadThread := nil;
	WriteThread := nil;
	hCommFile := 0;
	if not (csDesigning in ComponentState) then
		FHWnd := AllocateHWnd(CommWndProc);
end;

destructor TComm32.Destroy;
begin
	if not (csDesigning in ComponentState) then
	begin
		DeallocateHWnd(FHwnd);
	end;
	inherited Destroy;
end;

//
//  FUNCTION: StartComm
//
//  PURPOSE: Starts communications over the comm port.
//
//  PARAMETERS:
//    hNewCommFile - This is the COMM File handle to communicate with.
//                   This handle is obtained from TAPI.
//
//  RETURN VALUE:
//    TRUE if able to setup the communications.
//
//  COMMENTS:
//
//    StartComm makes sure there isn't communication in progress already,
//    creates a Comm file, and creates the read and write threads.  It
//    also configures the hNewCommFile for the appropriate COMM settings.
//
//    If StartComm fails for any reason, it's up to the calling application
//    to close the Comm file handle.
//
//
function TComm32.StartComm: Boolean;
var
	commtimeouts:	TCommTimeouts;
	dcb:				Tdcb;
	commprop:		TCommProp;
	fdwEvtMask:		DWORD;
	hNewCommFile: THandle;
begin
	// Are we already doing comm?
	if (hCommFile <> 0) then
		raise ECommsError.Create( 'Already have a comm file open' );

	if CommsLogFileName <> '' then
	begin
		AssignFile( CommsLogFile, fCommsLogFileName );
		Rewrite( CommsLogFile );
	end;

	hNewCommFile := CreateFile(
							PChar(fCommPort),
							GENERIC_READ+GENERIC_WRITE,
							0, {not shared}
							nil, {no security ??}
							OPEN_EXISTING,
							{FILE_ATTRIBUTE_NORMAL+}FILE_FLAG_OVERLAPPED,
							0 {template} );
	if hNewCommFile = INVALID_HANDLE_VALUE then
		raise ECommsError.Create( 'Error opening com port' );

	// Is this a valid comm handle?
	if GetFileType( hNewCommFile ) <> FILE_TYPE_CHAR then
		raise ECommsError.Create( 'File handle is not a comm handle. ' );

	// Its ok to continue.

	hCommFile := hNewCommFile;

	// Setting and querying the comm port configurations.

	// Configure the comm settings.
	// NOTE: Most Comm settings can be set through TAPI, but this means that
	//       the CommFile will have to be passed to this component.

	GetCommState( hNewCommFile, dcb );
	GetCommProperties( hNewCommFile, commprop );
	GetCommMask( hCommFile, fdwEvtMask );
	GetCommTimeouts( hCommFile, commtimeouts );

	// The CommTimeout numbers will very likely change if you are
	// coding to meet some kind of specification where
	// you need to reply within a certain amount of time after
	// recieving the last byte.  However,  If 1/4th of a second
	// goes by between recieving two characters, its a good
	// indication that the transmitting end has finished, even
	// assuming a 1200 baud modem.

	commtimeouts.ReadIntervalTimeout         := 250;
	commtimeouts.ReadTotalTimeoutMultiplier  := 0;
	commtimeouts.ReadTotalTimeoutConstant    := 0;
	commtimeouts.WriteTotalTimeoutMultiplier := 0;
	commtimeouts.WriteTotalTimeoutConstant   := 0;

	SetCommTimeouts( hCommFile, commtimeouts );

	// fAbortOnError is the only DCB dependancy in TapiComm.
	// Can't guarentee that the SP will set this to what we expect.
	{dcb.fAbortOnError := False; NOT VALID}
	dcb.BaudRate := FBaudRate;
	SetCommState( hNewCommFile, dcb );

	// Create the event that will signal the threads to close.
	hCloseEvent := CreateEvent( nil, True, False, nil );

	if hCloseEvent = 0 then
	begin
		 LogDebugLastError( GetLastError, 'Unable to CreateEvent: ' );
		 hCommFile := 0;
		 Result := False;
		 Exit
	end;

	// Create the Read thread.
	try
		ReadThread := TReadThread.Create( True {suspended} );
	except
		LogDebugLastError( GetLastError, 'Unable to create Read thread' );
		raise ECommsError.Create( 'Unable to create Read thread' );
	end;
	ReadThread.hCommFile := hCommFile;
	ReadThread.hCloseEvent := hCloseEvent;
	ReadThread.hComm32Window := FHWnd;
	ReadThread.Resume;

	// Comm threads should have a higher base priority than the UI thread.
	// If they don't, then any temporary priority boost the UI thread gains
	// could cause the COMM threads to loose data.
	ReadThread.Priority := tpHighest;

	// Create the Write thread.
	try
		WriteThread := TWriteThread.Create( True {suspended} );
	except
		LogDebugLastError( GetLastError, 'Unable to create Write thread' );
		raise ECommsError.Create( 'Unable to create Write thread' );
	end;
	WriteThread.hCommFile := hCommFile;
	WriteThread.hCloseEvent := hCloseEvent;
	WriteThread.hComm32Window := FHWnd;
	WriteThread.Resume;

	ReadThread.Priority := tpHigher;

	// Everything was created ok.  Ready to go!
	Result := True;
end; {TComm32.StartComm}

//
//  FUNCTION: StopComm
//
//  PURPOSE: Stop and end all communication threads.
//
//  PARAMETERS:
//    none
//
//  RETURN VALUE:
//    none
//
//  COMMENTS:
//
//    Tries to gracefully signal all communication threads to
//    close, but terminates them if it has to.
//
//
procedure TComm32.StopComm;
begin
	// No need to continue if we're not communicating.
	if hCommFile = 0 then
		Exit;

	LogDebugInfo( 'Stopping the Comm' );

	 // Close the threads.
	CloseReadThread;
	CloseWriteThread;

	// Not needed anymore.
	CloseHandle( hCloseEvent );

	// Now close the comm port handle.
	CloseHandle( hCommFile );
	hCommFile := 0;
	if fCommsLogFileName <> '' then
		CloseFile( CommsLogFile );
end; {TComm32.StopComm}

//
//  FUNCTION: WriteCommData(PChar, Word)
//
//  PURPOSE: Send a String to the Write Thread to be written to the Comm.
//
//  PARAMETERS:
//    pszStringToWrite     - String to Write to Comm port.
//    nSizeofStringToWrite - length of pszStringToWrite.
//
//  RETURN VALUE:
//    Returns TRUE if the PostMessage is successful.
//    Returns FALSE if PostMessage fails or Write thread doesn't exist.
//
//  COMMENTS:
//
//    This is a wrapper function so that other modules don't care that
//    Comm writing is done via PostMessage to a Write thread.  Note that
//    using PostMessage speeds up response to the UI (very little delay to
//    'write' a string) and provides a natural buffer if the comm is slow
//    (ie:  the messages just pile up in the message queue).
//
//    Note that it is assumed that pszStringToWrite is allocated with
//    LocalAlloc, and that if WriteCommData succeeds, its the job of the
//    Write thread to LocalFree it.  If WriteCommData fails, then its
//    the job of the calling function to free the string.
//
//
function TComm32.WriteCommData( pDataToWrite: PChar; dwSizeofDataToWrite: Word ): Boolean;
var
	Buffer:	Pointer;
begin
	if WriteThread <> nil then
	begin
		Buffer := Pointer(LocalAlloc( LPTR, dwSizeofDataToWrite+1 ));
		Move( pDataToWrite^, Buffer^, dwSizeofDataToWrite );
		if PostThreadMessage( WriteThread.ThreadID, PWM_COMMWRITE,
					 WPARAM(dwSizeofDataToWrite), LPARAM(Buffer) ) then
		begin
			Result := true;
			Exit;
		end
		else
			LogDebugInfo( 'Failed to Post to Write thread. ' );
	end
	else
		LogDebugInfo( 'Write thread not created' );

	Result := False;
end; {TComm32.WriteCommData}

(******************************************************************************)
//									TCOMM32 PROTECTED METHODS
(******************************************************************************)

//
//  FUNCTION: CloseReadThread
//
//  PURPOSE: Close the Read Thread.
//
//  PARAMETERS:
//    none
//
//  RETURN VALUE:
//    none
//
//  COMMENTS:
//
//    Closes the Read thread by signaling the CloseEvent.
//    Purges any outstanding reads on the comm port.
//
//    Note that terminating a thread leaks memory.
//    Besides the normal leak incurred, there is an event object
//    that doesn't get closed.  This isn't worth worrying about
//    since it shouldn't happen anyway.
//
//
procedure TComm32.CloseReadThread;
begin
	// If it exists...
	if ReadThread <> nil then
	begin
		LogDebugInfo( 'Closing Read Thread ');

		// Signal the event to close the worker threads.
		SetEvent( hCloseEvent );

		// Purge all outstanding reads
		PurgeComm( hCommFile, PURGE_RXABORT + PURGE_RXCLEAR );

		// Wait 10 seconds for it to exit.  Shouldn't happen.
		if (WaitForSingleObject(ReadThread.Handle, 10000) = WAIT_TIMEOUT) then
		begin
			LogDebugInfo( 'Read thread not exiting.  Terminating it.' );
			ReadThread.Terminate;
		end;
		ReadThread.Free;
		ReadThread := nil;
	end;
end; {TComm32.CloseReadThread}


//
//  FUNCTION: CloseWriteThread
//
//  PURPOSE: Closes the Write Thread.
//
//  PARAMETERS:
//    none
//
//  RETURN VALUE:
//    none
//
//  COMMENTS:
//
//    Closes the write thread by signaling the CloseEvent.
//    Purges any outstanding writes on the comm port.
//
//    Note that terminating a thread leaks memory.
//    Besides the normal leak incurred, there is an event object
//    that doesn't get closed.  This isn't worth worrying about
//    since it shouldn't happen anyway.
//
//
procedure TComm32.CloseWriteThread;
begin
	// If it exists...
	if WriteThread <> nil then
	begin
		LogDebugInfo( 'Closing Write Thread' );

		// Signal the event to close the worker threads.
		SetEvent(hCloseEvent);

		// Purge all outstanding writes.
		PurgeComm(hCommFile, PURGE_TXABORT + PURGE_TXCLEAR);

		// Wait 10 seconds for it to exit.  Shouldn't happen.
		if WaitForSingleObject( WriteThread.Handle, 10000 ) = WAIT_TIMEOUT then
		begin
			LogDebugInfo( 'Write thread not exiting.  Terminating it.' );
			WriteThread.Terminate;
		end;
		WriteThread.Free;
		WriteThread := nil;
	end;
end; {TComm32.CloseWriteThread}

procedure TComm32.ReceiveData( Buffer: PChar; BufferLength: Word );
begin
	if Assigned(FOnReceiveData) then
		FOnReceiveData( Buffer, BufferLength );
end;

procedure TComm32.RequestHangup;
begin
	if Assigned(FOnRequestHangup) then
		FOnRequestHangup( Self );
end;

(******************************************************************************)
//									TCOMM32 PRIVATE METHODS
(******************************************************************************)

procedure TComm32.SetCommsLogFileName( LogFileName: string );
begin
	CommsLogName := LogFileName;
	FCommsLogFileName := LogFileName;
end;

procedure TComm32.CommWndProc( var msg: TMessage );
begin
	case msg.msg of
		PWM_GOTCOMMDATA:
		begin
			ReceiveData( PChar(msg.LParam), msg.WParam );
			LocalFree( msg.LParam );
		end;
		PWM_REQUESTHANGUP: