comm32.pas

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

//
//    This function is a helper function for the Read Thread that (if
//    fRetrieveEvent == TRUE) retrieves an outstanding CommEvent and
//    deals with it.  The only event that should occur is an EV_ERR event,
//    signalling that there has been an error on the comm port.
//
//    Normally, comm errors would not be put into the normal data stream
//    as this sample is demonstrating.  Putting it in a status bar would
//    be more appropriate for a real application.
//
//
function TReadThread.HandleCommEvent( lpOverlappedCommEvent: POverlapped;
	 var lpfdwEvtMask: DWORD; fRetrieveEvent: Boolean ): Boolean;
var
	dwDummy:			DWORD;
	lpszOutput:		LPSTR;
	szError:			array[0..127] of Char;
	dwErrors,
	nOutput,
	dwLastError:	DWORD;
begin
	Result := False;

	szError[0] := #0;

	lpszOutput := PChar(LocalAlloc( LPTR, 256 ));
	if lpszOutput = nil{NULL} then
	begin
		LogDebugLastError( GetLastError, 'LocalAlloc: ' );
		Exit;
	end;

	// If this fails, it could be because the file was closed (and I/O is
	// finished) or because the overlapped I/O is still in progress.  In
	// either case (or any others) its a bug and return FALSE.
	if fRetrieveEvent then
		if not GetOverlappedResult( hCommFile,
					 lpOverlappedCommEvent^, dwDummy, False ) then
		begin
			dwLastError := GetLastError;

			// Its possible for this error to occur if the
			// service provider has closed the port.  Time to end.
			if dwLastError = ERROR_INVALID_HANDLE then
			begin
				LogDebugInfo( 'ERROR_INVALID_HANDLE, '+
						  'Likely that the Service Provider has closed the port.' );
				Exit;
			end;

			LogDebugLastError( dwLastError,
					 'Unexpected GetOverlappedResult for WaitCommEvent: ' );
			Exit;
		end;

	// Was the event an error?
	if (lpfdwEvtMask and EV_ERR) <> 0 then
	begin
		// Which error was it?
		if not ClearCommError( hCommFile, dwErrors, nil ) then
		begin
			dwLastError := GetLastError;

			// Its possible for this error to occur if the
			// service provider has closed the port.  Time to end.
			if dwLastError = ERROR_INVALID_HANDLE then
			begin
				LogDebugInfo( 'ERROR_INVALID_HANDLE, '+
					  'Likely that the Service Provider has closed the port.' );
				Exit;
			end;

			LogDebugLastError( GetLastError,'ClearCommError: ' );
			Exit;
		end;

		// Its possible that multiple errors occured and were handled
		// in the last ClearCommError.  Because all errors were signaled
		// individually, but cleared all at once, pending comm events
		// can yield EV_ERR while dwErrors equals 0.  Ignore this event.
		if dwErrors = 0 then
			strcat( szError, 'NULL Error' );

		if (dwErrors and CE_FRAME) <> 0 then
		begin
			if szError[0] <> #0 then
				strcat( szError, ' and ' );

			strcat( szError,'CE_FRAME' );
		end;

		if (dwErrors and CE_OVERRUN) <> 0 then
		begin
			if szError[0] <> #0 then
				strcat(szError, ' and ' );

			strcat( szError, 'CE_OVERRUN' );
		end;

		if (dwErrors and CE_RXPARITY) <> 0 then
		begin
			if szError[0] <> #0 then
				strcat( szError, ' and ' );

			strcat( szError, 'CE_RXPARITY' );
		end;

		if (dwErrors and not (CE_FRAME + CE_OVERRUN + CE_RXPARITY)) <> 0 then
		begin
			if szError[0] <> #0 then
				strcat( szError, ' and ' );

			strcat( szError, 'EV_ERR Unknown EvtMask' );
		end;

		nOutput := wsprintf(lpszOutput,
				PChar('Comm Event: '+szError+', EvtMask = '+IntToStr(dwErrors)) );

		ReceiveData( lpszOutput, nOutput );
		Result := True;
		Exit
	end;

	// Should not have gotten here.  Only interested in ERR conditions.

	LogDebugInfo( PChar('Unexpected comm event '+IntToStr(lpfdwEvtMask)) );
