100分 求救！！

[QQQZY]

100分求写一个简单的控件代码：
要求：继承TShape类，
创建的时候能同时创建两个框框，上下排列，上面的小，下面的大，形状如下

******
* *
* *
**************
* *
* *
* *
* *
**************
代码只要能用，立马结分！

[gaohua027]

路过 顶

[QQQZY]

logne():

您好，
我使用了您给的代码注册了控件，
但是
只要向窗体添加控件的时候就会报错：

danger

Stack overflow - save your work and restart Borland Delphi for
Microsoft Windows.

而且有时候还会导致delphi2006直接关闭
请问是什么原因呢？

[cnhxjtoa]

MK

[superyys]

100块钱还差不多,哈哈

[brightyang]

呵呵~,不错,帮顶

[QQQZY]

感谢！！！

[logne]

新建一个package，把下面这个单元加进去，做成dpk，然后装上，这些楼主会吧，我就不写了

unit MyShape;

interface

uses
SysUtils, Classes, Controls, ExtCtrls, DesignIntf;

type
TMyShape = class(TShape)
private
FBottomFrameWidth: Integer;
FTopFrameHeight: Integer;
FTopFrameWidth: Integer;
FBottomFrameHeight: Integer;
procedure SetBottomFrameHeight(const Value: Integer);
procedure SetBottomFrameWidth(const Value: Integer);
procedure SetTopFrameHeight(const Value: Integer);
procedure SetTopFrameWidth(const Value: Integer);
function GetHeight: Integer;
function GetWidth: Integer;
procedure SetHeight(const Value: Integer);
procedure SetWidth(const Value: Integer);
{ Private declarations }
protected
{ Protected declarations }
procedure Paint; override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
published
{ Published declarations }
property TopFrameHeight: Integer read FTopFrameHeight write SetTopFrameHeight;
property TopFrameWidth: Integer read FTopFrameWidth write SetTopFrameWidth;
property BottomFrameHeight: Integer read FBottomFrameHeight write SetBottomFrameHeight;
property BottomFrameWidth: Integer read FBottomFrameWidth write SetBottomFrameWidth;
property Width: Integer read GetWidth write SetWidth;
property Height: Integer read GetHeight write SetHeight;
end;

procedure Register;

implementation

procedure Register;
begin
// 注册控件 'ClockAndTime' 表示注册到哪个页签
RegisterComponents('ClockAndTime', [TMyShape]);

RegisterPropertyInCategory('ClockPro', TMyShape, 'TopFrameHeight');
RegisterPropertyInCategory('ClockPro', TMyShape, 'TopFrameWidth');
RegisterPropertyInCategory('ClockPro', TMyShape, 'BottomFrameHeight');
RegisterPropertyInCategory('ClockPro', TMyShape, 'BottomFrameWidth');
end;

{ TMyShape }

constructor TMyShape.Create(AOwner: TComponent);
begin
inherited;
BottomFrameWidth := 50;
TopFrameHeight := 20;
TopFrameWidth := 20;
BottomFrameHeight := 50;
end;

function TMyShape.GetHeight: Integer;
begin
Result := inherited Height;
end;

function TMyShape.GetWidth: Integer;
begin
Result := inherited Width;
end;

procedure TMyShape.Paint;
var
X, Y, W, H, S, W1, H1, W2, H2: Integer;
begin
with Canvas do
begin
Pen := inherited Pen;
Brush := inherited Brush;
X := Pen.Width div 2;
Y := X;
W := Width - Pen.Width + 1;
H := Height - Pen.Width + 1;
W1 := FTopFrameWidth - Pen.Width + 1;
H1 := FTopFrameHeight - Pen.Width + 1;
W2 := FBottomFrameWidth - Pen.Width + 1;
H2 := FBottomFrameHeight - Pen.Width + 1;
if Pen.Width = 0 then
begin
Dec(W);
Dec(H);
Dec(W1);
Dec(H1);
Dec(W2);
Dec(H2);
end;
if W < H then S := W else S := H;
// 画两个矩形
Rectangle(X, Y, X + W1, Y + H1);
Rectangle(X, Y + H1, X + W2, Y + H1 + H2);
end;
end;

procedure TMyShape.SetBottomFrameHeight(const Value: Integer);
begin
if FBottomFrameHeight <> Value then
begin
FBottomFrameHeight := Value;
SetHeight(FTopFrameHeight + FBottomFrameHeight);
Invalidate;
end;
end;

procedure TMyShape.SetBottomFrameWidth(const Value: Integer);
begin
if FBottomFrameWidth <> Value then
begin
FBottomFrameWidth := Value;
if FBottomFrameWidth > FTopFrameWidth then
SetWidth(FBottomFrameWidth)
else
SetWidth(FTopFrameWidth);
Invalidate;
end;
end;

procedure TMyShape.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
if AWidth <> Width then
if FTopFrameWidth = FBottomFrameWidth then
begin
FTopFrameWidth := AWidth;
FBottomFrameWidth := AWidth;
end
else if FTopFrameWidth > FBottomFrameWidth then
begin
FBottomFrameWidth := AWidth * FBottomFrameWidth div FTopFrameWidth;
FTopFrameWidth := AWidth;
end
else begin
FTopFrameWidth := AWidth * FTopFrameWidth div FBottomFrameWidth;
FBottomFrameWidth := AWidth;
end;
if AHeight <> Height then
if FTopFrameHeight = FBottomFrameHeight then
begin
FTopFrameHeight := AHeight div 2;
FBottomFrameHeight := AHeight - FTopFrameHeight;
end
else begin
FTopFrameHeight := AHeight * FTopFrameHeight div (FTopFrameHeight + FBottomFrameHeight);
FBottomFrameHeight := AHeight - FTopFrameHeight;
end;
inherited;

Invalidate;
end;

procedure TMyShape.SetHeight(const Value: Integer);
begin
if GetHeight <> Value then
begin
inherited Height := Value;
end;
end;

procedure TMyShape.SetTopFrameHeight(const Value: Integer);
begin
if FTopFrameHeight <> Value then
begin
FTopFrameHeight := Value;
SetHeight(FTopFrameHeight + FBottomFrameHeight);
Invalidate;
end;
end;

procedure TMyShape.SetTopFrameWidth(const Value: Integer);
begin
if FTopFrameWidth <> Value then
begin
FTopFrameWidth := Value;
if FTopFrameWidth > FBottomFrameWidth then
SetWidth(FTopFrameWidth)
else
SetWidth(FBottomFrameWidth);
Invalidate;
end;
end;

procedure TMyShape.SetWidth(const Value: Integer);
begin
if GetWidth <> Value then
begin
inherited Width := Value;
end;
end;

end.