读写COM口

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 Result := pool[Offset];
  end;

end.