自己写控件,请帮忙看一下.(100分)

  • 主题发起人 主题发起人 houtor
  • 开始时间 开始时间
H

houtor

Unregistered / Unconfirmed
GUEST, unregistred user!
看了别人写的一个书标控件(代码如下),但是有问题,就是当有窗体打开复盖这个控失件后,再返回.颜色就变了,变成白色,如果没有另一个窗体没有复盖完这个书标控件,就是白了复盖那一部分,导致很难看,如何改进?
unit BookLaber;

interface

uses
SysUtils, Classes, Controls,Graphics, Messages,windows;
const
Rad = 0.4142;

type
TBookLaber = class(TCustomControl)
private
FAlignment: TAlignment;
FAnySize: integer;
FTopStr:string;
FCentStr:string;
FDownStr:string;
FDrawLine: boolean;
FframeWidth: integer;
FLineWidth: integer;
FBackColor:Tcolor;
FframeColor:Tcolor;
FFont:Tfont;
FLineColor:Tcolor;
FuserPen:Tpen;
FLineHeight: integer;
function GetBackColor: TColor;
function GetDownStr: string;
function GetCentStr: string;
function GetFont: Tfont;
function GetFrameColor: Tcolor;
function GetTopStr: string;
procedure SetBackColor(const Value: TColor);
procedure SetDownStr(const Value: string);
procedure SetCentStr(const Value: string);
procedure SetFont(const Value: Tfont);
procedure SetFrameColor(const Value: Tcolor);
procedure SetTopStr(const Value: string);
function GetLineColor: Tcolor;
procedure SetLineColor(const Value: Tcolor);
procedure WMPAINT(var Msg : TMessage); message WM_PAINT;
procedure WMEARSEBKGND(var Msg : TMessage); message WM_ERASEBKGND;

procedure DrawShape(ASize,OffW:integer;Acolor:Tcolor);
procedure DrawMidLine;
procedure DrawTxt;
function CalcSize(FrameWidth:integer):integer;
procedure SetDrawLine(const Value: boolean);
procedure SetAnySize(const Value: integer);
procedure SetLineWidth(const Value: integer);
{ Private declarations }
protected
{ Protected declarations }
public
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
{ Public declarations }
published
property FrameColor : Tcolor read GetFrameColor write SetFrameColor;
property BackColor : TColor read GetBackColor write SetBackColor;
// property Font : Tfont read GetFont write SetFont;
property AnySize : integer read FAnySize write SetAnySize;
property TopStr : string read GetTopStr write SetTopStr;
property CentStr : string read GetCentStr write SetCentStr;
property DownStr : string read GetDownStr write SetDownStr;
property DrawLine :boolean read FDrawLine write SetDrawLine;
property LineWidth :integer read FLineWidth write SetLineWidth;
property LineHeight :integer read FLineHeight write FLineHeight;
property LineColor :Tcolor read GetLineColor write SetLineColor;
property FrameWidth:integer read FframeWidth write FframeWidth;
property Font;
property OnClick;
{ Published declarations }
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('XJVCL', [TBookLaber]);
end;

{ TBookLaber }

function TBookLaber.CalcSize(FrameWidth: integer): integer;
var
r:currency;

i:integer;
begin
r := FrameWidth * Rad;
i := round(r + FanySize - FframeWidth);
// i := strtoint(s);
result := i;
end;

constructor TBookLaber.Create(AOwner: TComponent);
begin
inherited;
FFont := TFont.Create ;
FuserPen := TPen.Create ;
FAnySize := 20;
FBackColor := clWhite;
FFrameColor := clRed;
FLineColor := clBlack;
FLineWidth := 50;
FlineHeight := 2;
FframeWidth := 20;
FDrawLine := true;
end;

destructor TBookLaber.Destroy;
begin
FFont.Free;
FuserPen.Free;
inherited;
end;

procedure TBookLaber.DrawMidLine;
begin
Canvas.Pen.Color := FlineColor;
Canvas.Pen.Width := FLineHeight;
Canvas.MoveTo((width - FlineWidth) div 2,(Height - FLineHeight) div 2);
Canvas.LineTo((width - FlineWidth) div 2 + FlineWidth,(Height - FLineHeight) div 2);
end;

procedure TBookLaber.DrawShape(ASize,OffW: integer;Acolor:Tcolor);
begin
Canvas.Pen.Color := AColor;
// Canvas.Pen.Width := FFrameWidth;
Canvas.MoveTo(Asize + offW, OffW);
Canvas.LineTo(Width - ASize - OffW,OffW);
Canvas.LineTo(Width - 1 - OffW,Asize + OffW);
Canvas.LineTo(Width - 1 - OffW,Height - Asize - OffW - 1);
Canvas.LineTo(Width - Asize - OffW,Height - OffW - 1 );
Canvas.LineTo(Asize + OffW,Height - OffW - 1);
Canvas.LineTo(OffW,Height - Asize - OffW);
Canvas.LineTo(OffW,Asize + OffW);
Canvas.LineTo(Asize + offW, OffW);
Canvas.Brush.Color := AColor;
Canvas.FloodFill(Width div 2,Height div 2,canvas.Pixels[Width div 2,Height div 2] ,fsSurface);

end;

