一个端口控件
unit Comm;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, ExtCtrls;
type
TCmdMode = (cmStr, cmBytes);
TComm = class(TGraphicControl)
private
{ Private declarations }
FPort : string;
FBaudRate: Word; { Baudrate at which runing }
FByteSize: Byte; { Number of bits/byte, 4-8 }
FParity: Byte; { 0-4=None,Odd,Even,Mark,Space }
FStopBits: Byte; { 0,1,2 = 1, 1.5, 2 }
FWaitByteNum : word;
FTimeOut : word;
FMode : TCmdMode;
ColorSet : array [0..3] of TColor;
FCmdStr : string;
{ Communicate-relate varibles }
State : integer;
dcb : TDCB;
CommBeginTime : TDateTime;
Timer1 : TTimer;
{ NotifyEvents }
FOnDataLoad : TNotifyEvent;
FOnTimeOut : TNotifyEvent;
procedure CommQuery(Sender : TObject);
procedure LoadData;
procedure SendCmd;
procedure SendStrCmd;
procedure SendBytesCmd;
procedure SetByteNum(val : word);
procedure DecodeCmd(str1 : string; var char1 : array of char);
protected
{ Protected declarations }
procedure Paint; override;
public
{ Public declarations }
hCommDev : integer;
{ Memory Pool }
connected, WaitOn : boolean;
stat : TComStat;
CmdChar : array[0..64] of Char;
SendLen : word;
pool : array [0..2048] of char;
ms : TMemoryStream;
constructor Create(AOwner : TComponent); override;
procedure Connect;
procedure Excute;
function GetData(Offset : word) : Char;
procedure ClearSigns;
procedure Free;
procedure HardWait;
procedure Query;
published
{ Published declarations }
property BaudRate : word read FBaudRate write FBaudRate;
property Parity : byte read FParity write FParity;
property ByteSize : byte read FByteSize write FByteSize;
property StopBits : byte read FStopBits write FStopBits;
property CmdStr : string read FCmdStr write FCmdStr;
property WaitByteNum : word read FWaitByteNum write SetByteNum;
property Port : string read FPort write FPort;
property TimeOut : word read FTimeOut write FTimeOut;
property OnTimeOut : TNotifyEvent read FOnTimeOut write FOnTimeOut;
property OnDataLoad : TNotifyEvent read FOnDataLoad write FOnDataLoad;
property OnClick;
property ShowHint;
property OnMouseDown;
property Mode : TCmdMode read FMode write FMode;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [TComm]);
end;
constructor TComm.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle + [csFramed];
FPort := 'COM1';
FBaudRate := 9600;
FByteSize := 8;
FStopBits := 0;
FParity := 0;
FTimeOut := 7;
Width := 20;
Height := 20;
WaitOn := False;
Connected := False;
State := 0; Hint := '空闲';
ShowHint := True;
ColorSet[0] := clBlue;
ColorSet[1] := clYellow;
ColorSet[2] := clOlive;
ColorSet[3] := clMaroon;
{ Create Memory Stream }
ms := TMemoryStream.Create;
ms.SetSize(1);
FWaitByteNum := 1;
{ Create a Timer }
Timer1 := TTimer.Create(self);
Timer1.Interval := 100;
Timer1.OnTimer := CommQuery;
end;
procedure TComm.Paint;
var
rGraph : TRect;
begin
with Canvas do begin
rGraph := Rect(1, 1, Width - 1, Height - 1);
Pen.Color := clBlack;
MoveTo(rGraph.Right, rGraph.Top);
LineTo(rGraph.Left, rGraph.Top);
LineTo(rGraph.Left, rGraph.Bottom);
Pen.Color := clWhite;
LineTo(rGraph.Right, rGraph.Bottom);
LineTo(rGraph.Right, rGraph.Top);
Brush.Color := ColorSet[State]; Pen.Color := clSilver;
InflateRect(rGraph, -3, -3);
Ellipse(rGraph.Left, rGraph.Top, rGraph.Right, rGraph.Bottom);
end;
end;
procedure TComm.SetByteNum(val : word);
begin
FWaitByteNum := val;
ms.Clear;
ms.SetSize(val);
end;
procedure TComm.Connect;
var
PortChar : array[0..12] of Char;
Label ret1;
begin
Connected := False;
{ Initialize the Communication Port }
StrPCopy(PortChar, FPort);
hCommDev := OpenComm(PortChar, 8192, 2048);
if hCommDev < 0 then goto ret1;
GetCommState(hCommDev, dcb);
dcb.BaudRate := FBaudRate;
dcb.ByteSize := FByteSize;
dcb.Parity := FParity;
dcb.StopBits := FStopBits;
if SetCommState( dcb ) < 0 then begin
CloseComm(hCommDev);
goto ret1;
end;
EscapeCommFunction( hCommDev, SETDTR );
Connected := True;
ret1:
end;
procedure TComm.DecodeCmd( str1 : string; var char1 : array of char);
var
i, j : integer;
btstr : string;
bytebegin : boolean;
begin
if str1[1] = '$' then begin
i := 1; j := 0;
btstr := '';
bytebegin := false;
while (i<=Length(str1)) do begin
case str1[i] of
'0'..'9', 'a'..'f', 'A'..'F' : begin
if not bytebegin then bytebegin := true;
btstr := btstr + str1[i];
end;
' ' : begin
if bytebegin then begin
btstr := '$'+btstr;
char1[j] := Chr(StrToInt(btstr));
j := j + 1;
bytebegin := false;
btstr := '';
end;
end;
end;
i := i + 1;
end;
if bytebegin then begin
btstr := '$'+btstr;
char1[j] := Chr(StrToInt(btstr));
j := j + 1;
bytebegin := false;
btstr := '';
end;
char1[j] := Chr(0);
SendLen := j;
end
else begin
StrPCopy(Addr(char1), str1);
SendLen := Length(str1);
end;
end;
procedure TComm.SendCmd;
begin
case FMode of
cmStr : SendStrCmd;
cmBytes : SendBytesCmd;
end;
end;
procedure TComm.SendBytesCmd;
begin
State := 1; Hint := FPort+'-等待';
Refresh;
WaitOn := False;
if not Connected then Connect;
if Connected then begin
FlushComm(hCommDev, 0);
FlushComm(hCommDev, 1);
FillChar(pool, 32, 0);
WriteComm(hCommDev, CmdChar, SendLen);
CmdStr := '';
FillChar(CmdChar, 32, 0);
WaitOn := True;
CommBeginTime := Now;
end
else begin
State := 3; Hint := FPort+'-错误';
Invalidate;
end;
end;
procedure TComm.SendStrCmd;
begin
DecodeCmd(CmdStr, CmdChar);
State := 1; Hint := FPort+'-等待';
Refresh;
WaitOn := False;
if not Connected then Connect;
if Connected then begin
FlushComm(hCommDev, 0);
FlushComm(hCommDev, 1);
FillChar(pool, 32, 0);
WriteComm(hCommDev, CmdChar, SendLen);
CmdStr := '';
FillChar(CmdChar, 32, 0);
WaitOn := True;
CommBeginTime := Now;
end
else begin
State := 3; Hint := FPort+'-错误';
Invalidate;
end;
end;
procedure TComm.ClearSigns;
begin
ReadComm(hCommDev, pool, stat.cbInQue);
pool[stat.cbInQue] := #0;
if WaitOn then begin
State := 2; Hint := FPort+'-超时';
Refresh;
WaitOn := False;
end;
CommBeginTime := Now;
FlushComm(hCommDev, 0);
FlushComm(hCommDev, 1);
end;
procedure TComm.LoadData;
begin
ReadComm(hCommDev, pool, stat.cbInQue);
pool[stat.cbInQue] := #0;
ms.Seek(0,0);
ms.Write(pool, FWaitByteNum);
State := 0; Hint := FPort+'-空闲';
Refresh;
WaitOn := False;
end;
procedure TComm.HardWait;
begin
while Connected and WaitOn do begin
Query;
end;
end;
procedure TComm.CommQuery(Sender : TObject);
begin
Query;
end;
procedure TComm.Query;
var
Hour, Min, Sec, MSec : Word;
begin
if Connected and WaitOn and (FWaitByteNum > 0) then
begin
GetCommError(hCommDev, stat);
if stat.cbInQue >= FWaitByteNum then begin
LoadData;
if Assigned(FOnDataLoad) then FOnDataLoad(self);
end
else begin
DecodeTime(Now-CommBeginTime, Hour, Min, Sec, MSec);
{ Communication Timeout Falure }
if (Sec > FTimeOut) or
((FTimeOut = 0) and (MSec > 500)) then begin
ClearSigns;
if Assigned(FOnTimeOut) then FOnTimeOut(self);
end;
end;
end;
end;
procedure TComm.Excute;
begin
if not WaitOn then SendCmd;
end;
procedure TComm.Free;
begin
if Connected then begin
Connected := False;
ClearSigns;
CloseComm(hCommDev);
end;
end;
function TComm.GetData(Offset : word) : Char;
begin
if Offset <= FWaitByteNum then begin
Result := pool[Offset];
end;
end;
end.