mycomm32.pas

windows 下的多线程串口通讯组件。纯delphi源代码

      		 lpOverlappedCommEvent^, dwDummy, False ) then
	    begin
	      dwLastError := GetLastError;
  	    if dwLastError = ERROR_INVALID_HANDLE then
	        begin
		        LogDebugInfo( 'ERROR_INVALID_HANDLE, '+
		            'Likely closed the port.' );
            LocalFree(HLOCAL(lpszOutput));
		        Exit;
          end;
        LogDebugInfo('Unexpected GetOverlappedResult for WaitCommEvent');
        LocalFree(HLOCAL(lpszOutput));
	      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;
    	    if dwLastError = ERROR_INVALID_HANDLE then
	          begin
		          LogDebugInfo( 'ERROR_INVALID_HANDLE, '+
          		    'Likely closed the port.' );
              LocalFree(HLOCAL(lpszOutput));
              Exit;
            end;
	        LogDebugInfo('ClearCommError: ' );
          LocalFree(HLOCAL(lpszOutput));
	        Exit;
        end;
	    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 );
      LocalFree(HLOCAL(lpszOutput));
  	  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(hMyComportWindow, PWM_GOTCOMMDATA,
  	  WPARAM(dwSizeofNewString), LPARAM(lpNewString) );
end;


(************************************************************)
//  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
	    LogDebugInfo('Unable to Create overlappedWrite Event: ');
	    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
		            LogDebugInfo('Write WAIT_FAILED: ' );
		            goto EndWriteThread;
              end;
          else                // This case should never occur.
		        begin
		          LogDebugInfo( PChar('Unexpected Wait return value '
				            +IntToStr(dwHandleSignaled)) );
		          goto EndWriteThread;
            end;
          end;  //End Case
        end;  //Peek A Message! Handle It.
      // Make sure the CloseEvent isn't signaled while retrieving messages.
      if WAIT_TIMEOUT <> WaitForSingleObject(hCloseEvent,0) then
	      goto EndWriteThread;
      // Process the message.
      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(Pchar(TimetoStr(Time)+ ' Writing to comm port'));
		        if not HandleWriteData( @overlappedWrite,
			              PChar(msg.lParam), DWORD(msg.wParam) ) then
		          begin
		            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; {End msg case}
    end; {main loop}
  // Thats the end.  Now clean up.
EndWriteThread:
  LogDebugInfo(Pchar(TimetoStr(Time)+' Write thread shutting down'));
  PurgeComm(hCommFile, PURGE_TXABORT + PURGE_TXCLEAR);
  CloseHandle(overlappedWrite.hEvent);
end; {TWriteThread.Execute}

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 closed the port.' );
	          Result := False;
	          Exit;
          end;
        // Unexpected error.  No idea what.
	      if dwLastError <> ERROR_IO_PENDING then
	        begin
	          LogDebugInfo('Error to writing to CommFile');
	          LogDebugInfo( 'Closing TAPI' );
	          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
		          LogDebugInfo('Write WAIT_FAILED: ' );
		          Result := False;
		          Exit;
            end;
        else // This case should never occur.
	        begin
		        LogDebugInfo( PChar('Unexpected Wait return value '+
		    		    IntToStr(dwHandleSignaled)));
		        Result := False;
		        Exit;
          end;
        end; {End case}
	      if not GetOverlappedResult(hCommFile,lpOverlappedWrite^,
	                      dwNumberOfBytesWritten, TRUE) then
          begin
	          dwLastError := GetLastError();
  	        if dwLastError = ERROR_INVALID_HANDLE then
	            begin
		            LogDebugInfo('ERROR_INVALID_HANDLE, '+
          		      'Likely  closed the port.');
		            Result := False;
		            Exit;
              end;
              // No idea what could cause another error.
	          LogDebugInfo('Error writing to CommFile while waiting');
	          LogDebugInfo('Closing TAPI');
	          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;
  LogDebugInfo(Pchar(TimetoStr(Time)+' Write OK:'+pDataToWrite));
  sleep(50);