end; {TReadThread.HandleCommEvent}

function TReadThread.ReceiveData( lpNewString: LPSTR; dwSizeofNewString: DWORD ): BOOL;
begin
	Result := PostMessage( hComm32Window, PWM_GOTCOMMDATA,
		  WPARAM(dwSizeofNewString), LPARAM(lpNewString) );
end;

procedure TReadThread.PostHangupCall;
begin
	PostMessage( hComm32Window, PWM_REQUESTHANGUP, 0, 0 );
end;

(******************************************************************************)
//											WRITE THREAD
(******************************************************************************)

//
//  PROCEDURE: TWriteThread.Execute
//
//  PURPOSE: The starting point for the Write thread.
//
//  PARAMETERS:
//    lpvParam - unused.
//
//  RETURN VALUE:
//    DWORD - unused.
//
//  COMMENTS:
//
//    The Write thread uses a PeekMessage loop to wait for a string to write,
//    and when it gets one, it writes it to the Comm port.  If the CloseEvent
//    object is signaled, then it exits.  The use of messages to tell the
//    Write thread what to write provides a natural desynchronization between
//    the UI and the Write thread.
//
//
procedure TWriteThread.Execute;
var
	 msg:	TMsg;
	 dwHandleSignaled:	DWORD;
	 overlappedWrite:		TOverLapped;
label
	EndWriteThread;
begin

	 // Needed for overlapped I/O.
	 FillChar( overlappedWrite, SizeOf(overlappedWrite), 0 );  {0, 0, 0, 0, NULL}

	 overlappedWrite.hEvent := CreateEvent( nil, True, True, nil );
	 if overlappedWrite.hEvent = 0 then
	 begin
		  LogDebugLastError( GetLastError, 'Unable to CreateEvent: ' );
		  PostHangupCall;
		  goto EndWriteThread;
	 end;

	 // This is the main loop.  Loop until we break out.
	 while True do
	 begin
		  if not PeekMessage( msg, 0, 0, 0, PM_REMOVE ) then
		  begin
				// If there are no messages pending, wait for a message or
				// the CloseEvent.
				dwHandleSignaled :=
					 MsgWaitForMultipleObjects(1, hCloseEvent, False,
						  INFINITE, QS_ALLINPUT);

				case dwHandleSignaled of
					 WAIT_OBJECT_0:     // CloseEvent signaled!
					 begin
						  // Time to exit.
						  goto EndWriteThread;
					 end;

					 WAIT_OBJECT_0 + 1: // New message was received.
					 begin
						  // Get the message that woke us up by looping again.
						  continue;
					 end;

					 WAIT_FAILED:       // Wait failed.  Shouldn't happen.
					 begin
						  LogDebugLastError( GetLastError, 'Write WAIT_FAILED: ' );
						  PostHangupCall;
						  goto EndWriteThread;
					 end;

					 else                // This case should never occur.
					 begin
						  LogDebugInfo( PChar('Unexpected Wait return value '
														+IntToStr(dwHandleSignaled)) );
						  PostHangupCall;
						  goto EndWriteThread;
					 end;
				end;
		  end;

		  // Make sure the CloseEvent isn't signaled while retrieving messages.
		  if WAIT_TIMEOUT <> WaitForSingleObject(hCloseEvent,0) then
				goto EndWriteThread;

		  // Process the message.

		  // This could happen if a dialog is created on this thread.
		  // This doesn't occur in this sample, but might if modified.
		  if msg.hwnd <> 0{NULL} then
		  begin
				TranslateMessage(msg);
				DispatchMessage(msg);

				continue;
		  end;

		  // Handle the message.
		  case msg.message of
				PWM_COMMWRITE:  // New string to write to Comm port.
				begin
					 LogDebugInfo( 'Writing to comm port' );

					 // Write the string to the comm port.  HandleWriteData
					 // does not return until the whole string has been written,
					 // an error occurs or until the CloseEvent is signaled.
					 if not HandleWriteData( @overlappedWrite,
								PChar(msg.lParam), DWORD(msg.wParam) ) then
					 begin
						  // If it failed, either we got a signal to end or there
						  // really was a failure.

						  LocalFree( HLOCAL(msg.lParam) );
						  goto EndWriteThread;
					 end;

					 // Data was sent in a LocalAlloc()d buffer.  Must free it.
					 LocalFree( HLOCAL(msg.lParam) );
				end;

				// What other messages could the thread get?
				else
				begin
					 LogDebugInfo( PChar('Unexpected message posted to Write thread: '+
						  IntToStr(msg.message)) );
					 {break;}
				end;
		  end; {case}
	 end; {main loop}

	 // Thats the end.  Now clean up.
  EndWriteThread:

	 LogDebugInfo( 'Write thread shutting down' );

	 PurgeComm(hCommFile, PURGE_TXABORT + PURGE_TXCLEAR);

	 CloseHandle(overlappedWrite.hEvent);
