unit SPComm; // // 這是一個序列埠通訊元件, 供 Delphi 2.0 應用程式使用. 適合用來做工業控制及 // 簡單傳輸. 此元件呼叫 Win32 API 來達成所需功能, 請見Communications部份。 // // 此元件參考 David Wann. 所製作的 COMM32.PAS Version 1.0。原始說明如下： // 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 // davidwann@hunterlink.net.au // // // 這個元件完全免費, 歡迎拷貝' 修改或做任何其它用途. 除了單獨販賣此元件. // This component is totally free(copyleft), you can do anything in any // purpose EXCEPT SELL IT ALONE. // // // Author?: 小豬工作室 Small-Pig Team in Taiwan R.O.C. // Email : spigteam@vlsi.ice.cycu.edu.tw // Date ? : 1997/5/9 // // Version 1.01 1996/9/4 // - Add setting Parity, Databits, StopBits // - Add setting Flowcontrol:Dtr-Dsr, Cts-Rts, Xon-Xoff // - Add setting Timeout information for read/write // // Version 1.02 1996/12/24 // - Add Sender parameter to TReceiveDataEvent // // Version 2.0 1997/4/15 // - Support separatly DTR/DSR and RTS/CTS hardware flow control setting // - Support separatly OutX and InX software flow control setting // - Log file(for debug) may used by many comms at the same time // - Add DSR sensitivity property // - You can set error char. replacement when parity error // - Let XonLim/XoffLim and XonChar/XoffChar setting by yourself // - You may change flow-control when comm is still opened // - Change TComm32 to TComm // - Add OnReceiveError event handler // - Add OnReceiveError event handler when overrun, framing error, // parity error // - Fix some bug // // Version 2.01 1997/4/19 // - Support some property for modem // - Add OnModemStateChange event hander when RLSD(CD) change state // // Version 2.02 1997/4/28 // - Bug fix: When receive XOFF character, the system FAULT!!!! // // Version 2.5 1997/5/9 // - Add OnSendDataEmpty event handler when all data in buffer // are sent(send-buffer become empty) this handler is called. // You may call send data here. // - Change the ModemState parameters in OnModemStateChange // to ModemEvent to indicate what modem event make this call // - Add RING signal detect. When RLSD changed state or // RING signal was detected, OnModemStateChange handler is called // - Change XonLim and XoffLim from 100 to 500 // - Remove TWriteThread.WriteData member // - PostHangupCall is re-design for debuging function // - Add a boolean property SendDataEmpty, True when send buffer // is empty // interface uses Windows, Messages, SysUtils, Classes; const // messages from read/write threads PWM_GOTCOMMDATA = WM_USER + 1; PWM_RECEIVEERROR = WM_USER + 2; PWM_REQUESTHANGUP = WM_USER + 3; PWM_MODEMSTATECHANGE = WM_USER + 4; PWM_SENDDATAEMPTY = WM_USER + 5; type TParity = (None, Odd, Even, Mark, Space); TStopBits = (_1, _1_5, _2); TByteSize = (_5, _6, _7, _8); TDtrControl = (DtrEnable, DtrDisable, DtrHandshake); TRtsControl = (RtsEnable, RtsDisable, RtsHandshake, RtsTransmissionAvailable); ECommsError = class(Exception); TReceiveDataEvent = procedure(Sender: TObject; Buffer: Pointer; BufferLength: Word) of object; TReceiveErrorEvent = procedure(Sender: TObject; EventMask: DWORD) of object; TModemStateChangeEvent = procedure(Sender: TObject; ModemEvent: DWORD) of object; TSendDataEmptyEvent = procedure(Sender: TObject) of object; const // // Modem Event Constant // ME_CTS = 1; ME_DSR = 2; ME_RING = 4; ME_RLSD = 8; type 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; function ReceiveError(EvtMask: DWORD): BOOL; function ModemStateChange(ModemEvent: 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; pFSendDataEmpty: ^Boolean; procedure PostHangupCall; end; TComm = class(TComponent) private { Private declarations } ReadThread: TReadThread; WriteThread: TWriteThread; hCommFile: THandle; hCloseEvent: THandle; FHWnd: THandle; FSendDataEmpty: Boolean; // True if send buffer become empty FCommName: String; FBaudRate: DWORD; FParityCheck: Boolean; FOutx_CtsFlow: Boolean; FOutx_DsrFlow: Boolean; FDtrControl: TDtrControl; FDsrSensitivity: Boolean; FTxContinueOnXoff: Boolean; FOutx_XonXoffFlow: Boolean; FInx_XonXoffFlow: Boolean; FReplaceWhenParityError: Boolean; FIgnoreNullChar: Boolean; FRtsControl: TRtsControl; FXonLimit: Word; FXoffLimit: Word; FByteSize: TByteSize; FParity: TParity; FStopBits: TStopBits; FXonChar: AnsiChar; FXoffChar: AnsiChar; FReplacedChar: AnsiChar; FReadIntervalTimeout: DWORD; FReadTotalTimeoutMultiplier: DWORD; FReadTotalTimeoutConstant: DWORD; FWriteTotalTimeoutMultiplier: DWORD; FWriteTotalTimeoutConstant: DWORD; FOnReceiveData: TReceiveDataEvent; FOnRequestHangup: TNotifyEvent; FOnReceiveError: TReceiveErrorEvent; FOnModemStateChange: TModemStateChangeEvent; FOnSendDataEmpty: TSendDataEmptyEvent; procedure SetBaudRate(Rate: DWORD); procedure SetParityCheck(b: Boolean); procedure SetOutx_CtsFlow(b: Boolean); procedure SetOutx_DsrFlow(b: Boolean); procedure SetDtrControl(c: TDtrControl); procedure SetDsrSensitivity(b: Boolean); procedure SetTxContinueOnXoff(b: Boolean); procedure SetOutx_XonXoffFlow(b: Boolean); procedure SetInx_XonXoffFlow(b: Boolean); procedure SetReplaceWhenParityError(b: Boolean); procedure SetIgnoreNullChar(b: Boolean); procedure SetRtsControl(c: TRtsControl); procedure SetXonLimit(Limit: Word); procedure SetXoffLimit(Limit: Word); procedure SetByteSize(Size: TByteSize); procedure SetParity(p: TParity); procedure SetStopBits(Bits: TStopBits); procedure SetXonChar(c: AnsiChar); procedure SetXoffChar(c: AnsiChar); procedure SetReplacedChar(c: AnsiChar); procedure SetReadIntervalTimeout(v: DWORD); procedure SetReadTotalTimeoutMultiplier(v: DWORD); procedure SetReadTotalTimeoutConstant(v: DWORD); procedure SetWriteTotalTimeoutMultiplier(v: DWORD); procedure SetWriteTotalTimeoutConstant(v: DWORD); procedure CommWndProc(var msg: TMessage); procedure _SetCommState; procedure _SetCommTimeout; protected { Protected declarations } procedure ReceiveData(Buffer: PChar; BufferLength: Word); procedure CloseReadThread; procedure CloseWriteThread; procedure ReceiveError(EvtMask: DWORD); procedure ModemStateChange(ModemEvent: DWORD); procedure RequestHangup; procedure _SendDataEmpty; public { Public declarations } property Handle: THandle read hCommFile; property SendDataEmpty: Boolean read FSendDataEmpty; constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure StartComm; procedure StopComm; function WriteCommData(pDataToWrite: PAnsiChar; dwSizeofDataToWrite: Word): Boolean; function SendHex(sHexString:string):boolean; function GetModemState: DWORD; published { Published declarations } property CommName: String read FCommName write FCommName; property BaudRate: DWORD read FBaudRate write SetBaudRate; property ParityCheck: Boolean read FParityCheck write SetParityCheck; property Outx_CtsFlow: Boolean read FOutx_CtsFlow write SetOutx_CtsFlow; property Outx_DsrFlow: Boolean read FOutx_DsrFlow write SetOutx_DsrFlow; property DtrControl: TDtrControl read FDtrControl write SetDtrControl; property DsrSensitivity: Boolean read FDsrSensitivity write SetDsrSensitivity; property TxContinueOnXoff: Boolean read FTxContinueOnXoff write SetTxContinueOnXoff; property Outx_XonXoffFlow: Boolean read FOutx_XonXoffFlow write SetOutx_XonXoffFlow; property Inx_XonXoffFlow: Boolean read FInx_XonXoffFlow write SetInx_XonXoffFlow; property ReplaceWhenParityError: Boolean read FReplaceWhenParityError write SetReplaceWhenParityError; property IgnoreNullChar: Boolean read FIgnoreNullChar write SetIgnoreNullChar; property RtsControl: TRtsControl read FRtsControl write SetRtsControl; property XonLimit: Word read FXonLimit write SetXonLimit; property XoffLimit: Word read FXoffLimit write SetXoffLimit; property ByteSize: TByteSize read FByteSize write SetByteSize; property Parity: TParity read FParity write FParity; property StopBits: TStopBits read FStopBits write SetStopBits; property XonChar: AnsiChar read FXonChar write SetXonChar; property XoffChar: AnsiChar read FXoffChar write SetXoffChar; property ReplacedChar: AnsiChar read FReplacedChar write SetReplacedChar; property ReadIntervalTimeout: DWORD read FReadIntervalTimeout write SetReadIntervalTimeout; property ReadTotalTimeoutMultiplier: DWORD read FReadTotalTimeoutMultiplier write SetReadTotalTimeoutMultiplier; property ReadTotalTimeoutConstant: DWORD read FReadTotalTimeoutConstant write SetReadTotalTimeoutConstant; property WriteTotalTimeoutMultiplier: DWORD read FWriteTotalTimeoutMultiplier write SetWriteTotalTimeoutMultiplier; property WriteTotalTimeoutConstant: DWORD read FWriteTotalTimeoutConstant write SetWriteTotalTimeoutConstant; property OnReceiveData: TReceiveDataEvent read FOnReceiveData write FOnReceiveData; property OnReceiveError: TReceiveErrorEvent read FOnReceiveError write FOnReceiveError; property OnModemStateChange: TModemStateChangeEvent read FOnModemStateChange write FOnModemStateChange; property OnRequestHangup: TNotifyEvent read FOnRequestHangup write FOnRequestHangup; property OnSendDataEmpty: TSendDataEmptyEvent read FOnSendDataEmpty write FOnSendDataEmpty; 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; procedure Register; implementation (* **************************************************************************** *) // TComm PUBLIC METHODS (* **************************************************************************** *) constructor TComm.Create(AOwner: TComponent); begin inherited Create(AOwner); ReadThread := nil; WriteThread := nil; hCommFile := 0; hCloseEvent := 0; FSendDataEmpty := True; FCommName := 'COM2'; FBaudRate := 9600; FParityCheck := False; FOutx_CtsFlow := False; FOutx_DsrFlow := False; FDtrControl := DtrEnable; FDsrSensitivity := False; FTxContinueOnXoff := True; FOutx_XonXoffFlow := True; FInx_XonXoffFlow := True; FReplaceWhenParityError := False; FIgnoreNullChar := False; FRtsControl := RtsEnable; FXonLimit := 500; FXoffLimit := 500; FByteSize := _8; FParity := None; FStopBits := _1; FXonChar := chr($11); // Ctrl-Q FXoffChar := chr($13); // Ctrl-S FReplacedChar := chr(0); FReadIntervalTimeout := 100; FReadTotalTimeoutMultiplier := 0; FReadTotalTimeoutConstant := 0; FWriteTotalTimeoutMultiplier := 0; FWriteTotalTimeoutConstant := 0; if not(csDesigning in ComponentState) then FHWnd := AllocateHWnd(CommWndProc) end; destructor TComm.Destroy; begin if not(csDesigning in ComponentState) then DeallocateHWnd(FHWnd); 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. // // Output: // Successful: Startup the communications. // Failure: Raise a exception // // 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. // // procedure TComm.StartComm; var hNewCommFile: THandle; begin // Are we already doing comm? if (hCommFile <> 0) then raise ECommsError.Create('This serial port already opened'); hNewCommFile := CreateFile(PChar('\\.\' + FCommName), GENERIC_READ or GENERIC_WRITE, 0, { not shared } nil, { no security ?? } OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_OVERLAPPED, 0 { template } ); if hNewCommFile = INVALID_HANDLE_VALUE then raise ECommsError.Create('Error opening serial port'); // Is this a valid comm handle? if GetFileType(hNewCommFile) <> FILE_TYPE_CHAR then begin CloseHandle(hNewCommFile); raise ECommsError.Create('File handle is not a comm handle') end; if not SetupComm(hNewCommFile, 4096, 4096) then begin CloseHandle(hCommFile); raise ECommsError.Create('Cannot setup comm buffer') end; // It is ok to continue. hCommFile := hNewCommFile; // purge any information in the buffer PurgeComm(hCommFile, PURGE_TXABORT or PURGE_RXABORT or PURGE_TXCLEAR or PURGE_RXCLEAR); FSendDataEmpty := True; // Setting the time-out value _SetCommTimeout; // Querying then setting the comm port configurations. _SetCommState; // Create the event that will signal the threads to close. hCloseEvent := CreateEvent(nil, True, False, nil); if hCloseEvent = 0 then begin CloseHandle(hCommFile); hCommFile := 0; raise ECommsError.Create('Unable to create event') end; // Create the Read thread. try ReadThread := TReadThread.Create(True { suspended } ); except ReadThread := nil; CloseHandle(hCloseEvent); CloseHandle(hCommFile); hCommFile := 0; raise ECommsError.Create('Unable to create read thread') end; ReadThread.hCommFile := hCommFile; ReadThread.hCloseEvent := hCloseEvent; ReadThread.hComm32Window := FHWnd; // 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 CloseReadThread; WriteThread := nil; CloseHandle(hCloseEvent); CloseHandle(hCommFile); hCommFile := 0; raise ECommsError.Create('Unable to create write thread') end; WriteThread.hCommFile := hCommFile; WriteThread.hCloseEvent := hCloseEvent; WriteThread.hComm32Window := FHWnd; WriteThread.pFSendDataEmpty := @FSendDataEmpty; WriteThread.Priority := tpHigher; ReadThread.Resume; WriteThread.Resume // Everything was created ok. Ready to go! end; { TComm.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 TComm.StopComm; begin // No need to continue if we're not communicating. if hCommFile = 0 then Exit; // Close the threads. CloseReadThread; CloseWriteThread; // Not needed anymore. CloseHandle(hCloseEvent); // Now close the comm port handle. CloseHandle(hCommFile); hCommFile := 0 end; { TComm.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 TComm.SendHex(sHexString:string):boolean; var i:integer; buf:array[0..1024] of AnsiCHAR; begin for i:=0 to (length(sHexString) div 2-1) do buf[i]:=AnsiCHAR(strtoint('$'+copy(sHexString,i*2+1,2))); WriteCommData(buf,(length(sHexString) div 2)); end; function TComm.WriteCommData(pDataToWrite: PAnsiChar; dwSizeofDataToWrite: Word): Boolean; var Buffer: Pointer; begin if (WriteThread <> nil) and (dwSizeofDataToWrite <> 0) then begin Buffer := Pointer(LocalAlloc(LPTR, dwSizeofDataToWrite + 1)); Move(pDataToWrite^, Buffer^, dwSizeofDataToWrite); if PostThreadMessage(WriteThread.ThreadID, PWM_COMMWRITE, WPARAM(dwSizeofDataToWrite), LPARAM(Buffer)) then begin FSendDataEmpty := False; Result := True; Exit end end; Result := False end; { TComm.WriteCommData } // // FUNCTION: GetModemState // // PURPOSE: Read the state of modem input pin right now // // PARAMETERS: // none // // RETURN VALUE: // // A DWORD variable containing one or more of following codes: // // Value Meaning // ---------- ----------------------------------------------------------- // MS_CTS_ON The CTS (clear-to-send) signal is on. // MS_DSR_ON The DSR (data-set-ready) signal is on. // MS_RING_ON The ring indicator signal is on. // MS_RLSD_ON The RLSD (receive-line-signal-detect) signal is on. // // If this comm have bad handle or not yet opened, the return value is 0 // // COMMENTS: // // This member function calls GetCommModemStatus and return its value. // Before calling this member function, you must have a successful // 'StartOpen' call. // // function TComm.GetModemState: DWORD; var dwModemState: DWORD; begin if not GetCommModemStatus(hCommFile, dwModemState) then Result := 0 else Result := dwModemState end; (* **************************************************************************** *) // TComm 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 TComm.CloseReadThread; begin // If it exists... if ReadThread <> nil then begin // 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 ReadThread.Terminate; ReadThread.Free; ReadThread := nil end end; { TComm.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 TComm.CloseWriteThread; begin // If it exists... if WriteThread <> nil then begin // Signal the event to close the worker threads. SetEvent(hCloseEvent); // Purge all outstanding writes. PurgeComm(hCommFile, PURGE_TXABORT + PURGE_TXCLEAR); FSendDataEmpty := True; // Wait 10 seconds for it to exit. Shouldn't happen. if WaitForSingleObject(WriteThread.Handle, 10000) = WAIT_TIMEOUT then WriteThread.Terminate; WriteThread.Free; WriteThread := nil end end; { TComm.CloseWriteThread } procedure TComm.ReceiveData(Buffer: PChar; BufferLength: Word); begin if Assigned(FOnReceiveData) then FOnReceiveData(self, Buffer, BufferLength) end; procedure TComm.ReceiveError(EvtMask: DWORD); begin if Assigned(FOnReceiveError) then FOnReceiveError(self, EvtMask) end; procedure TComm.ModemStateChange(ModemEvent: DWORD); begin if Assigned(FOnModemStateChange) then FOnModemStateChange(self, ModemEvent) end; procedure TComm.RequestHangup; begin if Assigned(FOnRequestHangup) then FOnRequestHangup(self); StopComm; //add djw 20230224 end; procedure TComm._SendDataEmpty; begin if Assigned(FOnSendDataEmpty) then FOnSendDataEmpty(self) end; (* **************************************************************************** *) // TComm PRIVATE METHODS (* **************************************************************************** *) procedure TComm.CommWndProc(var msg: TMessage); begin case msg.msg of PWM_GOTCOMMDATA: begin ReceiveData(PChar(msg.LPARAM), msg.WPARAM); LocalFree(msg.LPARAM) end; PWM_RECEIVEERROR: ReceiveError(msg.LPARAM); PWM_MODEMSTATECHANGE: ModemStateChange(msg.LPARAM); PWM_REQUESTHANGUP: RequestHangup; PWM_SENDDATAEMPTY: _SendDataEmpty; end end; procedure TComm._SetCommState; var dcb: Tdcb; commprop: TCommProp; fdwEvtMask: DWORD; begin // 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(hCommFile, dcb); GetCommProperties(hCommFile, commprop); GetCommMask(hCommFile, fdwEvtMask); // 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; dcb.Flags := 1; // Enable fBinary if FParityCheck then dcb.Flags := dcb.Flags or 2; // Enable parity check // setup hardware flow control if FOutx_CtsFlow then dcb.Flags := dcb.Flags or 4; if FOutx_DsrFlow then dcb.Flags := dcb.Flags or 8; if FDtrControl = DtrEnable then dcb.Flags := dcb.Flags or $10 else if FDtrControl = DtrHandshake then dcb.Flags := dcb.Flags or $20; if FDsrSensitivity then dcb.Flags := dcb.Flags or $40; if FTxContinueOnXoff then dcb.Flags := dcb.Flags or $80; if FOutx_XonXoffFlow then dcb.Flags := dcb.Flags or $100; if FInx_XonXoffFlow then dcb.Flags := dcb.Flags or $200; if FReplaceWhenParityError then dcb.Flags := dcb.Flags or $400; if FIgnoreNullChar then dcb.Flags := dcb.Flags or $800; if FRtsControl = RtsEnable then dcb.Flags := dcb.Flags or $1000 else if FRtsControl = RtsHandshake then dcb.Flags := dcb.Flags or $2000 else if FRtsControl = RtsTransmissionAvailable then dcb.Flags := dcb.Flags or $3000; dcb.XonLim := FXonLimit; dcb.XoffLim := FXoffLimit; dcb.ByteSize := Ord(FByteSize) + 5; dcb.Parity := Ord(FParity); dcb.StopBits := Ord(FStopBits); dcb.XonChar := FXonChar; dcb.XoffChar := FXoffChar; dcb.ErrorChar := FReplacedChar; SetCommState(hCommFile, dcb) end; procedure TComm._SetCommTimeout; var commtimeouts: TCommTimeouts; begin 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 := FReadIntervalTimeout; commtimeouts.ReadTotalTimeoutMultiplier := FReadTotalTimeoutMultiplier; commtimeouts.ReadTotalTimeoutConstant := FReadTotalTimeoutConstant; commtimeouts.WriteTotalTimeoutMultiplier := FWriteTotalTimeoutMultiplier; commtimeouts.WriteTotalTimeoutConstant := FWriteTotalTimeoutConstant; SetCommTimeouts(hCommFile, commtimeouts); end; procedure TComm.SetBaudRate(Rate: DWORD); begin if Rate = FBaudRate then Exit; FBaudRate := Rate; if hCommFile <> 0 then _SetCommState end; procedure TComm.SetParityCheck(b: Boolean); begin if b = FParityCheck then Exit; FParityCheck := b; if hCommFile <> 0 then _SetCommState end; procedure TComm.SetOutx_CtsFlow(b: Boolean); begin if b = FOutx_CtsFlow then Exit; FOutx_CtsFlow := b; if hCommFile <> 0 then _SetCommState end; procedure TComm.SetOutx_DsrFlow(b: Boolean); begin if b = FOutx_DsrFlow then Exit; FOutx_DsrFlow := b; if hCommFile <> 0 then _SetCommState end; procedure TComm.SetDtrControl(c: TDtrControl); begin if c = FDtrControl then Exit; FDtrControl := c; if hCommFile <> 0 then _SetCommState end; procedure TComm.SetDsrSensitivity(b: Boolean); begin if b = FDsrSensitivity then Exit; FDsrSensitivity := b; if hCommFile <> 0 then _SetCommState end; procedure TComm.SetTxContinueOnXoff(b: Boolean); begin if b = FTxContinueOnXoff then Exit; FTxContinueOnXoff := b; if hCommFile <> 0 then _SetCommState end; procedure TComm.SetOutx_XonXoffFlow(b: Boolean); begin if b = FOutx_XonXoffFlow then Exit; FOutx_XonXoffFlow := b; if hCommFile <> 0 then _SetCommState end; procedure TComm.SetInx_XonXoffFlow(b: Boolean); begin if b = FInx_XonXoffFlow then Exit; FInx_XonXoffFlow := b; if hCommFile <> 0 then _SetCommState end; procedure TComm.SetReplaceWhenParityError(b: Boolean); begin if b = FReplaceWhenParityError then Exit; FReplaceWhenParityError := b; if hCommFile <> 0 then _SetCommState end; procedure TComm.SetIgnoreNullChar(b: Boolean); begin if b = FIgnoreNullChar then Exit; FIgnoreNullChar := b; if hCommFile <> 0 then _SetCommState end; procedure TComm.SetRtsControl(c: TRtsControl); begin if c = FRtsControl then Exit; FRtsControl := c; if hCommFile <> 0 then _SetCommState end; procedure TComm.SetXonLimit(Limit: Word); begin if Limit = FXonLimit then Exit; FXonLimit := Limit; if hCommFile <> 0 then _SetCommState end; procedure TComm.SetXoffLimit(Limit: Word); begin if Limit = FXoffLimit then Exit; FXoffLimit := Limit; if hCommFile <> 0 then _SetCommState end; procedure TComm.SetByteSize(Size: TByteSize); begin if Size = FByteSize then Exit; FByteSize := Size; if hCommFile <> 0 then _SetCommState end; procedure TComm.SetParity(p: TParity); begin if p = FParity then Exit; FParity := p; if hCommFile <> 0 then _SetCommState end; procedure TComm.SetStopBits(Bits: TStopBits); begin if Bits = FStopBits then Exit; FStopBits := Bits; if hCommFile <> 0 then _SetCommState end; procedure TComm.SetXonChar(c: AnsiChar); begin if c = FXonChar then Exit; FXonChar := c; if hCommFile <> 0 then _SetCommState end; procedure TComm.SetXoffChar(c: AnsiChar); begin if c = FXoffChar then Exit; FXoffChar := c; if hCommFile <> 0 then _SetCommState end; procedure TComm.SetReplacedChar(c: AnsiChar); begin if c = FReplacedChar then Exit; FReplacedChar := c; if hCommFile <> 0 then _SetCommState end; procedure TComm.SetReadIntervalTimeout(v: DWORD); begin if v = FReadIntervalTimeout then Exit; FReadIntervalTimeout := v; if hCommFile <> 0 then _SetCommTimeout end; procedure TComm.SetReadTotalTimeoutMultiplier(v: DWORD); begin if v = FReadTotalTimeoutMultiplier then Exit; FReadTotalTimeoutMultiplier := v; if hCommFile <> 0 then _SetCommTimeout end; procedure TComm.SetReadTotalTimeoutConstant(v: DWORD); begin if v = FReadTotalTimeoutConstant then Exit; FReadTotalTimeoutConstant := v; if hCommFile <> 0 then _SetCommTimeout end; procedure TComm.SetWriteTotalTimeoutMultiplier(v: DWORD); begin if v = FWriteTotalTimeoutMultiplier then Exit; FWriteTotalTimeoutMultiplier := v; if hCommFile <> 0 then _SetCommTimeout end; procedure TComm.SetWriteTotalTimeoutConstant(v: DWORD); begin if v = FWriteTotalTimeoutConstant then Exit; FWriteTotalTimeoutConstant := v; if hCommFile <> 0 then _SetCommTimeout end; (* **************************************************************************** *) // READ THREAD (* **************************************************************************** *) // // PROCEDURE: TReadThread.Execute // // PURPOSE: This is the starting point for the Read Thread. // // PARAMETERS: // None. // // RETURN VALUE: // None. // // COMMENTS: // // The Read Thread uses overlapped ReadFile and sends any data // read from the comm port to the Comm32Window. This is // eventually done through a PostMessage so that the Read Thread // is never away from the comm port very long. This also provides // natural desynchronization between the Read thread and the UI. // // If the CloseEvent object is signaled, the Read Thread exits. // // Separating the Read and Write threads is natural for a application // where there is no need for synchronization between // reading and writing. However, if there is such a need (for example, // most file transfer algorithms synchronize the reading and writing), // then it would make a lot more sense to have a single thread to handle // both reading and writing. // // procedure TReadThread.Execute; var szInputBuffer: array [0 .. INPUTBUFFERSIZE - 1] of AnsiChar; nNumberOfBytesRead: DWORD; HandlesToWaitFor: array [0 .. 2] of THandle; dwHandleSignaled: DWORD; fdwEvtMask: DWORD; // Needed for overlapped I/O (ReadFile) overlappedRead: TOverlapped; // Needed for overlapped Comm Event handling. overlappedCommEvent: TOverlapped; label EndReadThread; begin FillChar(overlappedRead, Sizeof(overlappedRead), 0); FillChar(overlappedCommEvent, Sizeof(overlappedCommEvent), 0); // Lets put an event in the Read overlapped structure. overlappedRead.hEvent := CreateEvent(nil, True, True, nil); if overlappedRead.hEvent = 0 then begin PostHangupCall; goto EndReadThread end; // And an event for the CommEvent overlapped structure. overlappedCommEvent.hEvent := CreateEvent(nil, True, True, nil); if overlappedCommEvent.hEvent = 0 then begin PostHangupCall(); goto EndReadThread end; // We will be waiting on these objects. HandlesToWaitFor[0] := hCloseEvent; HandlesToWaitFor[1] := overlappedCommEvent.hEvent; HandlesToWaitFor[2] := overlappedRead.hEvent; // Setup CommEvent handling. // Set the comm mask so we receive error signals. if not SetCommMask(hCommFile, EV_ERR or EV_RLSD or EV_RING) then begin PostHangupCall; goto EndReadThread end; // Start waiting for CommEvents (Errors) if not SetupCommEvent(@overlappedCommEvent, fdwEvtMask) then goto EndReadThread; // Start waiting for Read events. if not SetupReadEvent(@overlappedRead, szInputBuffer, INPUTBUFFERSIZE, nNumberOfBytesRead) then goto EndReadThread; // Keep looping until we break out. while True do begin // Wait until some event occurs (data to read; error; stopping). dwHandleSignaled := WaitForMultipleObjects(3, @HandlesToWaitFor, False, INFINITE); // Which event occured? case dwHandleSignaled of WAIT_OBJECT_0: // Signal to end the thread. begin // Time to exit. goto EndReadThread end; WAIT_OBJECT_0 + 1: // CommEvent signaled. begin // Handle the CommEvent. if not HandleCommEvent(@overlappedCommEvent, fdwEvtMask, True) then goto EndReadThread; // Start waiting for the next CommEvent. if not SetupCommEvent(@overlappedCommEvent, fdwEvtMask) then goto EndReadThread { break;?? } end; WAIT_OBJECT_0 + 2: // Read Event signaled. begin // Get the new data! if not HandleReadEvent(@overlappedRead, szInputBuffer, INPUTBUFFERSIZE, nNumberOfBytesRead) then goto EndReadThread; // Wait for more new data. if not SetupReadEvent(@overlappedRead, szInputBuffer, INPUTBUFFERSIZE, nNumberOfBytesRead) then goto EndReadThread { break; } end; WAIT_FAILED: // Wait failed. Shouldn't happen. begin PostHangupCall; goto EndReadThread end else // This case should never occur. begin PostHangupCall; goto EndReadThread end end { case dwHandleSignaled } end; { while True } // Time to clean up Read Thread. EndReadThread: PurgeComm(hCommFile, PURGE_RXABORT + PURGE_RXCLEAR); CloseHandle(overlappedRead.hEvent); CloseHandle(overlappedCommEvent.hEvent) end; { TReadThread.Execute } // // FUNCTION: SetupReadEvent(LPOVERLAPPED, LPSTR, DWORD, LPDWORD) // // PURPOSE: Sets up an overlapped ReadFile // // PARAMETERS: // lpOverlappedRead - address of overlapped structure to use. // lpszInputBuffer - Buffer to place incoming bytes. // dwSizeofBuffer - size of lpszInputBuffer. // lpnNumberOfBytesRead - address of DWORD to place the number of read bytes. // // RETURN VALUE: // TRUE if able to successfully setup the ReadFile. FALSE if there // was a failure setting up or if the CloseEvent object was signaled. // // COMMENTS: // // This function is a helper function for the Read Thread. This // function sets up the overlapped ReadFile so that it can later // be waited on (or more appropriatly, so the event in the overlapped // structure can be waited upon). If there is data waiting, it is // handled and the next ReadFile is initiated. // Another possible reason for returning FALSE is if the comm port // is closed by the service provider. // // // function TReadThread.SetupReadEvent(lpOverlappedRead: POverlapped; lpszInputBuffer: LPSTR; dwSizeofBuffer: DWORD; var lpnNumberOfBytesRead: DWORD): Boolean; var dwLastError: DWORD; label StartSetupReadEvent; begin Result := False; StartSetupReadEvent: // Make sure the CloseEvent hasn't been signaled yet. // Check is needed because this function is potentially recursive. if WAIT_TIMEOUT <> WaitForSingleObject(hCloseEvent, 0) then Exit; // Start the overlapped ReadFile. if ReadFile(hCommFile, lpszInputBuffer^, dwSizeofBuffer, lpnNumberOfBytesRead, lpOverlappedRead) then begin // This would only happen if there was data waiting to be read. // Handle the data. if not HandleReadData(lpszInputBuffer, lpnNumberOfBytesRead) then Exit; // Start waiting for more data. goto StartSetupReadEvent end; // ReadFile failed. Expected because of overlapped I/O. dwLastError := GetLastError; // LastError was ERROR_IO_PENDING, as expected. if dwLastError = ERROR_IO_PENDING then begin Result := True; Exit end; // Its possible for this error to occur if the // service provider has closed the port. Time to end. if dwLastError = ERROR_INVALID_HANDLE then Exit; // Unexpected error come here. No idea what could cause this to happen. PostHangupCall end; { TReadThread.SetupReadEvent } // // FUNCTION: HandleReadData(LPCSTR, DWORD) // // PURPOSE: Deals with data after its been read from the comm file. // // PARAMETERS: // lpszInputBuffer - Buffer to place incoming bytes. // dwSizeofBuffer - size of lpszInputBuffer. // // RETURN VALUE: // TRUE if able to successfully handle the data. // FALSE if unable to allocate memory or handle the data. // // COMMENTS: // // This function is yet another helper function for the Read Thread. // It LocalAlloc()s a buffer, copies the new data to this buffer and // calls PostWriteToDisplayCtl to let the EditCtls module deal with // the data. Its assumed that PostWriteToDisplayCtl posts the message // rather than dealing with it right away so that the Read Thread // is free to get right back to waiting for data. Its also assumed // that the EditCtls module is responsible for LocalFree()ing the // pointer that is passed on. // // function TReadThread.HandleReadData(lpszInputBuffer: LPCSTR; dwSizeofBuffer: DWORD): Boolean; var lpszPostedBytes: LPSTR; begin Result := False; // If we got data and didn't just time out empty... if dwSizeofBuffer <> 0 then begin // Do something with the bytes read. lpszPostedBytes := PAnsiChar(LocalAlloc(LPTR, dwSizeofBuffer + 1)); if lpszPostedBytes = nil { NULL } then begin // Out of memory PostHangupCall; Exit end; Move(lpszInputBuffer^, lpszPostedBytes^, dwSizeofBuffer); lpszPostedBytes[dwSizeofBuffer] := #0; Result := ReceiveData(lpszPostedBytes, dwSizeofBuffer) end end; { TReadThread.HandleReadData } // // FUNCTION: HandleReadEvent(LPOVERLAPPED, LPSTR, DWORD, LPDWORD) // // PURPOSE: Retrieves and handles data when there is data ready. // // PARAMETERS: // lpOverlappedRead - address of overlapped structure to use. // lpszInputBuffer - Buffer to place incoming bytes. // dwSizeofBuffer - size of lpszInputBuffer. // lpnNumberOfBytesRead - address of DWORD to place the number of read bytes. // // RETURN VALUE: // TRUE if able to successfully retrieve and handle the available data. // FALSE if unable to retrieve or handle the data. // // COMMENTS: // // This function is another helper function for the Read Thread. This // is the function that is called when there is data available after // an overlapped ReadFile has been setup. It retrieves the data and // handles it. // // function TReadThread.HandleReadEvent(lpOverlappedRead: POverlapped; lpszInputBuffer: LPSTR; dwSizeofBuffer: DWORD; var lpnNumberOfBytesRead: DWORD): Boolean; var dwLastError: DWORD; begin Result := False; if GetOverlappedResult(hCommFile, lpOverlappedRead^, lpnNumberOfBytesRead, False) then begin Result := HandleReadData(lpszInputBuffer, lpnNumberOfBytesRead); Exit end; // Error in GetOverlappedResult; 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 Exit; // Unexpected error come here. No idea what could cause this to happen. PostHangupCall end; { TReadThread.HandleReadEvent } // // FUNCTION: SetupCommEvent(LPOVERLAPPED, LPDWORD) // // PURPOSE: Sets up the overlapped WaitCommEvent call. // // PARAMETERS: // lpOverlappedCommEvent - Pointer to the overlapped structure to use. // lpfdwEvtMask - Pointer to DWORD to received Event data. // // RETURN VALUE: // TRUE if able to successfully setup the WaitCommEvent. // FALSE if unable to setup WaitCommEvent, unable to handle // an existing outstanding event or if the CloseEvent has been signaled. // // COMMENTS: // // This function is a helper function for the Read Thread that sets up // the WaitCommEvent so we can deal with comm events (like Comm errors) // if they occur. // // function TReadThread.SetupCommEvent(lpOverlappedCommEvent: POverlapped; var lpfdwEvtMask: DWORD): Boolean; var dwLastError: DWORD; label StartSetupCommEvent; begin Result := False; StartSetupCommEvent: // Make sure the CloseEvent hasn't been signaled yet. // Check is needed because this function is potentially recursive. if WAIT_TIMEOUT <> WaitForSingleObject(hCloseEvent, 0) then Exit; // Start waiting for Comm Errors. if WaitCommEvent(hCommFile, lpfdwEvtMask, lpOverlappedCommEvent) then begin // This could happen if there was an error waiting on the // comm port. Lets try and handle it. if not HandleCommEvent(nil, lpfdwEvtMask, False) then begin { ??? GetOverlappedResult does not handle "NIL" as defined by Borland } Exit end; // What could cause infinite recursion at this point? goto StartSetupCommEvent end; // We expect ERROR_IO_PENDING returned from WaitCommEvent // because we are waiting with an overlapped structure. dwLastError := GetLastError; // LastError was ERROR_IO_PENDING, as expected. if dwLastError = ERROR_IO_PENDING then begin Result := True; Exit end; // Its possible for this error to occur if the // service provider has closed the port. Time to end. if dwLastError = ERROR_INVALID_HANDLE then Exit; // Unexpected error. No idea what could cause this to happen. PostHangupCall end; { TReadThread.SetupCommEvent } // // FUNCTION: HandleCommEvent(LPOVERLAPPED, LPDWORD, BOOL) // // PURPOSE: Handle an outstanding Comm Event. // // PARAMETERS: // lpOverlappedCommEvent - Pointer to the overlapped structure to use. // lpfdwEvtMask - Pointer to DWORD to received Event data. // fRetrieveEvent - Flag to signal if the event needs to be // retrieved, or has already been retrieved. // // RETURN VALUE: // TRUE if able to handle a Comm Event. // FALSE if unable to setup WaitCommEvent, unable to handle // an existing outstanding event or if the CloseEvent has been signaled. // // COMMENTS: // // 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; dwErrors: DWORD; dwLastError: DWORD; dwModemEvent: DWORD; begin Result := False; // 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 begin 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 Exit; PostHangupCall; Exit end 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 Exit; PostHangupCall; 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 not ReceiveError(dwErrors) then Exit; Result := True end; dwModemEvent := 0; if ((lpfdwEvtMask and EV_RLSD) <> 0) then dwModemEvent := ME_RLSD; if ((lpfdwEvtMask and EV_RING) <> 0) then dwModemEvent := dwModemEvent or ME_RING; if dwModemEvent <> 0 then begin if not ModemStateChange(dwModemEvent) then begin Result := False; Exit end; Result := True end; if ((lpfdwEvtMask and EV_ERR) = 0) and (dwModemEvent = 0) then begin // Should not have gotten here. PostHangupCall end end; { TReadThread.HandleCommEvent } function TReadThread.ReceiveData(lpNewString: LPSTR; dwSizeofNewString: DWORD): BOOL; begin Result := False; if not PostMessage(hComm32Window, PWM_GOTCOMMDATA, WPARAM(dwSizeofNewString), LPARAM(lpNewString)) then PostHangupCall else Result := True end; function TReadThread.ReceiveError(EvtMask: DWORD): BOOL; begin Result := False; if not PostMessage(hComm32Window, PWM_RECEIVEERROR, 0, LPARAM(EvtMask)) then PostHangupCall else Result := True end; function TReadThread.ModemStateChange(ModemEvent: DWORD): BOOL; begin Result := False; if not PostMessage(hComm32Window, PWM_MODEMSTATECHANGE, 0, LPARAM(ModemEvent)) then PostHangupCall else Result := True 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; CompleteOneWriteRequire: Boolean; 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 PostHangupCall; goto EndWriteThread end; CompleteOneWriteRequire := True; // 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. pFSendDataEmpty^ := True; if CompleteOneWriteRequire then begin if not PostMessage(hComm32Window, PWM_SENDDATAEMPTY, 0, 0) then begin PostHangupCall; goto EndWriteThread end end; CompleteOneWriteRequire := False; 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 PostHangupCall; goto EndWriteThread end else // This case should never occur. begin 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 // 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; CompleteOneWriteRequire := True; // Data was sent in a LocalAlloc()d buffer. Must free it. LocalFree(HLOCAL(msg.LPARAM)) end end end; { main loop } // Thats the end. Now clean up. EndWriteThread: PurgeComm(hCommFile, PURGE_TXABORT + PURGE_TXCLEAR); pFSendDataEmpty^ := True; 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 Result := False; 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 Exit; // Unexpected error. No idea what. if dwLastError <> ERROR_IO_PENDING then begin PostHangupCall; 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. Exit end; WAIT_OBJECT_0 + 1: // Wait finished. begin // Time to get the results of the WriteFile 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 Exit; // No idea what could cause another error. PostHangupCall; Exit end end; WAIT_FAILED: // Wait failed. Shouldn't happen. begin PostHangupCall; Exit end else // This case should never occur. begin PostHangupCall; Exit end end { case } 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 } procedure TWriteThread.PostHangupCall; begin PostMessage(hComm32Window, PWM_REQUESTHANGUP, 0, 0) end; procedure Register; begin RegisterComponents('System', [TComm]) end; end.