CSDN博客

img yuanqingfei

Delphi中读写COM口

发表于2004/7/5 18:55:00  1318人阅读

发信人: fuse (保险丝), 信区: Visual
标  题: Delphi中读写COM口
发信站: BBS 水木清华站 (Sat Nov  1 02:54:35 1997)


{下面的代码是一个COM控件,适合于发出命令后等待一些回应的应用。
 (嘿嘿,我是搞仪器的,这种应用比较多点),贴在这里主要是想说明
 Delphi中如何使用COM口的这些函数。
 真正实用的COM控件呢,也有:ftp://ftp.lib.pku.edu.cn/incoming/fuse/
 里面已经有一些东东了,看到有comm字样的,asyn字样的就是了 }

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.

 

0 0

相关博文

我的热门文章

img
取 消
img