end; {TWriteThread.Execute}


//
//  FUNCTION: HandleWriteData(LPOVERLAPPED, LPCSTR, DWORD)
//
//  PURPOSE: Writes a given string to the comm file handle.
//
//  PARAMETERS:
//    lpOverlappedWrite      - Overlapped structure to use in WriteFile
//    pDataToWrite      - String to write.
//    dwNumberOfBytesToWrite - Length of String to write.
//
//  RETURN VALUE:
//    TRUE if all bytes were written.  False if there was a failure to
//    write the whole string.
//
//  COMMENTS:
//
//    This function is a helper function for the Write Thread.  It
//    is this call that actually writes a string to the comm file.
//    Note that this call blocks and waits for the Write to complete
//    or for the CloseEvent object to signal that the thread should end.
//    Another possible reason for returning FALSE is if the comm port
//    is closed by the service provider.
//
//
function TWriteThread.HandleWriteData( lpOverlappedWrite: POverlapped;
	 pDataToWrite: PChar; dwNumberOfBytesToWrite: DWORD): Boolean;
var
	dwLastError,

	dwNumberOfBytesWritten,
	dwWhereToStartWriting,

	dwHandleSignaled:	DWORD;
	HandlesToWaitFor: array[0..1] of THandle;
begin
	dwNumberOfBytesWritten := 0;
	dwWhereToStartWriting := 0; // Start at the beginning.

	HandlesToWaitFor[0] := hCloseEvent;
	HandlesToWaitFor[1] := lpOverlappedWrite^.hEvent;

	 // Keep looping until all characters have been written.
	 repeat
		  // Start the overlapped I/O.
		  if not WriteFile(hCommFile,
					 pDataToWrite[ dwWhereToStartWriting ],
					 dwNumberOfBytesToWrite, dwNumberOfBytesWritten,
					 lpOverlappedWrite) then
		  begin
				// WriteFile failed.  Expected; lets handle it.
				dwLastError := GetLastError;

				// Its possible for this error to occur if the
				// service provider has closed the port.  Time to end.
				if (dwLastError = ERROR_INVALID_HANDLE) then
				begin
					 LogDebugInfo( 'ERROR_INVALID_HANDLE, '+
						  'Likely that the Service Provider has closed the port.' );
					 Result := False;
					 Exit;
				end;

				// Unexpected error.  No idea what.
				if dwLastError <> ERROR_IO_PENDING then
				begin
					 LogDebugLastError( dwLastError, 'Error to writing to CommFile' );

					 LogDebugInfo( 'Closing TAPI' );
					 PostHangupCall;
					 Result := False;
					 Exit;
				end;

				// This is the expected ERROR_IO_PENDING case.


				// Wait for either overlapped I/O completion,
				// or for the CloseEvent to get signaled.
				dwHandleSignaled :=
					 WaitForMultipleObjects(2, @HandlesToWaitFor,
						  False, INFINITE);

				case dwHandleSignaled of
					 WAIT_OBJECT_0:     // CloseEvent signaled!
					 begin
						  // Time to exit.
						  Result := False;
						  Exit;
					 end;

					 WAIT_OBJECT_0 + 1: // Wait finished.
					 begin
						  // Time to get the results of the WriteFile
					 end;

					 WAIT_FAILED: // Wait failed.  Shouldn't happen.
					 begin
						  LogDebugLastError( GetLastError, 'Write WAIT_FAILED: ' );
						  PostHangupCall;
						  Result := False;
						  Exit
					 end;

					 else // This case should never occur.
					 begin
						  LogDebugInfo( PChar('Unexpected Wait return value '+
													IntToStr(dwHandleSignaled)) );
						  PostHangupCall;
						  Result := False;
						  Exit
					 end;
				end; {case}

				if not GetOverlappedResult(hCommFile,
							lpOverlappedWrite^,
							dwNumberOfBytesWritten, TRUE) then
				begin
					 dwLastError := GetLastError();

					 // Its possible for this error to occur if the
					 // service provider has closed the port.
					 if dwLastError = ERROR_INVALID_HANDLE then
					 begin
						  LogDebugInfo('ERROR_INVALID_HANDLE, '+
								'Likely that the Service Provider has closed the port.');
						  Result := False;
						  Exit;
					 end;

					 // No idea what could cause another error.
					 LogDebugLastError( dwLastError, 'Error writing to CommFile while waiting');
					 LogDebugInfo('Closing TAPI');
					 PostHangupCall;
					 Result := False;
					 Exit;
				end;
		  end; {WriteFile failure}

		  // Some data was written.  Make sure it all got written.

		  Dec( dwNumberOfBytesToWrite, dwNumberOfBytesWritten );
		  Inc( dwWhereToStartWriting, dwNumberOfBytesWritten );
	 until (dwNumberOfBytesToWrite <= 0);  // Write the whole thing!

	 // Wrote the whole string.
	 Result := True;
