cportmonitor.pas

Cport3.0最好的使用例子

{***************************************************************
 *
 * Unit Name: CPortMonitor
 * Purpose  : Addition to ComPort 2.60 Communication Library
 *						TMemo to monitor incoming and outgoing data
 * Author   :	Roelof Y. Ensing ([e-mail])
 * History  : June 2000, first edition
 *
 ****************************************************************}

unit CPortMonitor;
{$I CPort.inc}

interface

uses
	Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
	StdCtrls, Math, CPortCtl, CPort;

type

	TMonitorStyle = (msAscii,msHex,msHexC,msHexVB,msHexPascal,msDecimal,msBinary);
	TMonitorEvent = procedure (var DisplayValue:string;const Data:string; ComPort: TComPort) of object;
	TMonitorInfo = (miCommPort, miDate, miTime, miDirection);
	TMonitorInfoSet = set of TMonitorInfo;

	TCPortMonitor = class(TCustomMemo)
	private
		FLines:TStringList;
		FBackColorOutput: TColor;
		FBackColorInput: TColor;
		FForeColorOutput: TColor;
		FForeColorInput: TColor;
		FColIncrement: integer;
		FRowIncrement: integer;
		FMonitorShow:TMonitorInfoSet;
		FUpdating:integer;
		FMonitorStyle:TMonitorStyle;
		FSpacing:integer;
		FEnclosed:boolean;
		FComLink:TComLink;
		FComPort:TComPort;
		FMaxLines:integer;
		FReverse:boolean;
		FOnInput:TMonitorEvent;
		FOnOutput:TMonitorEvent;
		procedure SetBackColorOutput (Value: TColor);
		procedure SetBackColorInput (Value: TColor);
		procedure SetForeColorOutput (Value: TColor);
		procedure SetForeColorInput (Value: TColor);
		procedure SetMonitorStyle(Value:TMonitorStyle);
		procedure SetSpacing(Value:integer);
		procedure SetEnclosed(Value:boolean);
		procedure SetComPort(Value:TComPort);
		procedure SetMaxLines(Value:integer);
		procedure SetReverse(Value:boolean);
		procedure SetMonitorShow(Value:TMonitorInfoSet);
		procedure WMPAINT (var Message: TMessage); message WM_PAINT;
		procedure WMHSCROLL (var Message: TMessage); message WM_HSCROLL;
		procedure WMVSCROLL (var Message: TMessage); message WM_VSCROLL;
		procedure WMLBUTTONDOWN (var Message: TMessage); message WM_LBUTTONDOWN;
		procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LButtonDblClk;
		procedure SetLines(AValue:TStringList);
		procedure TxBuf(Sender: TObject; const Buffer; Count: Integer);
		procedure RxBuf(Sender: TObject; const Buffer; Count: Integer);
		function StrToPrint(const s: string;spacing:integer): string;
		function StrToDecimal(const s: string;spacing:integer): string;
		function StrToBinary(const s: string;spacing:integer): string;
		function BufToHex(ABuf:pointer;const ALength,Spacing:integer;Prefix:string):string;
		function StrToHex(const s:string;spacing:integer;prefix:string):string;
		procedure AddLineToBuffer(const ALine:string;const AType:integer);
		function GetDisplayValue(const AValue:string;const AType:integer):string;
		procedure LinesChanging(Sender:TObject);
	protected
		procedure Change; override;
		procedure Notification(AComponent: TComponent; Operation: TOperation); override;
	public
		constructor Create (AOwner: TComponent); override;
		destructor Destroy; override;
		procedure CreateWnd; override;
		procedure Loaded; override;
	published
		property Align;
		//property Alignment;
{$IFDEF DELPHI_4_OR_HIGHER}
		property Anchors;
		property BiDiMode;
		property Constraints;
		property ParentBiDiMode;
{$ENDIF}
		property BorderStyle;
		property Color;
		property Ctl3D;
		//property DragCursor;
		//property DragKind;
		//property DragMode;
		//property Enabled;
		property Font;
		property HideSelection;
		//property ImeMode;
		//property ImeName;
		//property Lines;
		property MaxLength;
		//property OEMConvert;
		property ParentColor;
		property ParentCtl3D;
		property ParentFont;
		property ParentShowHint;
		property PopupMenu;
		//property ReadOnly;
		//property ScrollBars;
		property ShowHint;
		property TabOrder;
		property TabStop;
		property Visible;
		//property WantReturns;
		//property WantTabs;
		//property WordWrap;
		property OnChange;
		//property OnClick;
		//property OnDblClick;
		//property OnDragDrop;
		//property OnDragOver;
		//property OnEndDock;
		//property OnEndDrag;
		//property OnEnter;
		//property OnExit;
		//property OnKeyDown;
		//property OnKeyPress;
		//property OnKeyUp;
		//property OnMouseDown;
		//property OnMouseMove;
		//property OnMouseUp;
		//property OnStartDock;
		//property OnStartDrag;
		property BackColorOutput: TColor read FBackColorOutput write SetBackColorOutput default clAqua;
		property BackColorInput: TColor read FBackColorInput write SetBackColorInput default clWhite;
		property ForeColorOutput: TColor read FForeColorOutput write SetForeColorOutput default clNavy;
		property ForeColorInput: TColor read FForeColorInput write SetForeColorInput default clRed;
		property MonitorStyle:TMonitorStyle read FMonitorStyle write SetMonitorStyle default msHex;
		property Spacing:integer read fSpacing write SetSpacing default 0;
		property Enclosed:boolean read fEnclosed write SetEnclosed default true;
		property MaxLines:integer read FMaxLines write SetMaxLines default 1024;
		property Reverse:boolean read FReverse write SetReverse default true;
		property OnInput:TMonitorEvent read fOnInput write fOnInput;
		property OnOutput:TMonitorEvent read fOnOutput write fOnOutput;
		property ComPort: TComPort read FComPort write SetComPort;
		property MonitorShow:TMonitorInfoSet read FMonitorShow write SetMonitorShow;
	end;