end; {TWriteThread.HandleWriteData}

function TWriteThread.WriteComm( pDataToWrite: LPCSTR; dwSizeofDataToWrite: DWORD ): Boolean;
begin
  Result:= PostThreadMessage( ThreadID, PWM_COMMWRITE,
  		 WParam(dwSizeofDataToWrite), LParam(pDataToWrite) );
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}

function MAKELANGID( usPrimaryLanguage, usSubLanguage: Byte ): WORD;
begin
  Result := ((usSubLanguage shl 10) + usPrimaryLanguage);
end;

//  FUNCTION: FormatLastError(DWORD, LPSTR, DWORD)
//  PURPOSE: Pretty print a system error to a string.
//  PARAMETERS:
//    dwLastError          - Actual error code to decipher.
//    szOutputBuffer       - String buffer to pretty print to.
//    dwSizeofOutputBuffer - Size of String buffer.
//  RETURN VALUE:
//    Returns the buffer printed to.
//  COMMENTS:
//    If szOutputBuffer isn't big enough to hold the whole string,
//    then the string gets truncated to fit the buffer.
//    If szOutputBuffer == NULL, then dwSizeofOutputBuffer
//    is ignored, a buffer 'big enough' is LocalAlloc()d and
//    a pointer to it is returned.  However, its *very* important
//    that this pointer be LocalFree()d by the calling application.
function FormatLastError( dwLastError: DWORD;
	 szOutputBuffer: PChar; dwSizeofOutputBuffer: DWORD ): PChar;
var
	dwRetFM,
	dwFlags: 		DWORD;
	dwGetLastError: 	DWORD;
	szFormatMessageError:	LPSTR;
begin
//   Result:=nil;
//   Exit;

   dwFlags := FORMAT_MESSAGE_FROM_SYSTEM;
   // Should we allocate a buffer?
   if szOutputBuffer = nil then
      begin
	 // Actually, we make FormatMessage allocate the buffer, if needed.
	 dwFlags := dwFlags + FORMAT_MESSAGE_ALLOCATE_BUFFER;
	 // minimum size FormatMessage should allocate.
	 dwSizeofOutputBuffer := 1;
      end;
   // Make FormatMessage pretty print the system error.
   dwRetFM := FormatMessage(
   	  dwFlags, nil, dwLastError,
   	  MAKELANGID(LANG_ENGLISH, SUBLANG_ENGLISH_US),
   	  PAnsiChar(@szOutputBuffer), dwSizeofOutputBuffer,
   	  nil);
   // FormatMessage failed to print the error.
   if dwRetFM = 0 then
      begin
	 dwGetLastError := GetLastError;
	 // If we asked FormatMessage to allocate a buffer, then it
	 // might have allocated one.  Lets be safe and LocalFree it.
	 if (dwFlags and FORMAT_MESSAGE_ALLOCATE_BUFFER) <> 0 then
	   begin
	      LocalFree(HLOCAL(szOutputBuffer));
	      szOutputBuffer:= PChar(LocalAlloc(LPTR, MAXOUTPUTSTRINGLENGTH ));
	      {	dwSizeofOutputBuffer := MAXOUTPUTSTRINGLENGTH;}
	      if szOutputBuffer = nil then
	        begin
		   OutputDebugString('Out of memory trying to FormatLastError' );
		   result := nil;
		   Exit;
                end;
           end;
         szFormatMessageError := PChar(IntToStr(dwGetLastError));
         {FormatLastError( dwGetLastError, nil, 0 );}
	 if szFormatMessageError = nil then
	    begin
	       Result := nil;
	       Exit;
            end;
         wsprintf(szOutputBuffer,
	     PChar('FormatMessage failed on error '+IntToStr(dwLastError)+
             ' for the following reason: '+
	     szFormatMessageError) );
         LocalFree( HLOCAL(szFormatMessageError) );
      end;
   Result := szOutputBuffer;
end;

procedure Register;
begin
  RegisterComponents('Wuzhihui', [TMyComport]);
end;

end.