F
FreeAndNil
Unregistered / Unconfirmed
GUEST, unregistred user!
包含三个组件:
TGridLine:负责画表格线,TComponent继承
LeftTopControl、RithtBottomControl记录了表格框的范围,这两个属性只接受TMyLabel、TMyDBEdit组件,以这两个组件为左上角、右下角画外框
ILLeftOffset。。。等???Offset属性是对表格线的位置的描述
Draw: boolean属性,是否画线
???Color属性是对线的颜色的描述
TMyLabel:TLabel继承,辅助画线。
GridCellLine: TGridCellLines属性,是TGridCellLine集合,描述组件四边是否画表格线
GridConctrler: TGridLine属性,记录所属的画线组件
TMyDBEdit:TDBEdit继承,辅助画线。
GridCellLine: TGridCellLines属性,是TGridCellLine集合,描述组件四边是否画表格线
GridConctrler: TGridLine属性,记录所属的画线组件
其他是属性不用多关注,改过一版,还有些没什么用的属性没去掉。
组件是这样工作的:
TGridLine记录下左上、右下角的组件,这样,表格的外框范围就定了,然后所有需要在这个范围内画线的组件(TMyLabel、TMyDBEdit)设置好GridConctrler属性,然后设置GridCellLine属性,TGridLine负责把这些组件四周的线条画出来。
这个组件主要是为了方便在设计时直接在ide中看到画线的效果,用TBevel虽也可画线条,但是TBevel一多,界面调整起来就很麻烦。
这个组件是项目里面临时起意写的,之前没写过多少组件,经验不足,写得很糟糕,这是改进了的,主要有以下几个问题:
1、不知如何获得TMyLabel、TMyDBEdit在ide中移动的事件。不知道怎样才能在ide中直观的看到效果,就把重画动作放在wm_paint消息中,外框有变量记录,可以在重画前把原来位置的线条给清楚,但是GridCellLine所描述的线条,似乎无法用重载Left等属性的方法来获得变化前的位置,所以,在移动这些组件时,界面上就留下了没有清除的残像了,how?
2、也是最严重的问题,我的同事用了我的组件画界面,用了段时间后,delphi就越来越慢(运行态没有这个问题,似乎只是对ide环境有影响),最后到无法忍受,不知道是哪里出了问题,内存似乎并没有消耗太多,这几个组件本身并没有额外申请内存,cpu占用率也没有100%,到底是哪些代码让delphi出了问题?这时只要关闭工程(不用关闭delphi),再打开工程,又好了,可用一段时间后,delphi有变慢了,真是头痛。
我对编写组件不熟,以前虽说写过几个组件,但感觉还是不够深入,比如写这样直接在设计时界面上可以看到效果的组件怎么调试之类的问题都不了解,希望对组件编程比较熟的朋友帮忙指导一下。
又:抱歉一下,时间原因,代码写的很匆忙,没写注释,感觉思路、结构还比较简单清楚,凑活着看看吧[]
unit MyDBCtrl;
interface
uses
Windows, Messages, Classes, SysUtils, Graphics, Forms, Controls, StdCtrls, DBCtrls;
type
TGridCellLine = (gclLeft, gclTop, gclRight, gclBottom);
TGridCellLines = set of TGridCellLine;
TVerifyType = (vtIdentityCard, vtDate);
TGridLine = class(TComponent )
private
FInnerConctrl: array of TControl ;
FBorderSeted: Boolean;
FBorderRect: TRect ;
FCanvas: TCanvas ;
FDrawed: boolean;
FClearColor: TColor ;
FDraw: boolean;
FILBottomOffset: integer;
FILRightOffset: integer;
FILTopOffset: integer;
FILLeftOffset: integer;
FInnerLineColor: TColor;
FBorderColor: TColor;
FRithtBottomControl: TControl;
FLeftTopControl: TControl;
FOLRightOffset: integer;
FOLLeftOffset: integer;
FOLTopOffset: integer;
FOLBottomOffset: integer;
procedure ClearDraw;
procedure DelAControl(const Value: TControl);
procedure SetBorderColor(const Value: TColor);
procedure SetDraw(const Value: boolean);
procedure SetILBottomOffset(const Value: integer);
procedure SetILLeftOffset(const Value: integer);
procedure SetILRightOffset(const Value: integer);
procedure SetILTopOffset(const Value: integer);
procedure SetInnerLineColor(const Value: TColor);
procedure SetLeftTopControl(const Value: TControl);
procedure SetRithtBottomControl(const Value: TControl);
procedure SetOLBottomOffset(const Value: integer);
procedure SetOLLeftOffset(const Value: integer);
procedure SetOLRightOffset(const Value: integer);
procedure SetOLTopOffset(const Value: integer);
protected
procedure DoDraw;virtual ;
public
constructor Create(AWOner: TComponent); override;
destructor Destroy; override;
procedure AddAControl(Value: TControl );
procedure ReDraw;
published
property LeftTopControl:TControl read FLeftTopControl write SetLeftTopControl;
property RithtBottomControl:TControl read FRithtBottomControl write SetRithtBottomControl;
property ILLeftOffset: integer read FILLeftOffset write SetILLeftOffset default 10;
property ILTopOffset: integer read FILTopOffset write SetILTopOffset default 10;
property ILRightOffset: integer read FILRightOffset write SetILRightOffset default 10;
property ILBottomOffset: integer read FILBottomOffset write SetILBottomOffset default 0;
property OLLeftOffset: integer read FOLLeftOffset write SetOLLeftOffset default 10;
property OLTopOffset: integer read FOLTopOffset write SetOLTopOffset default 10;
property OLRightOffset: integer read FOLRightOffset write SetOLRightOffset default 10;
property OLBottomOffset: integer read FOLBottomOffset write SetOLBottomOffset default 10;
property Draw: boolean read FDraw write SetDraw;
property BorderColor: TColor read FBorderColor write SetBorderColor default clBlack;
property InnerLineColor: TColor read FInnerLineColor write SetInnerLineColor default clGray;
end;
TMyLabel = class(TLabel)
private
FTGridCellLines: TGridCellLines;
FIsLeftTop: boolean;
FIsRightBottom: boolean;
FParentForm: TWinControl; //TCustomForm;
FBorderColor: TColor;
FGridCellLineColor: TColor;
FGridConctrler: TGridLine;
procedure SetTGridCellLines(const Value: TGridCellLines);
procedure SetGridCellLineColor(const Value: TColor);
procedure SeTGridLine(const Value: TGridLine);
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
function GetHeight: integer;
function GetLeft: integer;
function GetTop: integer;
function GetWidth: integer;
procedure SetHeight(const Value: integer);
procedure SetLeft(const Value: integer);
procedure SetTop(const Value: integer);
procedure SetWidth(const Value: integer);
protected
procedure SetParent(AParent: TWinControl); override;
public
constructor Create(AWOner: TComponent); override;
published
property GridCellLine: TGridCellLines read FTGridCellLines write SetTGridCellLines default [];
property GridCellLineColor: TColor read FGridCellLineColor write SetGridCellLineColor default clBlack;
property GridConctrler: TGridLine read FGridConctrler write SeTGridLine;
property Left: integer read GetLeft write SetLeft;
property Top: integer read GetTop write SetTop;
property Width: integer read GetWidth write SetWidth;
property Height: integer read GetHeight write SetHeight;
end;
TMyDBEdit = class(TDBEdit)
private
FPropertyCode: string;
FUnderLine: Boolean;
FUnderLineColor: TColor;
FParentForm: TWinControl; // TCustomForm;
FTGridCellLines: TGridCellLines;
FIsLeftTop: boolean;
FIsRightBottom: boolean;
FBorderColor: TColor;
FGridCellLineColor: TColor;
FNotNull: boolean;
FVerifyType: TVerifyType;
FGridConctrler: TGridLine;
procedure SetPropertyCode(const Value: string);
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure SetUnderLine(const Value: Boolean);
procedure SetUnderLineColor(const Value: TColor);
procedure SetTGridCellLines(const Value: TGridCellLines);
procedure SetGridCellLineColor(const Value: TColor);
procedure SetNotNull(const Value: boolean);
procedure SetVerifyType(const Value: TVerifyType);
procedure SeTGridLine(const Value: TGridLine);
function GetHeight: integer;
function GetLeft: integer;
function GetTop: integer;
function GetWidth: integer;
procedure SetHeight(const Value: integer);
procedure SetLeft(const Value: integer);
procedure SetTop(const Value: integer);
procedure SetWidth(const Value: integer);
protected
procedure DrawUnderLine;
procedure SetParent(AParent: TWinControl); override;
published
property PropertyCode: string read FPropertyCode write SetPropertyCode;
property UnderLine: Boolean read FUnderLine write SetUnderLine default False;
property UnderLineColor: TColor read FUnderLineColor write SetUnderLineColor default clBlack;
property GridCellLine: TGridCellLines read FTGridCellLines write SetTGridCellLines default [];
property GridCellLineColor: TColor read FGridCellLineColor write SetGridCellLineColor default clBlack;
property NotNull: boolean read FNotNull write SetNotNull default false;
property VerifyType:TVerifyType read FVerifyType write SetVerifyType;
property GridConctrler: TGridLine read FGridConctrler write SeTGridLine;
property Left: integer read GetLeft write SetLeft;
property Top: integer read GetTop write SetTop;
property Width: integer read GetWidth write SetWidth;
property Height: integer read GetHeight write SetHeight;
property Text;
public
constructor Create(AWOner: TComponent); override;
end;
procedure Register;
procedure DrawAll(Value: TControl );
const
cNotNullUC: TColor = clRed; //必须输入项的下划线颜色
cReadOnlyUC: TColor = clBlue; //只读输入项的下划线颜色
implementation
procedure Register;
begin
RegisterComponents('Samples', [TMyDBEdit, TMyLabel,TGridLine]);
end;
{ TMyDBEdit }
procedure DrawAll(Value: TControl );
var
i: integer;
begin
for i := 0 to Value.ComponentCount - 1 do
begin
if Value.Components is TGridLine then
TGridLine(Value.Components).ReDraw ;
end;
end;
constructor TMyDBEdit.Create(AWOner: TComponent);
begin
inherited;
FPropertyCode := '';
FTGridCellLines := [];
FParentForm := nil;
FUnderLine := false;
FUnderLineColor := clBlack;
FIsLeftTop := False;
FIsRightBottom := False;
FBorderColor := clBlack;
FGridCellLineColor := clBlack;
FNotNull := false;
FGridConctrler := nil;
end;
procedure TMyDBEdit.DrawUnderLine;
const
cUOffset = 15;
var
c: TCanvas;
begin
c := TCanvas.Create;
try
c.Handle := GetDC(Handle);
c.MoveTo(0, cUOffset);
if FUnderLine then
begin
if FNotNull then
c.Pen.Color := cNotNullUC
else
if ReadOnly then
c.Pen.Color := cReadOnlyUC
else
c.Pen.Color := FUnderLineColor;
end
else
c.Pen.Color := Color;
c.LineTo(Width, cUOffset);
finally
c.Free;
end;
end;
function TMyDBEdit.GetHeight: integer;
begin
Result := inherited Height;
end;
function TMyDBEdit.GetLeft: integer;
begin
Result := inherited Left;
end;
function TMyDBEdit.GetTop: integer;
begin
Result := inherited Top;
end;
function TMyDBEdit.GetWidth: integer;
begin
Result := inherited Width;
end;
procedure TMyDBEdit.SetGridCellLineColor(const Value: TColor);
begin
FGridCellLineColor := Value;
end;
procedure TMyDBEdit.SeTGridLine(const Value: TGridLine);
begin
if Value = nil then
begin
if FGridConctrler.FDrawed then
FGridConctrler.ClearDraw ;
FGridConctrler.DelAControl(self);
FGridConctrler.ReDraw ;
FGridConctrler := Value;
end
else begin
FGridConctrler := Value;
FGridConctrler.AddAControl(Self);
FGridConctrler.ReDraw ;
end;
end;
procedure TMyDBEdit.SetHeight(const Value: integer);
begin
if FGridConctrler <> nil then
if FGridConctrler.FDrawed then
FGridConctrler.ClearDraw ;
inherited Height := Value ;
end;
procedure TMyDBEdit.SetLeft(const Value: integer);
begin
if FGridConctrler <> nil then
if FGridConctrler.FDrawed then
FGridConctrler.ClearDraw ;
inherited Left := Value ;
end;
procedure TMyDBEdit.SetNotNull(const Value: boolean);
begin
FNotNull := Value;
end;
procedure TMyDBEdit.SetParent(AParent: TWinControl);
begin
inherited;
FParentForm := Parent; // GetParentForm(Self);
end;
procedure TMyDBEdit.SetPropertyCode(const Value: string);
begin
FPropertyCode := Value;
end;
procedure TMyDBEdit.SetTGridCellLines(const Value: TGridCellLines);
begin
if FGridConctrler <> nil then
FGridConctrler.ReDraw ;
FTGridCellLines := Value;
end;
procedure TMyDBEdit.SetTop(const Value: integer);
begin
if FGridConctrler <> nil then
if FGridConctrler.FDrawed then
FGridConctrler.ClearDraw ;
inherited Top := Value ;
end;
procedure TMyDBEdit.SetUnderLine(const Value: Boolean);
begin
FUnderLine := Value;
if FUnderLine then
begin
ParentColor := true;
BorderStyle := bsNone;
BevelEdges := [];
BevelKind := bkNone;
Ctl3D := false;
end;
DrawUnderLine
end;
procedure TMyDBEdit.SetUnderLineColor(const Value: TColor);
begin
FUnderLineColor := Value;
if FUnderLine then
DrawUnderLine;
end;
procedure TMyDBEdit.SetVerifyType(const Value: TVerifyType);
begin
FVerifyType := Value;
end;
procedure TMyDBEdit.SetWidth(const Value: integer);
begin
if FGridConctrler <> nil then
if FGridConctrler.FDrawed then
FGridConctrler.ClearDraw ;
inherited Width := Value ;
end;
procedure TMyDBEdit.WMPaint(var Message: TWMPaint);
begin
inherited;
if FUnderLine then
DrawUnderLine;
if (FGridConctrler <> nil) and FGridConctrler.FDraw then
FGridConctrler.ReDraw ;
end;
{ TMyLabel }
constructor TMyLabel.Create(AWOner: TComponent);
begin
inherited;
FTGridCellLines := [];
FParentForm := nil;
FIsLeftTop := False;
FIsRightBottom := False;
FBorderColor := clBlack;
FGridCellLineColor := clBlack;
FGridConctrler := nil;
end;
function TMyLabel.GetHeight: integer;
begin
Result := inherited Height;
end;
function TMyLabel.GetLeft: integer;
begin
Result := inherited Left;
end;
function TMyLabel.GetTop: integer;
begin
Result := inherited Top;
end;
function TMyLabel.GetWidth: integer;
begin
Result := inherited Width;
end;
procedure TMyLabel.SetGridCellLineColor(const Value: TColor);
begin
FGridCellLineColor := Value;
end;
procedure TMyLabel.SeTGridLine(const Value: TGridLine);
begin
if Value = nil then
begin
if FGridConctrler.FDrawed then
FGridConctrler.ClearDraw ;
FGridConctrler.DelAControl(self);
FGridConctrler.ReDraw ;
FGridConctrler := Value;
end
else begin
FGridConctrler := Value;
FGridConctrler.AddAControl(Self);
FGridConctrler.ReDraw ;
end;
end;
procedure TMyLabel.SetHeight(const Value: integer);
begin
if FGridConctrler <> nil then
if FGridConctrler.FDrawed then
FGridConctrler.ClearDraw ;
inherited Height := Value ;
end;
procedure TMyLabel.SetLeft(const Value: integer);
begin
if FGridConctrler <> nil then
begin
// if FGridConctrler.FDrawed then
FGridConctrler.ClearDraw ;
Parent.Invalidate ;
end;
inherited Left := Value ;
end;
procedure TMyLabel.SetParent(AParent: TWinControl);
begin
inherited;
FParentForm := Parent; //GetParentForm(Self);
end;
procedure TMyLabel.SetTGridCellLines(const Value: TGridCellLines);
begin
if FGridConctrler <> nil then
FGridConctrler.ReDraw ;
FTGridCellLines := Value;
end;
{ TGridLine }
procedure TGridLine.AddAControl(Value: TControl);
var
i: integer;
begin
if Value = nil then exit;
if (Value is TMyDBEdit) or (Value is TMyLabel) then
begin
i := Length(FInnerConctrl);
if i = 0 then
begin
i := Length(FInnerConctrl);
SetLength(FInnerConctrl, i + 1);
FInnerConctrl := Value ;
end
else begin
if Value.Parent <> FInnerConctrl[0].Parent then
raise Exception.Create('加入的组件: '+Value.Name + ' 与其他组件不在同一容器')
else begin
for i := 0 to i do
if FInnerConctrl = Value then exit;
i := Length(FInnerConctrl);
SetLength(FInnerConctrl, i + 1);
FInnerConctrl := Value ;
end;
end;
if Value is TMyDBEdit then
TMyDBEdit(Value).FGridConctrler := Self
else
TMyLabel(Value).FGridConctrler := Self;
end;
end;
procedure TGridLine.ClearDraw;
var
i: integer;
Edit: TMyDBEdit ;
Lbl: TMyLabel ;
begin
FCanvas.Pen.Color := FClearColor ;
FCanvas.Handle := GetDC(FInnerConctrl[0].Parent.Handle);
FCanvas.MoveTo(FBorderRect.Left ,FBorderRect.Top );
FCanvas.LineTo(FBorderRect.Right ,FBorderRect.Top );
FCanvas.LineTo(FBorderRect.Right ,FBorderRect.Bottom );
FCanvas.LineTo(FBorderRect.Left ,FBorderRect.Bottom );
FCanvas.LineTo(FBorderRect.Left ,FBorderRect.Top );
for i := 0 to High(FInnerConctrl) do
begin
if FInnerConctrl is TMyDBEdit then
begin
Edit := TMyDBEdit(FInnerConctrl);
if gclLeft in Edit.GridCellLine then
begin
FCanvas.MoveTo(Edit.Left - FILLeftOffset , FBorderRect.Top);
FCanvas.LineTo(Edit.Left - FILLeftOffset, FBorderRect.Bottom);
end;
if gclTop in Edit.GridCellLine then
begin
FCanvas.MoveTo(FBorderRect.Left, Edit.Top - FILTopOffset );
FCanvas.LineTo(FBorderRect.Right, Edit.Top - FILTopOffset);
end;
if gclRight in Edit.GridCellLine then
begin
FCanvas.MoveTo(Edit.Left + Edit.Width + FILRightOffset , FBorderRect.Top);
FCanvas.LineTo(Edit.Left + Edit.Width + FILRightOffset, FBorderRect.Bottom);
end;
if gclBottom in Edit.GridCellLine then
begin
FCanvas.MoveTo(FBorderRect.Left, Edit.Top + Edit.Height + FILBottomOffset );
FCanvas.LineTo(FBorderRect.Right, Edit.Top + Edit.Height + FILBottomOffset);
end;
end;
if FInnerConctrl is TMyLabel then
begin
Lbl := TMyLabel(FInnerConctrl);
if gclLeft in Lbl.GridCellLine then
begin
FCanvas.MoveTo(Lbl.Left - FILLeftOffset , FBorderRect.Top);
FCanvas.LineTo(Lbl.Left - FILLeftOffset, FBorderRect.Bottom);
end;
if gclTop in Lbl.GridCellLine then
begin
FCanvas.MoveTo(FBorderRect.Left, Lbl.Top - FILTopOffset );
FCanvas.LineTo(FBorderRect.Right, Lbl.Top - FILTopOffset);
end;
if gclRight in Lbl.GridCellLine then
begin
FCanvas.MoveTo(Lbl.Left + Lbl.Width + FILRightOffset , FBorderRect.Top);
FCanvas.LineTo(Lbl.Left + Lbl.Width + FILRightOffset, FBorderRect.Bottom);
end;
if gclBottom in Lbl.GridCellLine then
begin
FCanvas.MoveTo(FBorderRect.Left, Lbl.Top + Lbl.Height + FILBottomOffset );
FCanvas.LineTo(FBorderRect.Right, Lbl.Top + Lbl.Height + FILBottomOffset);
end;
end;
end;
end;
constructor TGridLine.Create(AWOner: TComponent);
begin
inherited Create(AWOner);
FLeftTopControl := nil;
FRithtBottomControl := nil;
SetLength(FInnerConctrl ,0);
FDraw := False;
FBorderSeted := false;
FCanvas := TCanvas.Create ;
FILLeftOffset := 10;
FILTopOffset := 10;
FILRightOffset := 10;
FILBottomOffset := 0;
FOLLeftOffset := 10;
FOLTopOffset := 10;
FOLRightOffset := 10;
FOLBottomOffset := 10;
FBorderColor := clBlack;
FInnerLineColor := clGray;
FDrawed := false;
FClearColor := -1;
end;
procedure TGridLine.DelAControl(const Value: TControl);
var
i, j: integer;
begin
j := -1;
for i := 0 to High(FInnerConctrl ) do
begin
if FInnerConctrl = Value then
begin
FInnerConctrl := nil;
j := i;
Break ;
end;
end;
if j <> -1 then
begin
for i := j to High(FInnerConctrl ) - 1 do
FInnerConctrl := FInnerConctrl[i + 1];
SetLength(FInnerConctrl ,Length(FInnerConctrl) -1);
end;
end;
destructor TGridLine.Destroy;
begin
FCanvas.Free ;
inherited;
end;
procedure TGridLine.DoDraw;
var
i: integer;
Edit: TMyDBEdit ;
Lbl: TMyLabel ;
begin
if not (FDraw or FDrawed) then exit;
if FDrawed then
ClearDraw ;
if FDraw then
begin
if (FLeftTopControl <> nil) and (FRithtBottomControl <> nil) then
begin
FBorderRect.Left := FLeftTopControl.Left - FOLLeftOffset ;
FBorderRect.Top := FLeftTopControl.Top - FOLTopOffset ;
FBorderRect.Right := FRithtBottomControl.Left + FRithtBottomControl.Width + FOLRightOffset ;
FBorderRect.Bottom := FRithtBottomControl.Top + FRithtBottomControl.Height + FOLBottomOffset ;
FBorderSeted := true;
end
else begin
FBorderSeted := false;
if not (csLoading in ComponentState) then
FDraw := false;
end;
if FBorderSeted then
begin
FClearColor := TEdit(FLeftTopControl.Parent).Color ;
FDrawed := true;
FCanvas.Handle := GetDC(FLeftTopControl.Parent.Handle);
FCanvas.Pen.Color := FBorderColor ;
FCanvas.MoveTo(FBorderRect.Left ,FBorderRect.Top );
FCanvas.LineTo(FBorderRect.Right ,FBorderRect.Top );
FCanvas.LineTo(FBorderRect.Right ,FBorderRect.Bottom );
FCanvas.LineTo(FBorderRect.Left ,FBorderRect.Bottom );
FCanvas.LineTo(FBorderRect.Left ,FBorderRect.Top );
FCanvas.Pen.Color := FInnerLineColor ;
for i := 0 to High(FInnerConctrl) do
begin
if FInnerConctrl is TMyDBEdit then
begin
Edit := TMyDBEdit(FInnerConctrl);
if gclLeft in Edit.GridCellLine then
begin
FCanvas.MoveTo(Edit.Left - FILLeftOffset , FBorderRect.Top);
FCanvas.LineTo(Edit.Left - FILLeftOffset, FBorderRect.Bottom);
end;
if gclTop in Edit.GridCellLine then
begin
FCanvas.MoveTo(FBorderRect.Left, Edit.Top - FILTopOffset );
FCanvas.LineTo(FBorderRect.Right, Edit.Top - FILTopOffset);
end;
if gclRight in Edit.GridCellLine then
begin
FCanvas.MoveTo(Edit.Left + Edit.Width + FILRightOffset , FBorderRect.Top);
FCanvas.LineTo(Edit.Left + Edit.Width + FILRightOffset, FBorderRect.Bottom);
end;
if gclBottom in Edit.GridCellLine then
begin
FCanvas.MoveTo(FBorderRect.Left, Edit.Top + Edit.Height + FILBottomOffset );
FCanvas.LineTo(FBorderRect.Right, Edit.Top + Edit.Height + FILBottomOffset);
end;
end;
if FInnerConctrl is TMyLabel then
begin
Lbl := TMyLabel(FInnerConctrl);
if gclLeft in Lbl.GridCellLine then
begin
FCanvas.MoveTo(Lbl.Left - FILLeftOffset , FBorderRect.Top);
FCanvas.LineTo(Lbl.Left - FILLeftOffset, FBorderRect.Bottom);
end;
if gclTop in Lbl.GridCellLine then
begin
FCanvas.MoveTo(FBorderRect.Left, Lbl.Top - FILTopOffset );
FCanvas.LineTo(FBorderRect.Right, Lbl.Top - FILTopOffset);
end;
if gclRight in Lbl.GridCellLine then
begin
FCanvas.MoveTo(Lbl.Left + Lbl.Width + FILRightOffset , FBorderRect.Top);
FCanvas.LineTo(Lbl.Left + Lbl.Width + FILRightOffset, FBorderRect.Bottom);
end;
if gclBottom in Lbl.GridCellLine then
begin
FCanvas.MoveTo(FBorderRect.Left, Lbl.Top + Lbl.Height + FILBottomOffset );
FCanvas.LineTo(FBorderRect.Right, Lbl.Top + Lbl.Height + FILBottomOffset);
end;
end;
end;
end;
end;
end;
procedure TGridLine.ReDraw;
begin
DoDraw ;
end;
procedure TGridLine.SetBorderColor(const Value: TColor);
begin
FBorderColor := Value;
DoDraw ;
end;
procedure TGridLine.SetDraw(const Value: boolean);
begin
FDraw := Value;
DoDraw ;
end;
procedure TGridLine.SetILBottomOffset(const Value: integer);
begin
if FDrawed then ClearDraw;
FILBottomOffset := Value;
DoDraw;
end;
procedure TGridLine.SetILLeftOffset(const Value: integer);
begin
if FDrawed then ClearDraw;
FILLeftOffset := Value;
DoDraw;
end;
procedure TGridLine.SetILRightOffset(const Value: integer);
begin
if FDrawed then ClearDraw;
FILRightOffset := Value;
DoDraw;
end;
procedure TGridLine.SetILTopOffset(const Value: integer);
begin
if FDrawed then ClearDraw;
FILTopOffset := Value;
DoDraw;
end;
procedure TGridLine.SetInnerLineColor(const Value: TColor);
begin
FInnerLineColor := Value;
DoDraw;
end;
procedure TGridLine.SetLeftTopControl(const Value: TControl);
begin
if Value = nil then
begin
FLeftTopControl := nil;
DoDraw;
end
else begin
if (Value is TMyDBEdit) or (Value is TMyLabel) then
begin
if Value <> FLeftTopControl then
begin
if ((FRithtBottomControl <> nil) and (FRithtBottomControl.Parent <> Value.Parent )) or
((Length(FInnerConctrl ) > 0) and (FInnerConctrl[0].Parent <> Value.Parent)) then
raise Exception.Create('加入的组件: '+Value.Name + ' 与其他组件不在同一容器');
AddAControl(Value );
FLeftTopControl := Value;
DoDraw;
end;
end;
end;
DoDraw;
end;
procedure TGridLine.SetOLBottomOffset(const Value: integer);
begin
FOLBottomOffset := Value;
DoDraw;
end;
procedure TGridLine.SetOLLeftOffset(const Value: integer);
begin
FOLLeftOffset := Value;
DoDraw;
end;
procedure TGridLine.SetOLRightOffset(const Value: integer);
begin
FOLRightOffset := Value;
DoDraw;
end;
procedure TGridLine.SetOLTopOffset(const Value: integer);
begin
FOLTopOffset := Value;
DoDraw;
end;
procedure TGridLine.SetRithtBottomControl(const Value: TControl);
begin
if Value = nil then
begin
FRithtBottomControl := nil;
DoDraw;
end
else begin
if (Value is TMyDBEdit) or (Value is TMyLabel) then
begin
if Value <> FRithtBottomControl then
begin
if ((FLeftTopControl <> nil) and (FLeftTopControl.Parent <> Value.Parent )) or
((Length(FInnerConctrl ) > 0) and (FInnerConctrl[0].Parent <> Value.Parent)) then
raise Exception.Create('加入的组件: '+Value.Name + ' 与其他组件不在同一容器');
AddAControl(Value );
FRithtBottomControl := Value;
DoDraw;
end;
end;
end;
end;
procedure TMyLabel.SetTop(const Value: integer);
begin
if FGridConctrler <> nil then
if FGridConctrler.FDrawed then
FGridConctrler.ClearDraw ;
inherited Top := Value ;
end;
procedure TMyLabel.SetWidth(const Value: integer);
begin
if FGridConctrler <> nil then
if FGridConctrler.FDrawed then
FGridConctrler.ClearDraw ;
inherited Width := Value ;
end;
procedure TMyLabel.WMPaint(var Message: TWMPaint);
begin
inherited;
if (FGridConctrler <> nil) and FGridConctrler.FDraw then
FGridConctrler.ReDraw ;
end;
end.
TGridLine:负责画表格线,TComponent继承
LeftTopControl、RithtBottomControl记录了表格框的范围,这两个属性只接受TMyLabel、TMyDBEdit组件,以这两个组件为左上角、右下角画外框
ILLeftOffset。。。等???Offset属性是对表格线的位置的描述
Draw: boolean属性,是否画线
???Color属性是对线的颜色的描述
TMyLabel:TLabel继承,辅助画线。
GridCellLine: TGridCellLines属性,是TGridCellLine集合,描述组件四边是否画表格线
GridConctrler: TGridLine属性,记录所属的画线组件
TMyDBEdit:TDBEdit继承,辅助画线。
GridCellLine: TGridCellLines属性,是TGridCellLine集合,描述组件四边是否画表格线
GridConctrler: TGridLine属性,记录所属的画线组件
其他是属性不用多关注,改过一版,还有些没什么用的属性没去掉。
组件是这样工作的:
TGridLine记录下左上、右下角的组件,这样,表格的外框范围就定了,然后所有需要在这个范围内画线的组件(TMyLabel、TMyDBEdit)设置好GridConctrler属性,然后设置GridCellLine属性,TGridLine负责把这些组件四周的线条画出来。
这个组件主要是为了方便在设计时直接在ide中看到画线的效果,用TBevel虽也可画线条,但是TBevel一多,界面调整起来就很麻烦。
这个组件是项目里面临时起意写的,之前没写过多少组件,经验不足,写得很糟糕,这是改进了的,主要有以下几个问题:
1、不知如何获得TMyLabel、TMyDBEdit在ide中移动的事件。不知道怎样才能在ide中直观的看到效果,就把重画动作放在wm_paint消息中,外框有变量记录,可以在重画前把原来位置的线条给清楚,但是GridCellLine所描述的线条,似乎无法用重载Left等属性的方法来获得变化前的位置,所以,在移动这些组件时,界面上就留下了没有清除的残像了,how?
2、也是最严重的问题,我的同事用了我的组件画界面,用了段时间后,delphi就越来越慢(运行态没有这个问题,似乎只是对ide环境有影响),最后到无法忍受,不知道是哪里出了问题,内存似乎并没有消耗太多,这几个组件本身并没有额外申请内存,cpu占用率也没有100%,到底是哪些代码让delphi出了问题?这时只要关闭工程(不用关闭delphi),再打开工程,又好了,可用一段时间后,delphi有变慢了,真是头痛。
我对编写组件不熟,以前虽说写过几个组件,但感觉还是不够深入,比如写这样直接在设计时界面上可以看到效果的组件怎么调试之类的问题都不了解,希望对组件编程比较熟的朋友帮忙指导一下。
又:抱歉一下,时间原因,代码写的很匆忙,没写注释,感觉思路、结构还比较简单清楚,凑活着看看吧[]
unit MyDBCtrl;
interface
uses
Windows, Messages, Classes, SysUtils, Graphics, Forms, Controls, StdCtrls, DBCtrls;
type
TGridCellLine = (gclLeft, gclTop, gclRight, gclBottom);
TGridCellLines = set of TGridCellLine;
TVerifyType = (vtIdentityCard, vtDate);
TGridLine = class(TComponent )
private
FInnerConctrl: array of TControl ;
FBorderSeted: Boolean;
FBorderRect: TRect ;
FCanvas: TCanvas ;
FDrawed: boolean;
FClearColor: TColor ;
FDraw: boolean;
FILBottomOffset: integer;
FILRightOffset: integer;
FILTopOffset: integer;
FILLeftOffset: integer;
FInnerLineColor: TColor;
FBorderColor: TColor;
FRithtBottomControl: TControl;
FLeftTopControl: TControl;
FOLRightOffset: integer;
FOLLeftOffset: integer;
FOLTopOffset: integer;
FOLBottomOffset: integer;
procedure ClearDraw;
procedure DelAControl(const Value: TControl);
procedure SetBorderColor(const Value: TColor);
procedure SetDraw(const Value: boolean);
procedure SetILBottomOffset(const Value: integer);
procedure SetILLeftOffset(const Value: integer);
procedure SetILRightOffset(const Value: integer);
procedure SetILTopOffset(const Value: integer);
procedure SetInnerLineColor(const Value: TColor);
procedure SetLeftTopControl(const Value: TControl);
procedure SetRithtBottomControl(const Value: TControl);
procedure SetOLBottomOffset(const Value: integer);
procedure SetOLLeftOffset(const Value: integer);
procedure SetOLRightOffset(const Value: integer);
procedure SetOLTopOffset(const Value: integer);
protected
procedure DoDraw;virtual ;
public
constructor Create(AWOner: TComponent); override;
destructor Destroy; override;
procedure AddAControl(Value: TControl );
procedure ReDraw;
published
property LeftTopControl:TControl read FLeftTopControl write SetLeftTopControl;
property RithtBottomControl:TControl read FRithtBottomControl write SetRithtBottomControl;
property ILLeftOffset: integer read FILLeftOffset write SetILLeftOffset default 10;
property ILTopOffset: integer read FILTopOffset write SetILTopOffset default 10;
property ILRightOffset: integer read FILRightOffset write SetILRightOffset default 10;
property ILBottomOffset: integer read FILBottomOffset write SetILBottomOffset default 0;
property OLLeftOffset: integer read FOLLeftOffset write SetOLLeftOffset default 10;
property OLTopOffset: integer read FOLTopOffset write SetOLTopOffset default 10;
property OLRightOffset: integer read FOLRightOffset write SetOLRightOffset default 10;
property OLBottomOffset: integer read FOLBottomOffset write SetOLBottomOffset default 10;
property Draw: boolean read FDraw write SetDraw;
property BorderColor: TColor read FBorderColor write SetBorderColor default clBlack;
property InnerLineColor: TColor read FInnerLineColor write SetInnerLineColor default clGray;
end;
TMyLabel = class(TLabel)
private
FTGridCellLines: TGridCellLines;
FIsLeftTop: boolean;
FIsRightBottom: boolean;
FParentForm: TWinControl; //TCustomForm;
FBorderColor: TColor;
FGridCellLineColor: TColor;
FGridConctrler: TGridLine;
procedure SetTGridCellLines(const Value: TGridCellLines);
procedure SetGridCellLineColor(const Value: TColor);
procedure SeTGridLine(const Value: TGridLine);
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
function GetHeight: integer;
function GetLeft: integer;
function GetTop: integer;
function GetWidth: integer;
procedure SetHeight(const Value: integer);
procedure SetLeft(const Value: integer);
procedure SetTop(const Value: integer);
procedure SetWidth(const Value: integer);
protected
procedure SetParent(AParent: TWinControl); override;
public
constructor Create(AWOner: TComponent); override;
published
property GridCellLine: TGridCellLines read FTGridCellLines write SetTGridCellLines default [];
property GridCellLineColor: TColor read FGridCellLineColor write SetGridCellLineColor default clBlack;
property GridConctrler: TGridLine read FGridConctrler write SeTGridLine;
property Left: integer read GetLeft write SetLeft;
property Top: integer read GetTop write SetTop;
property Width: integer read GetWidth write SetWidth;
property Height: integer read GetHeight write SetHeight;
end;
TMyDBEdit = class(TDBEdit)
private
FPropertyCode: string;
FUnderLine: Boolean;
FUnderLineColor: TColor;
FParentForm: TWinControl; // TCustomForm;
FTGridCellLines: TGridCellLines;
FIsLeftTop: boolean;
FIsRightBottom: boolean;
FBorderColor: TColor;
FGridCellLineColor: TColor;
FNotNull: boolean;
FVerifyType: TVerifyType;
FGridConctrler: TGridLine;
procedure SetPropertyCode(const Value: string);
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure SetUnderLine(const Value: Boolean);
procedure SetUnderLineColor(const Value: TColor);
procedure SetTGridCellLines(const Value: TGridCellLines);
procedure SetGridCellLineColor(const Value: TColor);
procedure SetNotNull(const Value: boolean);
procedure SetVerifyType(const Value: TVerifyType);
procedure SeTGridLine(const Value: TGridLine);
function GetHeight: integer;
function GetLeft: integer;
function GetTop: integer;
function GetWidth: integer;
procedure SetHeight(const Value: integer);
procedure SetLeft(const Value: integer);
procedure SetTop(const Value: integer);
procedure SetWidth(const Value: integer);
protected
procedure DrawUnderLine;
procedure SetParent(AParent: TWinControl); override;
published
property PropertyCode: string read FPropertyCode write SetPropertyCode;
property UnderLine: Boolean read FUnderLine write SetUnderLine default False;
property UnderLineColor: TColor read FUnderLineColor write SetUnderLineColor default clBlack;
property GridCellLine: TGridCellLines read FTGridCellLines write SetTGridCellLines default [];
property GridCellLineColor: TColor read FGridCellLineColor write SetGridCellLineColor default clBlack;
property NotNull: boolean read FNotNull write SetNotNull default false;
property VerifyType:TVerifyType read FVerifyType write SetVerifyType;
property GridConctrler: TGridLine read FGridConctrler write SeTGridLine;
property Left: integer read GetLeft write SetLeft;
property Top: integer read GetTop write SetTop;
property Width: integer read GetWidth write SetWidth;
property Height: integer read GetHeight write SetHeight;
property Text;
public
constructor Create(AWOner: TComponent); override;
end;
procedure Register;
procedure DrawAll(Value: TControl );
const
cNotNullUC: TColor = clRed; //必须输入项的下划线颜色
cReadOnlyUC: TColor = clBlue; //只读输入项的下划线颜色
implementation
procedure Register;
begin
RegisterComponents('Samples', [TMyDBEdit, TMyLabel,TGridLine]);
end;
{ TMyDBEdit }
procedure DrawAll(Value: TControl );
var
i: integer;
begin
for i := 0 to Value.ComponentCount - 1 do
begin
if Value.Components is TGridLine then
TGridLine(Value.Components).ReDraw ;
end;
end;
constructor TMyDBEdit.Create(AWOner: TComponent);
begin
inherited;
FPropertyCode := '';
FTGridCellLines := [];
FParentForm := nil;
FUnderLine := false;
FUnderLineColor := clBlack;
FIsLeftTop := False;
FIsRightBottom := False;
FBorderColor := clBlack;
FGridCellLineColor := clBlack;
FNotNull := false;
FGridConctrler := nil;
end;
procedure TMyDBEdit.DrawUnderLine;
const
cUOffset = 15;
var
c: TCanvas;
begin
c := TCanvas.Create;
try
c.Handle := GetDC(Handle);
c.MoveTo(0, cUOffset);
if FUnderLine then
begin
if FNotNull then
c.Pen.Color := cNotNullUC
else
if ReadOnly then
c.Pen.Color := cReadOnlyUC
else
c.Pen.Color := FUnderLineColor;
end
else
c.Pen.Color := Color;
c.LineTo(Width, cUOffset);
finally
c.Free;
end;
end;
function TMyDBEdit.GetHeight: integer;
begin
Result := inherited Height;
end;
function TMyDBEdit.GetLeft: integer;
begin
Result := inherited Left;
end;
function TMyDBEdit.GetTop: integer;
begin
Result := inherited Top;
end;
function TMyDBEdit.GetWidth: integer;
begin
Result := inherited Width;
end;
procedure TMyDBEdit.SetGridCellLineColor(const Value: TColor);
begin
FGridCellLineColor := Value;
end;
procedure TMyDBEdit.SeTGridLine(const Value: TGridLine);
begin
if Value = nil then
begin
if FGridConctrler.FDrawed then
FGridConctrler.ClearDraw ;
FGridConctrler.DelAControl(self);
FGridConctrler.ReDraw ;
FGridConctrler := Value;
end
else begin
FGridConctrler := Value;
FGridConctrler.AddAControl(Self);
FGridConctrler.ReDraw ;
end;
end;
procedure TMyDBEdit.SetHeight(const Value: integer);
begin
if FGridConctrler <> nil then
if FGridConctrler.FDrawed then
FGridConctrler.ClearDraw ;
inherited Height := Value ;
end;
procedure TMyDBEdit.SetLeft(const Value: integer);
begin
if FGridConctrler <> nil then
if FGridConctrler.FDrawed then
FGridConctrler.ClearDraw ;
inherited Left := Value ;
end;
procedure TMyDBEdit.SetNotNull(const Value: boolean);
begin
FNotNull := Value;
end;
procedure TMyDBEdit.SetParent(AParent: TWinControl);
begin
inherited;
FParentForm := Parent; // GetParentForm(Self);
end;
procedure TMyDBEdit.SetPropertyCode(const Value: string);
begin
FPropertyCode := Value;
end;
procedure TMyDBEdit.SetTGridCellLines(const Value: TGridCellLines);
begin
if FGridConctrler <> nil then
FGridConctrler.ReDraw ;
FTGridCellLines := Value;
end;
procedure TMyDBEdit.SetTop(const Value: integer);
begin
if FGridConctrler <> nil then
if FGridConctrler.FDrawed then
FGridConctrler.ClearDraw ;
inherited Top := Value ;
end;
procedure TMyDBEdit.SetUnderLine(const Value: Boolean);
begin
FUnderLine := Value;
if FUnderLine then
begin
ParentColor := true;
BorderStyle := bsNone;
BevelEdges := [];
BevelKind := bkNone;
Ctl3D := false;
end;
DrawUnderLine
end;
procedure TMyDBEdit.SetUnderLineColor(const Value: TColor);
begin
FUnderLineColor := Value;
if FUnderLine then
DrawUnderLine;
end;
procedure TMyDBEdit.SetVerifyType(const Value: TVerifyType);
begin
FVerifyType := Value;
end;
procedure TMyDBEdit.SetWidth(const Value: integer);
begin
if FGridConctrler <> nil then
if FGridConctrler.FDrawed then
FGridConctrler.ClearDraw ;
inherited Width := Value ;
end;
procedure TMyDBEdit.WMPaint(var Message: TWMPaint);
begin
inherited;
if FUnderLine then
DrawUnderLine;
if (FGridConctrler <> nil) and FGridConctrler.FDraw then
FGridConctrler.ReDraw ;
end;
{ TMyLabel }
constructor TMyLabel.Create(AWOner: TComponent);
begin
inherited;
FTGridCellLines := [];
FParentForm := nil;
FIsLeftTop := False;
FIsRightBottom := False;
FBorderColor := clBlack;
FGridCellLineColor := clBlack;
FGridConctrler := nil;
end;
function TMyLabel.GetHeight: integer;
begin
Result := inherited Height;
end;
function TMyLabel.GetLeft: integer;
begin
Result := inherited Left;
end;
function TMyLabel.GetTop: integer;
begin
Result := inherited Top;
end;
function TMyLabel.GetWidth: integer;
begin
Result := inherited Width;
end;
procedure TMyLabel.SetGridCellLineColor(const Value: TColor);
begin
FGridCellLineColor := Value;
end;
procedure TMyLabel.SeTGridLine(const Value: TGridLine);
begin
if Value = nil then
begin
if FGridConctrler.FDrawed then
FGridConctrler.ClearDraw ;
FGridConctrler.DelAControl(self);
FGridConctrler.ReDraw ;
FGridConctrler := Value;
end
else begin
FGridConctrler := Value;
FGridConctrler.AddAControl(Self);
FGridConctrler.ReDraw ;
end;
end;
procedure TMyLabel.SetHeight(const Value: integer);
begin
if FGridConctrler <> nil then
if FGridConctrler.FDrawed then
FGridConctrler.ClearDraw ;
inherited Height := Value ;
end;
procedure TMyLabel.SetLeft(const Value: integer);
begin
if FGridConctrler <> nil then
begin
// if FGridConctrler.FDrawed then
FGridConctrler.ClearDraw ;
Parent.Invalidate ;
end;
inherited Left := Value ;
end;
procedure TMyLabel.SetParent(AParent: TWinControl);
begin
inherited;
FParentForm := Parent; //GetParentForm(Self);
end;
procedure TMyLabel.SetTGridCellLines(const Value: TGridCellLines);
begin
if FGridConctrler <> nil then
FGridConctrler.ReDraw ;
FTGridCellLines := Value;
end;
{ TGridLine }
procedure TGridLine.AddAControl(Value: TControl);
var
i: integer;
begin
if Value = nil then exit;
if (Value is TMyDBEdit) or (Value is TMyLabel) then
begin
i := Length(FInnerConctrl);
if i = 0 then
begin
i := Length(FInnerConctrl);
SetLength(FInnerConctrl, i + 1);
FInnerConctrl := Value ;
end
else begin
if Value.Parent <> FInnerConctrl[0].Parent then
raise Exception.Create('加入的组件: '+Value.Name + ' 与其他组件不在同一容器')
else begin
for i := 0 to i do
if FInnerConctrl = Value then exit;
i := Length(FInnerConctrl);
SetLength(FInnerConctrl, i + 1);
FInnerConctrl := Value ;
end;
end;
if Value is TMyDBEdit then
TMyDBEdit(Value).FGridConctrler := Self
else
TMyLabel(Value).FGridConctrler := Self;
end;
end;
procedure TGridLine.ClearDraw;
var
i: integer;
Edit: TMyDBEdit ;
Lbl: TMyLabel ;
begin
FCanvas.Pen.Color := FClearColor ;
FCanvas.Handle := GetDC(FInnerConctrl[0].Parent.Handle);
FCanvas.MoveTo(FBorderRect.Left ,FBorderRect.Top );
FCanvas.LineTo(FBorderRect.Right ,FBorderRect.Top );
FCanvas.LineTo(FBorderRect.Right ,FBorderRect.Bottom );
FCanvas.LineTo(FBorderRect.Left ,FBorderRect.Bottom );
FCanvas.LineTo(FBorderRect.Left ,FBorderRect.Top );
for i := 0 to High(FInnerConctrl) do
begin
if FInnerConctrl is TMyDBEdit then
begin
Edit := TMyDBEdit(FInnerConctrl);
if gclLeft in Edit.GridCellLine then
begin
FCanvas.MoveTo(Edit.Left - FILLeftOffset , FBorderRect.Top);
FCanvas.LineTo(Edit.Left - FILLeftOffset, FBorderRect.Bottom);
end;
if gclTop in Edit.GridCellLine then
begin
FCanvas.MoveTo(FBorderRect.Left, Edit.Top - FILTopOffset );
FCanvas.LineTo(FBorderRect.Right, Edit.Top - FILTopOffset);
end;
if gclRight in Edit.GridCellLine then
begin
FCanvas.MoveTo(Edit.Left + Edit.Width + FILRightOffset , FBorderRect.Top);
FCanvas.LineTo(Edit.Left + Edit.Width + FILRightOffset, FBorderRect.Bottom);
end;
if gclBottom in Edit.GridCellLine then
begin
FCanvas.MoveTo(FBorderRect.Left, Edit.Top + Edit.Height + FILBottomOffset );
FCanvas.LineTo(FBorderRect.Right, Edit.Top + Edit.Height + FILBottomOffset);
end;
end;
if FInnerConctrl is TMyLabel then
begin
Lbl := TMyLabel(FInnerConctrl);
if gclLeft in Lbl.GridCellLine then
begin
FCanvas.MoveTo(Lbl.Left - FILLeftOffset , FBorderRect.Top);
FCanvas.LineTo(Lbl.Left - FILLeftOffset, FBorderRect.Bottom);
end;
if gclTop in Lbl.GridCellLine then
begin
FCanvas.MoveTo(FBorderRect.Left, Lbl.Top - FILTopOffset );
FCanvas.LineTo(FBorderRect.Right, Lbl.Top - FILTopOffset);
end;
if gclRight in Lbl.GridCellLine then
begin
FCanvas.MoveTo(Lbl.Left + Lbl.Width + FILRightOffset , FBorderRect.Top);
FCanvas.LineTo(Lbl.Left + Lbl.Width + FILRightOffset, FBorderRect.Bottom);
end;
if gclBottom in Lbl.GridCellLine then
begin
FCanvas.MoveTo(FBorderRect.Left, Lbl.Top + Lbl.Height + FILBottomOffset );
FCanvas.LineTo(FBorderRect.Right, Lbl.Top + Lbl.Height + FILBottomOffset);
end;
end;
end;
end;
constructor TGridLine.Create(AWOner: TComponent);
begin
inherited Create(AWOner);
FLeftTopControl := nil;
FRithtBottomControl := nil;
SetLength(FInnerConctrl ,0);
FDraw := False;
FBorderSeted := false;
FCanvas := TCanvas.Create ;
FILLeftOffset := 10;
FILTopOffset := 10;
FILRightOffset := 10;
FILBottomOffset := 0;
FOLLeftOffset := 10;
FOLTopOffset := 10;
FOLRightOffset := 10;
FOLBottomOffset := 10;
FBorderColor := clBlack;
FInnerLineColor := clGray;
FDrawed := false;
FClearColor := -1;
end;
procedure TGridLine.DelAControl(const Value: TControl);
var
i, j: integer;
begin
j := -1;
for i := 0 to High(FInnerConctrl ) do
begin
if FInnerConctrl = Value then
begin
FInnerConctrl := nil;
j := i;
Break ;
end;
end;
if j <> -1 then
begin
for i := j to High(FInnerConctrl ) - 1 do
FInnerConctrl := FInnerConctrl[i + 1];
SetLength(FInnerConctrl ,Length(FInnerConctrl) -1);
end;
end;
destructor TGridLine.Destroy;
begin
FCanvas.Free ;
inherited;
end;
procedure TGridLine.DoDraw;
var
i: integer;
Edit: TMyDBEdit ;
Lbl: TMyLabel ;
begin
if not (FDraw or FDrawed) then exit;
if FDrawed then
ClearDraw ;
if FDraw then
begin
if (FLeftTopControl <> nil) and (FRithtBottomControl <> nil) then
begin
FBorderRect.Left := FLeftTopControl.Left - FOLLeftOffset ;
FBorderRect.Top := FLeftTopControl.Top - FOLTopOffset ;
FBorderRect.Right := FRithtBottomControl.Left + FRithtBottomControl.Width + FOLRightOffset ;
FBorderRect.Bottom := FRithtBottomControl.Top + FRithtBottomControl.Height + FOLBottomOffset ;
FBorderSeted := true;
end
else begin
FBorderSeted := false;
if not (csLoading in ComponentState) then
FDraw := false;
end;
if FBorderSeted then
begin
FClearColor := TEdit(FLeftTopControl.Parent).Color ;
FDrawed := true;
FCanvas.Handle := GetDC(FLeftTopControl.Parent.Handle);
FCanvas.Pen.Color := FBorderColor ;
FCanvas.MoveTo(FBorderRect.Left ,FBorderRect.Top );
FCanvas.LineTo(FBorderRect.Right ,FBorderRect.Top );
FCanvas.LineTo(FBorderRect.Right ,FBorderRect.Bottom );
FCanvas.LineTo(FBorderRect.Left ,FBorderRect.Bottom );
FCanvas.LineTo(FBorderRect.Left ,FBorderRect.Top );
FCanvas.Pen.Color := FInnerLineColor ;
for i := 0 to High(FInnerConctrl) do
begin
if FInnerConctrl is TMyDBEdit then
begin
Edit := TMyDBEdit(FInnerConctrl);
if gclLeft in Edit.GridCellLine then
begin
FCanvas.MoveTo(Edit.Left - FILLeftOffset , FBorderRect.Top);
FCanvas.LineTo(Edit.Left - FILLeftOffset, FBorderRect.Bottom);
end;
if gclTop in Edit.GridCellLine then
begin
FCanvas.MoveTo(FBorderRect.Left, Edit.Top - FILTopOffset );
FCanvas.LineTo(FBorderRect.Right, Edit.Top - FILTopOffset);
end;
if gclRight in Edit.GridCellLine then
begin
FCanvas.MoveTo(Edit.Left + Edit.Width + FILRightOffset , FBorderRect.Top);
FCanvas.LineTo(Edit.Left + Edit.Width + FILRightOffset, FBorderRect.Bottom);
end;
if gclBottom in Edit.GridCellLine then
begin
FCanvas.MoveTo(FBorderRect.Left, Edit.Top + Edit.Height + FILBottomOffset );
FCanvas.LineTo(FBorderRect.Right, Edit.Top + Edit.Height + FILBottomOffset);
end;
end;
if FInnerConctrl is TMyLabel then
begin
Lbl := TMyLabel(FInnerConctrl);
if gclLeft in Lbl.GridCellLine then
begin
FCanvas.MoveTo(Lbl.Left - FILLeftOffset , FBorderRect.Top);
FCanvas.LineTo(Lbl.Left - FILLeftOffset, FBorderRect.Bottom);
end;
if gclTop in Lbl.GridCellLine then
begin
FCanvas.MoveTo(FBorderRect.Left, Lbl.Top - FILTopOffset );
FCanvas.LineTo(FBorderRect.Right, Lbl.Top - FILTopOffset);
end;
if gclRight in Lbl.GridCellLine then
begin
FCanvas.MoveTo(Lbl.Left + Lbl.Width + FILRightOffset , FBorderRect.Top);
FCanvas.LineTo(Lbl.Left + Lbl.Width + FILRightOffset, FBorderRect.Bottom);
end;
if gclBottom in Lbl.GridCellLine then
begin
FCanvas.MoveTo(FBorderRect.Left, Lbl.Top + Lbl.Height + FILBottomOffset );
FCanvas.LineTo(FBorderRect.Right, Lbl.Top + Lbl.Height + FILBottomOffset);
end;
end;
end;
end;
end;
end;
procedure TGridLine.ReDraw;
begin
DoDraw ;
end;
procedure TGridLine.SetBorderColor(const Value: TColor);
begin
FBorderColor := Value;
DoDraw ;
end;
procedure TGridLine.SetDraw(const Value: boolean);
begin
FDraw := Value;
DoDraw ;
end;
procedure TGridLine.SetILBottomOffset(const Value: integer);
begin
if FDrawed then ClearDraw;
FILBottomOffset := Value;
DoDraw;
end;
procedure TGridLine.SetILLeftOffset(const Value: integer);
begin
if FDrawed then ClearDraw;
FILLeftOffset := Value;
DoDraw;
end;
procedure TGridLine.SetILRightOffset(const Value: integer);
begin
if FDrawed then ClearDraw;
FILRightOffset := Value;
DoDraw;
end;
procedure TGridLine.SetILTopOffset(const Value: integer);
begin
if FDrawed then ClearDraw;
FILTopOffset := Value;
DoDraw;
end;
procedure TGridLine.SetInnerLineColor(const Value: TColor);
begin
FInnerLineColor := Value;
DoDraw;
end;
procedure TGridLine.SetLeftTopControl(const Value: TControl);
begin
if Value = nil then
begin
FLeftTopControl := nil;
DoDraw;
end
else begin
if (Value is TMyDBEdit) or (Value is TMyLabel) then
begin
if Value <> FLeftTopControl then
begin
if ((FRithtBottomControl <> nil) and (FRithtBottomControl.Parent <> Value.Parent )) or
((Length(FInnerConctrl ) > 0) and (FInnerConctrl[0].Parent <> Value.Parent)) then
raise Exception.Create('加入的组件: '+Value.Name + ' 与其他组件不在同一容器');
AddAControl(Value );
FLeftTopControl := Value;
DoDraw;
end;
end;
end;
DoDraw;
end;
procedure TGridLine.SetOLBottomOffset(const Value: integer);
begin
FOLBottomOffset := Value;
DoDraw;
end;
procedure TGridLine.SetOLLeftOffset(const Value: integer);
begin
FOLLeftOffset := Value;
DoDraw;
end;
procedure TGridLine.SetOLRightOffset(const Value: integer);
begin
FOLRightOffset := Value;
DoDraw;
end;
procedure TGridLine.SetOLTopOffset(const Value: integer);
begin
FOLTopOffset := Value;
DoDraw;
end;
procedure TGridLine.SetRithtBottomControl(const Value: TControl);
begin
if Value = nil then
begin
FRithtBottomControl := nil;
DoDraw;
end
else begin
if (Value is TMyDBEdit) or (Value is TMyLabel) then
begin
if Value <> FRithtBottomControl then
begin
if ((FLeftTopControl <> nil) and (FLeftTopControl.Parent <> Value.Parent )) or
((Length(FInnerConctrl ) > 0) and (FInnerConctrl[0].Parent <> Value.Parent)) then
raise Exception.Create('加入的组件: '+Value.Name + ' 与其他组件不在同一容器');
AddAControl(Value );
FRithtBottomControl := Value;
DoDraw;
end;
end;
end;
end;
procedure TMyLabel.SetTop(const Value: integer);
begin
if FGridConctrler <> nil then
if FGridConctrler.FDrawed then
FGridConctrler.ClearDraw ;
inherited Top := Value ;
end;
procedure TMyLabel.SetWidth(const Value: integer);
begin
if FGridConctrler <> nil then
if FGridConctrler.FDrawed then
FGridConctrler.ClearDraw ;
inherited Width := Value ;
end;
procedure TMyLabel.WMPaint(var Message: TWMPaint);
begin
inherited;
if (FGridConctrler <> nil) and FGridConctrler.FDraw then
FGridConctrler.ReDraw ;
end;
end.