procedure Register;

implementation

procedure Register;
begin
	RegisterComponents('CPortLib', [TCPortMonitor]);
end;

function TCPortMonitor.StrToPrint(const s: string;spacing:integer): string;
var
	i1,i3: integer;
begin
	Result := '';
	if Length(S) <= 0 then
		exit;
	for i1 := 1 to Length(s) do
	begin
		if fEnclosed then
			Result:=Result+'[';
		if ( ord(S[I1]) < 32 ) or ( ord(S[i1] ) > 127 ) then
			Result:=Result+format('x%.2x', [ord(S[i1])])
		else
			Result:=Result+s[i1];
		if fEnclosed then
			Result:=Result+']';
		if spacing > 0 then
			for i3 := 1 to spacing do
				result := result + ' ';
	 end;
end;

function TCPortMonitor.StrToDecimal(const s: string;spacing:integer): string;
var
	i1,i3: integer;
begin
	Result := '';
	if Length(S) <= 0 then
		exit;
	for i1 := 1 to Length(s) do
	begin
		if fEnclosed then
			Result:=Result+'[';
		Result:=Result+Format('%.3d',[ord(S[i1])]);
		if fEnclosed then
			Result:=Result+']';
		if spacing > 0 then
			for i3 := 1 to spacing do
				result := result + ' ';
	 end;
end;

function TCPortMonitor.StrToBinary(const s: string;spacing:integer): string;
var
	i1,i2,i3: integer;
	 quotient,pwr,numpres:integer;
	 x1: real;
	 x2: real;
begin
	Result := '';
	if Length(S) <= 0 then
		exit;
	for i1 := 1 to Length(s) do
	begin
		if fEnclosed then
			Result:=Result+'[';
		numpres := ord(s[i1]);
		for i2 := 8 downto 1 do
		begin
			x1			:= i2 - 1;
			x2			:= 2;
			pwr		:= trunc(power(x2,x1));
			quotient	:= numpres div pwr;
			if quotient > 0 then
			begin
				result := result + '1';
				numpres := numpres - pwr;
			end
			else
				result := result + '0';
		end;
		if fEnclosed then
			Result:=Result+']';
		if spacing > 0 then
		for i3 := 1 to spacing do
			result := result + ' ';
	end;
end;

function TCPortMonitor.BufToHex(ABuf:pointer;const ALength,Spacing:integer;Prefix:string):string;
var
	i1,i2:integer;
begin
	Result := '';
	if ALength <= 0 then
		exit;
	try
		for i1 :=0 to ALength -1 do
		begin
			if fEnclosed then
				Result:=Result+'[';
			AppendStr(Result,Format(prefix+'%.2x', [ord(char(PChar(ABuf)[i1]))] ));
			if fEnclosed then
				Result:=Result+']';
			if spacing > 0 then
				for i2 := 1 to spacing do
					AppendStr(Result,' ');
		end;
	except
		AppendStr(Result,' (out of bounds)');
	end;
end;

function TCPortMonitor.StrToHex(const s:string;spacing:integer;prefix:string):string;
begin
	Result:=BufToHex(Pchar(s),Length(s),Spacing,prefix);
end;

{ **************************************************************************** }

constructor TCPortMonitor.Create (AOwner: TComponent);
begin
	inherited Create (AOwner);
	ReadOnly:=true;
	ScrollBars := ssBoth;
	WantReturns:= false;
	WantTabs := false;
	WordWrap := true;
	Font.Name := 'Courier';
	FBackColorOutput  := clAqua;
	FBackColorInput  := clWhite;
	FForeColorOutput  := clNavy;
	FForeColorInput  := clRed;
	FRowIncrement := 0;
	FMonitorStyle := msHex;
	FSpacing := 0;
	FEnclosed := true;
	FMaxLines := 1024;
	FReverse := true;
	FLines:=TStringList.Create;
	FLines.OnChange:=LinesChanging;
	FComLink := TComLink.Create;
	FComLink.OnRxBuf := RxBuf;
	FComLink.OnTxBuf := TxBuf;
	FMonitorShow := [miDirection];
end;

destructor TCPortMonitor.Destroy;
begin
	if FComPort <> nil then
	try
		FComPort.UnRegisterLink(FComLink);
	finally
		FComLink.Free;
	end;
	FLines.Free;
	inherited;
end;

procedure TCPortMonitor.CreateWnd;
begin
	inherited;
	FLines.Clear;
	inherited Lines.Clear;
	if (csDesigning in ComponentState) then
	begin
		AddLineToBuffer('Input Message',(0));
		AddLineToBuffer('Output Message',(1));
		//SetLines(FLines);
	end;
end;

procedure TCPortMonitor.Loaded;
begin
	FLines.Clear;
	inherited Lines.Clear;
	if (csDesigning in ComponentState) then
	begin
		AddLineToBuffer('Input Message',(0));
		AddLineToBuffer('Output Message',(1));
		//SetLines(FLines);
	end;
end;

procedure TCPortMonitor.Notification(AComponent: TComponent; Operation: TOperation);