Delphi中读写COM口

转载 2004年07月05日 18:55:00

发信人: 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.

 

Delphi中ComPort串口控件通信中的数据处理

http://www.cnblogs.com/gaiyang/archive/2011/09/02/2163265.html 1.串口通信的基本原理: 一般计算机与外部设备通讯有两种方式:...
  • lotusyangjun
  • lotusyangjun
  • 2013年11月06日 21:57
  • 10965

早些时候写的一个Delphi中的串口通读类.

这个是早期的版本,后期我做了很大的修动...仅做为学习参考用.       在做数据采集,及控制系统中,我建议大家自己用API写通讯类..不要使用SPCOMM,以及MSCOMM...在实际的应用中,自...
  • lijinjie
  • lijinjie
  • 2005年02月21日 03:44
  • 2028

Delphi 接口:两个接口有相同名称的方法

假设有两个接口定义,里面有相同名称的方法。然后有一个类,要同时实现这两个接口。语法上该怎么写才正确? 请看代码: type IMyIntfA = interface ['{03...
  • pcplayer
  • pcplayer
  • 2017年06月28日 14:26
  • 294

Delphi获取默认打印机名称及端口

Delphi获取默认打印机名称及端口  在前段时间写的收银系统中由于目前市场上很多电脑主板上已经没有并口,而POS机却又需要并口,所以目前需要用PCI转接卡,这个就导致不同门店使用...
  • lailai186
  • lailai186
  • 2013年08月12日 14:10
  • 3535

delphi 修改文件夹名和文件名

unit Unit1;interfaceuses  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,...
  • wjw806
  • wjw806
  • 2008年04月15日 01:29
  • 7737

delphi 下枚举可用串口

class function TSysMethod.GetSysComList: TStringList; var   KeyHandle: HKEY;   ErrCode, Index: In...
  • zang141588761
  • zang141588761
  • 2017年04月12日 16:18
  • 531

如何知道COM端口在使用中

假如机器上原来有两个COM口,COM1和COM2安装了一个USB设备后,这个USB设备使用了VCP(virtual com port)把COM3占用了,当我安装另一个新设备时,我如何知道哪些COM口已...
  • swayi21
  • swayi21
  • 2007年07月02日 14:33
  • 4536

Delphi 实现程序 动态 类名

1、首先将delphi中Controls单元提取2、修改Controls单元中如下部分:procedure TWinControl.CreateParams(var Params: TCreatePa...
  • rryr2
  • rryr2
  • 2009年12月16日 19:58
  • 1372

Delphi中获取打印机设备名和端口名

uses printers; procedure TForm1.Button1Click(Sender: TObject); var   pDevice : pChar;   pDriver : pC...
  • delphi308
  • delphi308
  • 2013年08月07日 17:32
  • 1551

电脑COM口被莫名其妙占用

之前一直没发现,直到今天使用DNW软件,它上面固定了COM1-COM4,如图 而我的CH340则被分配到了COM16,无奈只能去设备管理器中修改端口号,但是发现出现电脑的COM1到COM15都在...
  • yanlutian
  • yanlutian
  • 2016年08月28日 20:50
  • 1253
内容举报
返回顶部
收藏助手
不良信息举报
您举报文章:Delphi中读写COM口
举报原因:
原因补充:

(最多只允许输入30个字)