end; {TWriteThread.HandleWriteData}

function TWriteThread.WriteComm( pDataToWrite: LPCSTR; dwSizeofDataToWrite: DWORD ): Boolean;
begin
	Result := PostThreadMessage( ThreadID, PWM_COMMWRITE,
					 WParam(dwSizeofDataToWrite), LParam(pDataToWrite) );
end;

procedure TWriteThread.PostHangupCall;
begin
	PostMessage( hComm32Window, PWM_REQUESTHANGUP, 0, 0 );
end;

(******************************************************************************)
//											DEBUG ROUTINES
(******************************************************************************)

//
//  FUNCTION: LogDebugLastError(..)
//
//  PURPOSE: Pretty print a line error to the debugging output.
//
//  PARAMETERS:
//    dwLastError - Actual error code to decipher.
//    pszPrefix   - String to prepend to the printed message.
//
//  RETURN VALUE:
//    none
//
//  COMMENTS:
//
//    Note that there is an internal string length limit of
//    MAXOUTPUTSTRINGLENGTH.  If this length is exceeded,
//    the behavior will be the same as wsprintf, although
//    it will be undetectable.  *KEEP szPrefix SHORT!*
//
//
procedure LogDebugLastError( dwLastError: DWORD; szPrefix: LPSTR );
var
	szLastError: LPSTR;
	szOutputLastError: array[0..MAXOUTPUTSTRINGLENGTH-1] of Char;
begin
	if szPrefix = nil then
		szPrefix := '';

	// Pretty print the error.
	szLastError := FormatLastError(dwLastError, nil, 0);

	// The only reason FormatLastError should fail is "Out of memory".
	if szLastError = nil then
	begin
		wsprintf( szOutputLastError, PChar(szPrefix+'Out of memory') );

		LogDebugInfo( szOutputLastError );

		Exit;
	end;

	wsprintf( szOutputLastError,
			  PChar(szPrefix+'GetLastError returned: "'+szLastError+'"') );

	// Pointer returned from FormatLineError *must* be freed!
	LocalFree( HLOCAL(szLastError) );

	// Print it!
	LogDebugInfo( szOutputLastError );
end; {LogDebugLastError}

procedure LogDebugInfo( outstr: PChar );
begin
	if CommsLogName <> '' then
		Writeln( CommsLogFile, outstr );
end; {LogDebugInfo}

procedure Register;
begin
  RegisterComponents('Stamina', [TComm32]);
end;

end.