📄 spcomm.pas
字号:
unit SPComm;
interface
uses
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 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
PWM_COMMWRITE = WM_USER+1;
INPUTBUFFERSIZE = 2048;
procedure Register;
implementation
//uses GD_dxcsy;
(******************************************************************************)
// 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;
procedure TComm.StartComm;
var
hNewCommFile:THandle;
begin
// Are we already doing comm?
if (hCommFile <> 0) then
raise ECommsError.Create( '串口已经被打开' );
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( '打开串口失败，可能设备没有安装好' );
// Is this a valid comm handle?
if GetFileType( hNewCommFile ) <> FILE_TYPE_CHAR then
begin
CloseHandle( hNewCommFile );
raise ECommsError.Create( '打开的不是串口 ' )
end;
if not SetupComm( hNewCommFile, 4096, 4096 ) then
begin
CloseHandle( hCommFile );
raise ECommsError.Create( '无法初始化接收缓冲区' )
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( 'U系统错误，无法创建事件' )
end;
// Create the Read thread.
try
ReadThread := TReadThread.Create( True {suspended} );
except
ReadThread := nil;
CloseHandle( hCloseEvent );
CloseHandle( hCommFile );
hCommFile := 0;
raise ECommsError.Create( '系统错误，无法创建读线程' )
end;
ReadThread.hCommFile := hCommFile;
ReadThread.hCloseEvent := hCloseEvent;
ReadThread.hComm32Window := FHWnd;
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( '系统错误，无法创建写线程' )
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}
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}
//用于发送一个字符串到写线程，发送成功返回true 发送失败返回false
//执行此函数将立即得到返回值，发送操作随后执行。函数有两个参数，其中
//pdatatowrite是要发送的字符串，dwsizeofdatatowrite 是发送的长度。
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 TComm.GetModemState : DWORD;
var
dwModemState : DWORD;
begin
if not GetCommModemStatus( hCommFile, dwModemState ) then
Result := 0
else
Result := dwModemState
end;
procedure TComm.CloseReadThread;
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -