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 // [email protected] // // // 硂じンЧ禣, 舧ī' э┪暗ヴㄤウノ硚. 埃虫縒砪芥じン. // 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 : [email protected] // 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 //interfaceuses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;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 CloseReadThread; procedure CloseWriteThread; procedure ReceiveData(Buffer: PChar; BufferLength: Word); 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: PChar; dwSizeofDataToWrite: Word): 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 SetParity; //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.WriteCommData(pDataToWrite: PChar; 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) 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 Char; 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 := PChar(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.
unit PDV_FD8CUnit;interfaceuses SysUtils, Classes, ComControlUnit, Spcomm;type TCaretsPos = 1 .. 8; TWelcomeStyle = 0 .. 3; TLineStyle = 0 .. 2; TWordStyle = 0 .. 4; TCodeStyle = 0 .. 5;type TPDV_FD8C = class(TComControl) private FLight: Boolean; FCaretsPos: Integer; FNumber: Real; FCodeStyle: TCodeStyle; FLineStyle: TLineStyle; FWelcomeStyle: TWelcomeStyle; FWordStyle: TWordStyle; FPosSystem: Boolean; procedure SetCodeStyle(const Value: TCodeStyle); procedure SetCaretsPos(const Value: Integer); procedure SetCaretsStyle(const Value: Boolean); procedure SetLineStyle(const Value: TLineStyle); procedure SetNumber(const Value: Real); procedure SetWelcomeStyle(const Value: TWelcomeStyle); procedure SetWordStyle(const Value: TWordStyle); procedure SetPosSystem(const Value: Boolean); public function Clear: Boolean; { 清屏命令 } function Can: Boolean; { 清除光标行命令 } function Init: Boolean; { 初始化命令 } function ShowNumber(mNumber: Real): Boolean; { 送显示数据命令 } function ShowCarets(mLight: Boolean): Boolean; { 设置光标状态命令 } function CaretsMove(mCaretsPos: TCaretsPos): Boolean; { 移动光位置 } function ShowNote(mWelcomeStyle: TWelcomeStyle; mLineStyle: TLineStyle): Boolean; { 控制"多谢惠顾" "动态线" } function ShowWord(mWordStyle: TWordStyle): Boolean; { 设置"收款"、"单价"、"总计"、"找零"字符显示状态 } function ShowPosSystem(mShow: Boolean): Boolean; { 设置"POS SYSTEM"字符显示状态命令 } function ShowCodeStyle(mCodeStyle: TCodeStyle): Boolean; { 设置 "￥"、"$"、"￡" 字符显示状态命令 } /////// property Number: Real read FNumber write SetNumber; property Light: Boolean read FLight write SetCaretsStyle; property CaretsPos: Integer read FCaretsPos write SetCaretsPos; property WelcomeStyle: TWelcomeStyle read FWelcomeStyle write SetWelcomeStyle; property LineStyle: TLineStyle read FLineStyle write SetLineStyle; property WordStyle: TWordStyle read FWordStyle write SetWordStyle; property PosSystem: Boolean read FPosSystem write SetPosSystem; property CodeStyle: TCodeStyle read FCodeStyle write SetCodeStyle; end;implementation{ TPDV_FD8C }const cCommand_Cls = #$0C; cCommand_Can = #$18; cCommand_Init = #$1B#$40; cCommand_SendNumber = #$1B#$51#$41'%.2f'#$0D; cCommand_CaretsStyle = #$1B#$5F'%d'; cCommand_CaretsMove = #$1B#$6C'%d'; cCommand_ShowNote = #$1F#$5F'%d%d'; cCommand_ShowWord = #$1B#$73'%d'; cCommand_ShowPosSystem = #$1f#$50'%d'; cCommand_ShowCodeStyle = #$1F#$73'%d';function TPDV_FD8C.Can: Boolean; begin Result := SendStr(cCommand_Can); end;function TPDV_FD8C.Clear: Boolean; begin Result := SendStr(cCommand_Cls); end;function TPDV_FD8C.CaretsMove(mCaretsPos: TCaretsPos): Boolean; begin Result := SendStr(Format(cCommand_CaretsMove, [mCaretsPos])); end;function TPDV_FD8C.ShowCarets(mLight: Boolean): Boolean; begin Result := SendStr(Format(cCommand_CaretsStyle, [Ord(mLight)])); end;function TPDV_FD8C.Init: Boolean; begin Result := SendStr(cCommand_Init); end;function TPDV_FD8C.ShowNumber(mNumber: Real): Boolean; begin Result := SendStr(Format(cCommand_SendNumber, [mNumber])); end;procedure TPDV_FD8C.SetCodeStyle(const Value: TCodeStyle); begin FCodeStyle := Value; if Active then ShowCodeStyle(FCodeStyle); end;procedure TPDV_FD8C.SetCaretsPos(const Value: Integer); begin FCaretsPos := Value; if Active then CaretsMove(FCaretsPos); end;procedure TPDV_FD8C.SetCaretsStyle(const Value: Boolean); begin FLight := Value; if Active then ShowCarets(FLight); end;procedure TPDV_FD8C.SetLineStyle(const Value: TLineStyle); begin FLineStyle := Value; if Active then ShowNote(FWelcomeStyle, FLineStyle); end;procedure TPDV_FD8C.SetNumber(const Value: Real); begin FNumber := Value; if Active then ShowNumber(FNumber); end;procedure TPDV_FD8C.SetWelcomeStyle(const Value: TWelcomeStyle); begin FWelcomeStyle := Value; if Active then ShowNote(FWelcomeStyle, FLineStyle); end;procedure TPDV_FD8C.SetWordStyle(const Value: TWordStyle); begin FWordStyle := Value; if Active then ShowWord(FWordStyle); end;function TPDV_FD8C.ShowCodeStyle(mCodeStyle: TCodeStyle): Boolean; begin Result := SendStr(Format(cCommand_ShowCodeStyle, [mCodeStyle])); end;function TPDV_FD8C.ShowNote(mWelcomeStyle: TWelcomeStyle; mLineStyle: TLineStyle): Boolean; begin Result := SendStr(Format(cCommand_ShowNote, [mWelcomeStyle, mLineStyle])); end;function TPDV_FD8C.ShowPosSystem(mShow: Boolean): Boolean; begin Result := SendStr(Format(cCommand_ShowPosSystem, [Ord(mShow)])); end;function TPDV_FD8C.ShowWord(mWordStyle: TWordStyle): Boolean; begin Result := SendStr(Format(cCommand_ShowWord, [mWordStyle])); end;procedure TPDV_FD8C.SetPosSystem(const Value: Boolean); begin FPosSystem := Value; if Active then ShowPosSystem(FPosSystem); end;end.
[email protected]
//
// 硂琌梆硄癟じン, ㄑ 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
// [email protected]
//
//
// 硂じンЧ禣, 舧ī' э┪暗ヴㄤウノ硚. 埃虫縒砪芥じン.
// 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 : [email protected]
// 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
//interfaceuses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;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 CloseReadThread;
procedure CloseWriteThread;
procedure ReceiveData(Buffer: PChar; BufferLength: Word);
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: PChar; dwSizeofDataToWrite: Word): 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 SetParity; //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.WriteCommData(pDataToWrite: PChar; 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)
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 Char;
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 := PChar(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.
SysUtils, Classes, ComControlUnit, Spcomm;type
TCaretsPos = 1 .. 8;
TWelcomeStyle = 0 .. 3;
TLineStyle = 0 .. 2;
TWordStyle = 0 .. 4;
TCodeStyle = 0 .. 5;type
TPDV_FD8C = class(TComControl)
private
FLight: Boolean;
FCaretsPos: Integer;
FNumber: Real;
FCodeStyle: TCodeStyle;
FLineStyle: TLineStyle;
FWelcomeStyle: TWelcomeStyle;
FWordStyle: TWordStyle;
FPosSystem: Boolean;
procedure SetCodeStyle(const Value: TCodeStyle);
procedure SetCaretsPos(const Value: Integer);
procedure SetCaretsStyle(const Value: Boolean);
procedure SetLineStyle(const Value: TLineStyle);
procedure SetNumber(const Value: Real);
procedure SetWelcomeStyle(const Value: TWelcomeStyle);
procedure SetWordStyle(const Value: TWordStyle);
procedure SetPosSystem(const Value: Boolean);
public
function Clear: Boolean; { 清屏命令 }
function Can: Boolean; { 清除光标行命令 }
function Init: Boolean; { 初始化命令 }
function ShowNumber(mNumber: Real): Boolean; { 送显示数据命令 }
function ShowCarets(mLight: Boolean): Boolean; { 设置光标状态命令 }
function CaretsMove(mCaretsPos: TCaretsPos): Boolean; { 移动光位置 }
function ShowNote(mWelcomeStyle: TWelcomeStyle; mLineStyle: TLineStyle): Boolean; { 控制"多谢惠顾" "动态线" }
function ShowWord(mWordStyle: TWordStyle): Boolean; { 设置"收款"、"单价"、"总计"、"找零"字符显示状态 }
function ShowPosSystem(mShow: Boolean): Boolean; { 设置"POS SYSTEM"字符显示状态命令 }
function ShowCodeStyle(mCodeStyle: TCodeStyle): Boolean; { 设置 "￥"、"$"、"￡" 字符显示状态命令 }
///////
property Number: Real read FNumber write SetNumber;
property Light: Boolean read FLight write SetCaretsStyle;
property CaretsPos: Integer read FCaretsPos write SetCaretsPos;
property WelcomeStyle: TWelcomeStyle read FWelcomeStyle write SetWelcomeStyle;
property LineStyle: TLineStyle read FLineStyle write SetLineStyle;
property WordStyle: TWordStyle read FWordStyle write SetWordStyle;
property PosSystem: Boolean read FPosSystem write SetPosSystem;
property CodeStyle: TCodeStyle read FCodeStyle write SetCodeStyle;
end;implementation{ TPDV_FD8C }const
cCommand_Cls = #$0C;
cCommand_Can = #$18;
cCommand_Init = #$1B#$40;
cCommand_SendNumber = #$1B#$51#$41'%.2f'#$0D;
cCommand_CaretsStyle = #$1B#$5F'%d';
cCommand_CaretsMove = #$1B#$6C'%d';
cCommand_ShowNote = #$1F#$5F'%d%d';
cCommand_ShowWord = #$1B#$73'%d';
cCommand_ShowPosSystem = #$1f#$50'%d';
cCommand_ShowCodeStyle = #$1F#$73'%d';function TPDV_FD8C.Can: Boolean;
begin
Result := SendStr(cCommand_Can);
end;function TPDV_FD8C.Clear: Boolean;
begin
Result := SendStr(cCommand_Cls);
end;function TPDV_FD8C.CaretsMove(mCaretsPos: TCaretsPos): Boolean;
begin
Result := SendStr(Format(cCommand_CaretsMove, [mCaretsPos]));
end;function TPDV_FD8C.ShowCarets(mLight: Boolean): Boolean;
begin
Result := SendStr(Format(cCommand_CaretsStyle, [Ord(mLight)]));
end;function TPDV_FD8C.Init: Boolean;
begin
Result := SendStr(cCommand_Init);
end;function TPDV_FD8C.ShowNumber(mNumber: Real): Boolean;
begin
Result := SendStr(Format(cCommand_SendNumber, [mNumber]));
end;procedure TPDV_FD8C.SetCodeStyle(const Value: TCodeStyle);
begin
FCodeStyle := Value;
if Active then ShowCodeStyle(FCodeStyle);
end;procedure TPDV_FD8C.SetCaretsPos(const Value: Integer);
begin
FCaretsPos := Value;
if Active then CaretsMove(FCaretsPos);
end;procedure TPDV_FD8C.SetCaretsStyle(const Value: Boolean);
begin
FLight := Value;
if Active then ShowCarets(FLight);
end;procedure TPDV_FD8C.SetLineStyle(const Value: TLineStyle);
begin
FLineStyle := Value;
if Active then ShowNote(FWelcomeStyle, FLineStyle);
end;procedure TPDV_FD8C.SetNumber(const Value: Real);
begin
FNumber := Value;
if Active then ShowNumber(FNumber);
end;procedure TPDV_FD8C.SetWelcomeStyle(const Value: TWelcomeStyle);
begin
FWelcomeStyle := Value;
if Active then ShowNote(FWelcomeStyle, FLineStyle);
end;procedure TPDV_FD8C.SetWordStyle(const Value: TWordStyle);
begin
FWordStyle := Value;
if Active then ShowWord(FWordStyle);
end;function TPDV_FD8C.ShowCodeStyle(mCodeStyle: TCodeStyle): Boolean;
begin
Result := SendStr(Format(cCommand_ShowCodeStyle, [mCodeStyle]));
end;function TPDV_FD8C.ShowNote(mWelcomeStyle: TWelcomeStyle; mLineStyle: TLineStyle): Boolean;
begin
Result := SendStr(Format(cCommand_ShowNote, [mWelcomeStyle, mLineStyle]));
end;function TPDV_FD8C.ShowPosSystem(mShow: Boolean): Boolean;
begin
Result := SendStr(Format(cCommand_ShowPosSystem, [Ord(mShow)]));
end;function TPDV_FD8C.ShowWord(mWordStyle: TWordStyle): Boolean;
begin
Result := SendStr(Format(cCommand_ShowWord, [mWordStyle]));
end;procedure TPDV_FD8C.SetPosSystem(const Value: Boolean);
begin
FPosSystem := Value;
if Active then ShowPosSystem(FPosSystem);
end;end.
和我自己以前控制顾客牌的单元
你查查顾客牌的说明书
模仿做一下即可
你好，先谢谢你。我也是往串口发数据，可是不接受，能给我sendstr()的代码吗，还有运行前还需运行其它顾客显示器驱动程序吗？
unit ComControlUnit;interfaceuses
SysUtils, Classes, Spcomm;type
TComControl = class(TComponent)
private
FComm: TComm;
FActive: Boolean;
FComIndex: Byte;
FBaudRate: Integer;
FParityCheck: Boolean;
procedure SetActive(const Value: Boolean);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property ComIndex: Byte read FComIndex write FComIndex; //端口号
property BaudRate: Integer read FBaudRate write FBaudRate; //通讯波特率
property ParityCheck: Boolean read FParityCheck write FParityCheck; //奇偶校验
property Active: Boolean read FActive write SetActive;
function Open: Boolean;
function Close: Boolean;
function Send(mBuffer: PChar; mSize: Word): Boolean;
function SendStr(mStr: string): Boolean;
end;implementation{ TComControl }function TComControl.Close: Boolean;
begin
try
FComm.StopComm;
Result := True;
except
Result := False;
end;
if Result then FActive := False;
end;constructor TComControl.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FComm := TComm.Create(Self);
FComIndex := 1;
FBaudRate := 2400;
FParityCheck := True;
end;destructor TComControl.Destroy;
begin
if Assigned(FComm) then FComm.Free;
end;function TComControl.Open: Boolean;
begin
with FComm do try
CommName := Format('COM%d', [FComIndex]);
BaudRate := FBaudRate;
Parity := Space;
ParityCheck := FParityCheck;
Outx_XonXoffFlow := False;
Inx_XonXoffFlow := False;
StartComm;
Result := True;
except
Result := False;
end;
FActive := Result;
end;function TComControl.Send(mBuffer: PChar; mSize: Word): Boolean;
begin
Result := FComm.WriteCommData(mBuffer, mSize);
end;function TComControl.SendStr(mStr: string): Boolean;
begin
Result := Send(PChar(mStr), Length(mStr));
end;procedure TComControl.SetActive(const Value: Boolean);
begin
if FActive = Value then Exit;
FActive := Value;
if FActive then Open else Close;
end;end.
unit PDV_FD8CTestUnit;interfaceuses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, PDV_FD8CUnit, Spin;
type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
Button2: TButton;
Button3: TButton;
Button4: TButton;
CheckBox1: TCheckBox;
SpinEdit1: TSpinEdit;
Label1: TLabel;
ComboBox1: TComboBox;
ComboBox2: TComboBox;
Label2: TLabel;
Label3: TLabel;
ComboBox3: TComboBox;
Label4: TLabel;
CheckBox2: TCheckBox;
Label5: TLabel;
ComboBox4: TComboBox;
ComboBox5: TComboBox;
Label6: TLabel;
CheckBox3: TCheckBox;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure CheckBox1Click(Sender: TObject);
procedure SpinEdit1Change(Sender: TObject);
procedure ComboBox3Change(Sender: TObject);
procedure CheckBox2Click(Sender: TObject);
procedure ComboBox4Change(Sender: TObject);
procedure ComboBox1Change(Sender: TObject);
procedure ComboBox2Change(Sender: TObject);
procedure Edit1Change(Sender: TObject);
procedure ComboBox5Change(Sender: TObject);
procedure CheckBox3Click(Sender: TObject);
private
{ Private declarations }
FPDV_FD8C: TPDV_FD8C;
public
{ Public declarations }
end;var
Form1: TForm1;implementation{$R *.DFM}procedure TForm1.Button1Click(Sender: TObject);
begin
FPDV_FD8C.Clear;
end;procedure TForm1.FormCreate(Sender: TObject);
begin
ComboBox1.ItemIndex := 0;
ComboBox2.ItemIndex := 0;
ComboBox3.ItemIndex := 0;
ComboBox4.ItemIndex := 0;
FPDV_FD8C := TPDV_FD8C.Create(nil);
FPDV_FD8C.BaudRate := 2400;
end;procedure TForm1.FormDestroy(Sender: TObject);
begin
FPDV_FD8C.Close;
FPDV_FD8C.Free;
end;procedure TForm1.Button2Click(Sender: TObject);
begin
FPDV_FD8C.Can;
end;procedure TForm1.CheckBox1Click(Sender: TObject);
begin
FPDV_FD8C.Light := TCheckBox(Sender).Checked;
end;procedure TForm1.SpinEdit1Change(Sender: TObject);
begin
FPDV_FD8C.CaretsPos := TSpinEdit(Sender).Value;
end;procedure TForm1.ComboBox3Change(Sender: TObject);
begin
FPDV_FD8C.WordStyle := ComboBox3.ItemIndex;
end;procedure TForm1.CheckBox2Click(Sender: TObject);
begin
FPDV_FD8C.PosSystem := TCheckBox(Sender).Checked;
end;procedure TForm1.ComboBox4Change(Sender: TObject);
begin
FPDV_FD8C.CodeStyle := TComboBox(Sender).ItemIndex;
end;procedure TForm1.ComboBox1Change(Sender: TObject);
begin
FPDV_FD8C.WelcomeStyle := TComboBox(Sender).ItemIndex;
end;procedure TForm1.ComboBox2Change(Sender: TObject);
begin
FPDV_FD8C.LineStyle := TComboBox(Sender).ItemIndex;
end;function StrToFloatDef(mStr: string; mDef: Real): Real;
var
vCode: Integer;
begin
Val(mStr, Result, vCode);
if vCode <> 0 then Result := mDef;
end;procedure TForm1.Edit1Change(Sender: TObject);
begin
FPDV_FD8C.Number := StrToFloatDef(TEdit(Sender).Text, 0);
end;procedure TForm1.ComboBox5Change(Sender: TObject);
begin
FPDV_FD8C.ComIndex := ComboBox5.ItemIndex + 1;
end;procedure TForm1.CheckBox3Click(Sender: TObject);
begin
FPDV_FD8C.Close;
if TCheckBox(Sender).Checked then
TCheckBox(Sender).Checked := FPDV_FD8C.Open;
end;end.//dfm
object Form1: TForm1
Left = 192
Top = 107
Width = 435
Height = 300
Caption = 'Form1'
Color = clBtnFace
Font.Charset = GB2312_CHARSET
Font.Color = clWindowText
Font.Height = -16
Font.Name = '宋体'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
OnDestroy = FormDestroy
PixelsPerInch = 96
TextHeight = 16
object Label1: TLabel
Left = 10
Top = 133
Width = 64
Height = 16
Caption = '光标位置'
end
object Label2: TLabel
Left = 136
Top = 136
Width = 64
Height = 16
Caption = '谢谢惠顾'
end
object Label3: TLabel
Left = 272
Top = 136
Width = 48
Height = 16
Caption = '动态线'
end
object Label4: TLabel
Left = 8
Top = 168
Width = 32
Height = 16
Caption = '文字'
end
object Label5: TLabel
Left = 240
Top = 168
Width = 64
Height = 16
Caption = '货币符号'
end
object Label6: TLabel
Left = 22
Top = 234
Width = 32
Height = 16
Caption = '端口'
end
object Button1: TButton
Left = 8
Top = 80
Width = 75
Height = 25
Caption = '清除屏幕'
TabOrder = 0
OnClick = Button1Click
end
object Edit1: TEdit
Left = 8
Top = 16
Width = 121
Height = 24
TabOrder = 1
OnChange = Edit1Change
end
object Button2: TButton
Left = 88
Top = 80
Width = 75
Height = 25
Caption = '清除行'
TabOrder = 2
OnClick = Button2Click
end
object Button3: TButton
Left = 168
Top = 80
Width = 75
Height = 25
Caption = '初始化'
TabOrder = 3
end
object Button4: TButton
Left = 256
Top = 80
Width = 75
Height = 25
Caption = '显示数据'
TabOrder = 4
end
object CheckBox1: TCheckBox
Left = 168
Top = 16
Width = 97
Height = 17
Caption = '显示光标'
TabOrder = 5
OnClick = CheckBox1Click
end
object SpinEdit1: TSpinEdit
Left = 80
Top = 128
Width = 54
Height = 26
MaxValue = 8
MinValue = 1
TabOrder = 6
Value = 1
OnChange = SpinEdit1Change
end
object ComboBox1: TComboBox
Left = 200
Top = 128
Width = 66
Height = 24
Style = csDropDownList
ItemHeight = 16
TabOrder = 7
OnChange = ComboBox1Change
Items.Strings = (
'全暗。'
'全亮。'
'转动。'
'闪烁。')
end
object ComboBox2: TComboBox
Left = 323
Top = 128
Width = 98
Height = 24
Style = csDropDownList
ItemHeight = 16
TabOrder = 8
OnChange = ComboBox2Change
Items.Strings = (
' 全暗。'
' 全亮。'
'转动')
end
object ComboBox3: TComboBox
Left = 48
Top = 168
Width = 73
Height = 24
Style = csDropDownList
ItemHeight = 16
TabOrder = 9
OnChange = ComboBox3Change
Items.Strings = (
'全暗。'
'“单价”字符 亮'
'“总计”字符 亮'
'“收款”字符 亮'
'“找零”字符 亮')
end
object CheckBox2: TCheckBox
Left = 128
Top = 168
Width = 97
Height = 17
Caption = 'POS SYSTEM'
TabOrder = 10
OnClick = CheckBox2Click
end
object ComboBox4: TComboBox
Left = 312
Top = 160
Width = 81
Height = 24
Style = csDropDownList
ItemHeight = 16
TabOrder = 11
OnChange = ComboBox4Change
Items.Strings = (
'全暗。'
'＄。'
'￥。'
'￡。'
'全亮。'
'转动。')
end
object ComboBox5: TComboBox
Left = 56
Top = 232
Width = 89
Height = 24
Style = csDropDownList
ItemHeight = 16
TabOrder = 12
OnChange = ComboBox5Change
Items.Strings = (
'Com1'
'Com2'
'Com3'
'Com4')
end
object CheckBox3: TCheckBox
Left = 152
Top = 240
Width = 97
Height = 17
Caption = '是否连接'
TabOrder = 13
OnClick = CheckBox3Click
end
end
都是直接控制COM,LTD口
谢谢你，我一会给你分的，事实上我用的是foxpro for dos,你对此熟悉吗,我现在不知道如何发数据到串口，我把它作为串口打印机处理，可是返回打印机未准备好的错误！
你用Delphi编译
再用foxpro调用
API ---> delphi
你在VF区发发帖子
就不是什么都搞定