Sender: FUSE (fuse), letter area: Visual Title: Delphi reads and writes COM ports: BBS Shuimu Tsinghua Station (Sat Nov 1 02:54:35 1997)
{The following code is a COM control, which is suitable for the application of some responses after issuing commands. (Hey, I am engaged in the instrument, this application is more than possible), which is mainly to explain how to use these functions of the COM port in Delphi. Really practical COM control, also: ftp://ftp.lib.pku.edu.cn/incoming/fuse/ There are already some stuffs, see if there is a stroke, asynword is like a word}
Unit CommM;
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 declara Tions} hs} hion; {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: 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 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; connection: = false;
State: = 0; hint: = 'idle'; 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.Iterval: = 100; Timer1.ontimer: = CommQuery;
Procedure tcomm.paint; var rgraph: TRECT; Begin with Canvas Do Begraph: = Rect (1, 1, Width - 1, Height - 1); Pen.Color: = CLBLACK; Moveto (RGRAPH.right, RGRAPH.TOP) LINETO (RGRAPH.EFT, 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.Light, 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 the Goto Ret1;
GetcommDev, DCB); dcb.baudrate: = fbaudrate; dcb.bytesize: = fbytesize; dcb.parity: = fparity; dcb.stopbits: = fstopbits;
IF setcommstate (DCB) <0 dammdecomm (hcommdev); goto ret1;
EscapeCommfunction (hcommdev, setdtr);
CONNECTED: = TRUE;
RET1: END;
Procedure tcomm.decodecmd (str1: string; var); 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 dam: = true; btstr: = BTSTR STR1 [i]; end; '': begin if bytebegin the beginning [J]: = CHR (StrtOINT (BTSTR)); J: = J 1; Bytebegin: = false; btstr: = '; end; end; end; i: = i 1; end; ifbetebegin THEN BEGIN BTSTR: = '$' BTSTR; Char1 [J]: = CHR (STRTOINT (BTSTR)); J: = J 1; Bytebegin: = false; btstr: = '; end; char1 [J]: = CHR (0); sendlen: = J; Else Begin Str1); sendlen: = length (str1); end; end; procedure tcomm.sendcmd; begin case fmode of cmstr: s EndStrMD; CMBYTES: SendBytescmd; end;
procedure TComm.SendBytesCmd; begin State: = 1; Hint: = FPort '- Wait'; 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 '- error'; invalidate; end; end; procedure tcomm.sendstrcmd; begin decodecmd (cmdstr, cmdcha); state: = 1; hint: = fport '- Waiting'; 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 stat: = 3; hint: = fport '- error'; invalidate; end;
Procedure Tcomm.clears; begin readcomm (hcommdev, pool, stat.cbinque); pool [stat.cbinque]: = # 0; if Waiton Then Begin State: = 2; Hint: = fport '- Timeout'; refresh; Waiton: = False; end; commit; flushcomm (hcommdev, 0); flushcomm (hcommdev, 1);
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 '- idle'; refresh; Waiton: = FALSE; END
Procedure tcomm.hardwait; begin while connection; end;
Procedure tcomm.commquery (sender: TOBJECT);
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 (self); Else Begin Decodetime (now, min, sec, msec); {Communication Timeout falure} if (sec> ftimeout) OR ((ftimeout = 0) AND (msec> 500) ); if assigned (fontimeout) THEN FONTIMEOUT (Self); end; end; end; end; procedure tcomm.excute; begin if not waiton dam
Procedure tcomm.free; begin if connection; clearsigns; closecomm (hcommdev); end;
Function Tcomm.getdata (Offset: Word): Char; Begin IF Offset <= fwaitbyTenum Then Begin Result: = pool [offset];
End.