procedure TBookLaber.DrawTxt;
const
Alignments: array[TAlignment] of Longint = (DT_LEFT, DT_RIGHT, DT_CENTER);
var
RectUp,RectDown,RectCent:TRect;
FontHeight: Integer;
Flags: Longint;

begin
RectUp := Rect(CalcSize(FframeWidth) + FAnySize,FFrameWidth,Width - CalcSize(FframeWidth) - FanySize,Height div 3 - FlineHeight div 3);
RectDown := Rect(CalcSize(FframeWidth) + FAnySize,Height div 3,Width - CalcSize(FframeWidth) - FanySize,Height - FframeWidth);
RectCent := Rect(CalcSize(FframeWidth) + FAnySize,Height div 3,Width - CalcSize(FframeWidth) - FanySize,Height - FframeWidth);
with Canvas do
begin
Brush.Style := bsclear;
Font := self.Font;
end;
FontHeight := Canvas.TextHeight('W');
RectUp.Top := RectUp.Top + (((RectUp.Bottom -RectUp.Top) - FontHeight) div 4);
RectCent.Top:=RectCent.Top + (((RectUp.Bottom -RectUp.Top) - FontHeight) div 3)*3;
RectDown.Top := RectDown.Top + (((RectDown.Bottom -RectDown.Top) - FontHeight) div 3)*3;

Flags := DT_EXPANDTABS or DT_VCENTER or Alignments[FAlignment];
Flags := DrawTextBiDiModeFlags(Flags);
drawtext(canvas.Handle,Pchar(FTopStr),strlen(pchar(FTopStr)),RectUp,(DT_EXPANDTABS or DT_center));
drawtext(canvas.Handle,Pchar(FCentStr),strlen(pchar(FCentStr)),RectCent,(DT_EXPANDTABS or DT_center));
drawtext(canvas.Handle,Pchar(FDownStr),strlen(pchar(FDownStr)),RectDown,(DT_EXPANDTABS or DT_center));

end;

function TBookLaber.GetBackColor: TColor;
begin
result := FBackColor;
end;

function TBookLaber.GetDownStr: string;
begin
result := FDownStr;
end;

function TBookLaber.GetFont: Tfont;
begin
result := FFont;
end;

function TBookLaber.GetFrameColor: Tcolor;
begin
result := FFrameColor;
end;

function TBookLaber.GetLineColor: Tcolor;
begin
result := FLineColor;
end;

function TBookLaber.GetTopStr: string;
begin
result := FTopStr;
end;

function TBookLaber.GetCentStr: string;
begin
result := FCentStr;
end;

procedure TBookLaber.SetAnySize(const Value: integer);
begin
FAnySize := Value;
Invalidate ;
end;

procedure TBookLaber.SetBackColor(const Value: TColor);
begin
FBackColor := Value;
Invalidate ;
end;

procedure TBookLaber.SetDownStr(const Value: string);
begin
FDownStr := Value;
Invalidate ;
end;

procedure TBookLaber.SetDrawLine(const Value: boolean);
begin
FDrawLine := Value;
Invalidate ;
end;

procedure TBookLaber.SetFont(const Value: Tfont);
begin
FFont := Value;
Invalidate ;
end;

procedure TBookLaber.SetFrameColor(const Value: Tcolor);
begin
FFrameColor := Value;
Invalidate ;
end;

procedure TBookLaber.SetLineColor(const Value: Tcolor);
begin
FLineColor := Value;
Invalidate ;
end;

procedure TBookLaber.SetLineWidth(const Value: integer);
begin
FLineWidth := Value;
Invalidate ;
end;

procedure TBookLaber.SetTopStr(const Value: string);
begin
FTopStr := Value;
Invalidate ;
end;

procedure TBookLaber.SetCentStr(const Value: string);
begin
FCentStr := Value;
Invalidate ;
end;

procedure TBookLaber.WMEARSEBKGND(var Msg: TMessage);
begin
inherited;
//DrawShape(FanySize,0,FframeColor);
// DrawShape(calcsize(FframeWidth),FframeWidth,FBackColor);
end;

procedure TBookLaber.WMPAINT(var Msg: TMessage);
begin
inherited;
DrawShape(FanySize,0,FframeColor);
DrawShape(calcsize(FframeWidth),FframeWidth,FBackColor);
if DrawLine then
DrawMidLine;
DrawTxt;
end;
end.
 
Canvas.FloodFill(Width div 2,Height div 2,canvas.Pixels[Width div 2,Height div 2] ,fsSurface);
问题在于这句话。
procedure TCanvas.FloodFill(X, Y: Integer; Color: TColor;
FillStyle: TFillStyle);
const
FillStyles: array[TFillStyle] of Word =
(FLOODFILLSURFACE, FLOODFILLBORDER);
begin
Changing;
RequiredState([csHandleValid, csBrushValid]);
Windows.ExtFloodFill(FHandle, X, Y, Color, FillStyles[FillStyle]);
Changed;
end;
你的在遮住打开后ExtFloodFill返回失败。
具体失败原因就很好查了。自己看ExtFloodFill的说明去
 

Similar threads

I
回复
0
查看
504
import
I
I
回复
0
查看
632
import
I
I
回复
0
查看
625
import
I
I
回复
0
查看
527
import
I
后退
顶部