DELPHI 按钮设计(300分)

DELPHI 按钮设计
1.象会计伴侣一样的按钮控件
2.象超级解霸一样的按钮
3.不规则图形按钮

找第三方控件吧

自己 Create Region再SetWindowRgn就是了，用第三方控件当然也可以，那就不是太通用

建议使用第三方空间象1stclass之类的，否则大部分时间你都要花在这上了。

rxlib,flatstyle等好多的第三方控件，挺好使的．

1STCLASS很容易做出这么效果。

找第三方控件吧!
如：extrapack。

agree 建议使用第三方空间之类的，否则大部分时间你都要花在这上了

cakk.126.com又一个做界面的包,里面有很多形状的按钮.
>>自己 Create Region再SetWindowRgn就是了
自己写组件当然也不难,但是浪费时间.

关注

有时间就自己写，没时间就用控件

www.51delphi.com有这样的控件,快去下吧.如果你想用第三方控件的话.

就用Timage，图象做成背景透明色的bmp8类型，你的按钮想怎么样就怎么样，想要什么特效
就可以设计成什么特效，除了没有焦点这个缺点，没办法，谁叫Timage不是从Twincontrol
继承的

to wangxd:
怎么做，能说清楚点吗？

up

谁写的不清楚， 300 分，没有代码怕不好拿。
unit Noshape;

interface

uses
SysUtils, Windows, Messages, Classes, Graphics, Controls,
Forms, Buttons;

CONST FBevelWidth = 1;
type
TNoShape = class(TGraphicControl)
private
FAutoSize: Boolean;
FBitmap: TBitmap;
FBitmapUp: TBitmap;
FBitmapDown: TBitmap;
FHitTestMask: TBitmap;
FPrevCursorSaved: Boolean;
FPrevCursor: TCursor;
FPrevShowHintSaved: Boolean;
FPrevShowHint: Boolean;
FPreciseShowHint: Boolean;
procedure AdjustBounds;
procedure AdjustSize(var W, H: Integer);
function BevelColor(const AState: TButtonState; const TopLeft: Boolean): TColor;
procedure BitmapChanged(Sender: TObject);
procedure Create3DBitmap(Source: TBitmap; const AState: TButtonState; Target: TBitmap);
procedure SetAutoSize(Value: Boolean);
procedure SetBitmap(Value: TBitmap);
procedure SetBitmapDown(Value: TBitmap);
procedure SetBitmapUp(Value: TBitmap);
procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
protected
FState: TButtonState;
procedure DefineProperties(Filer: TFiler); override;
procedure DrawButtonText(Canvas: TCanvas; const Caption: String; TextBounds: TRect; State: TButtonState); virtual;
function GetPalette: HPALETTE; override;
procedure Loaded; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure Paint; override;
procedure ReadBitmapDownData(Stream: TStream); virtual;
procedure ReadBitmapUpData(Stream: TStream); virtual;
procedure WriteBitmapDownData(Stream: TStream); virtual;
procedure WriteBitmapUpData(Stream: TStream); virtual;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Click; override;
procedure Invalidate; override;
function PtInMask(const X, Y: Integer): Boolean; virtual;
procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
property BitmapUp: TBitmap read FBitmapUp;
property BitmapDown: TBitmap read FBitmapDown;
published
property AutoSize: Boolean read FAutoSize write SetAutoSize default True;
property Bitmap: TBitmap read FBitmap write SetBitmap;
property Caption;
property Enabled;
property Font;
property ParentFont;
property ShowHint;
property Visible;
property OnClick;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
end;

procedure Register;

implementation

type
Apair = Array[0..1] of Integer;

function MakeMask(ColorBmp: TBitmap; TransparentColor: TColor): TBitmap;
var R: TRect;
OldBkColor: TColorRef;
begin
Result := TBitmap.Create;
try
Result.Monochrome := True;
Result.Width := ColorBmp.Width;
Result.Height := ColorBmp.Height;
OldBkColor := SetBkColor(ColorBmp.Canvas.Handle, ColorToRGB(TransparentColor));
R := Rect(0, 0, ColorBmp.Width, ColorBmp.Height);
Result.Canvas.CopyMode := cmSrcCopy;
Result.Canvas.CopyRect(R, ColorBmp.Canvas, R);
SetBkColor(ColorBmp.Canvas.Handle, OldBkColor);
except
Result.Free;
Raise;
end;

end;

function MakeBorder(Source, NewSource: TBitmap; const OffsetPts: Array of Apair;
TransparentColor: TColor): TBitmap;
var I, W, H: Integer;
R, NewR: TRect;
SmallMask, BigMask, NewSourceMask: TBitmap;
begin
Result := TBitmap.Create;
try
W := Source.Width;
H := Source.Height;
R := Rect(0, 0, W, H);

Result.Monochrome := True;
Result.Width := W;
Result.Height := H;

SmallMask := MakeMask(Source, TransparentColor);
NewSourceMask := MakeMask(NewSource, TransparentColor);
BigMask := MakeMask(NewSourceMask, TransparentColor);

try

BigMask.Canvas.CopyMode := cmSrcCopy;
BigMask.Canvas.CopyRect(R, NewSourceMask.Canvas, R);

for I := Low(OffsetPts) to High(OffsetPts) do
begin
if (OffsetPts[I, 0] = 0) and (OffsetPts[I, 1] = 0) then
Break;
NewR := R;
OffsetRect(NewR, OffsetPts[I, 0], OffsetPts[I, 1]);
BigMask.Canvas.CopyMode := cmSrcAnd;
BigMask.Canvas.CopyRect(NewR, SmallMask.Canvas, R);
end;
BigMask.Canvas.CopyMode := cmSrcCopy;

with Result do
begin
Canvas.CopyMode := cmSrcCopy;
Canvas.CopyRect(R, NewSourceMask.Canvas, R);
Canvas.CopyMode := $00DD0228;
Canvas.CopyRect(R, BigMask.Canvas, R);
Canvas.CopyMode := cmSrcCopy;
end;

finally
SmallMask.Free;
NewSourceMask.Free;
BigMask.Free;
end;

except
Result.Free;
Raise;
end;

end;

{ TNoShape }
constructor TNoShape.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
SetBounds(0, 0, 80, 80);
ControlStyle := [csCaptureMouse, csOpaque];
FAutoSize := True;
FBitmap := TBitmap.Create;
FBitmap.OnChange := BitmapChanged;
FBitmapUp := TBitmap.Create;
FBitmapDown := TBitmap.Create;
FHitTestMask := nil;
ParentFont := True;
FState := bsUp;
FPreciseShowHint := True;
{ Caption := ClassName;}
end;

destructor TNoShape.Destroy;
begin
FBitmap.Free;
FBitmapUp.Free;
FBitmapDown.Free;
FHitTestMask.Free;
inherited Destroy;
end;

procedure TNoShape.Paint;
var W, H: Integer;
Composite, Mask, Overlay, CurrentBmp: TBitmap;
R, NewR: TRect;
begin
if csDesigning in ComponentState then
with Canvas do
begin
Pen.Style := psDash;
Brush.Style := bsClear;
Rectangle(0, 0, Width, Height);
end;

if (csDesigning in ComponentState) or
(FState in [bsDisabled, bsExclusive]) then
FState := bsUp;

if (FState = bsUp) then CurrentBmp := FBitmapUp
else CurrentBmp := FBitmapDown;

if not CurrentBmp.Empty then
begin

W := Width;
H := Height;
R := ClientRect;
NewR := R;

Composite := TBitmap.Create;
Overlay := TBitmap.Create;

try
with Composite do
begin
Width := W;
Height := H;
Canvas.CopyMode := cmSrcCopy;
Canvas.CopyRect(R, Self.Canvas, R);
end;

with Overlay do
begin
Width := W;
Height := H;
Canvas.CopyMode := cmSrcCopy;
Canvas.Brush.Color := FBitmap.TransparentColor;
Canvas.FillRect(R);
if FState = bsDown then
OffsetRect(NewR, 1, 1);
Canvas.CopyRect(NewR, CurrentBmp.Canvas, R);
end;

Mask := MakeMask(Overlay, FBitmap.TransparentColor);
try

Composite.Canvas.CopyMode := cmSrcAnd;
Composite.Canvas.CopyRect(R, Mask.Canvas, R);


Overlay.Canvas.CopyMode := $00220326;
Overlay.Canvas.CopyRect(R, Mask.Canvas, R);


Composite.Canvas.CopyMode := cmSrcPaint;
Composite.Canvas.CopyRect(R, Overlay.Canvas, R);

Canvas.CopyMode := cmSrcCopy;
Canvas.CopyRect(R, Composite.Canvas, R);

finally
Mask.Free;
end;

finally
Composite.Free;
Overlay.Free;
end;

end;

if Length(Caption) > 0 then
begin
Canvas.Font := Self.Font;
R := CLIENTRECT;
DrawButtonText(Canvas, Caption, R, FState);
end;

end;

function TNoShape.PtInMask(const X, Y: Integer): Boolean;
begin
Result := True;
if FHitTestMask <> nil then
Result := (FHitTestMask.Canvas.Pixels[X, Y] = clBlack);
end;

procedure TNoShape.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
var Clicked: Boolean;
begin
inherited MouseDown(Button, Shift, X, Y);
if (Button = mbLeft) and Enabled then
begin
Clicked := PtInMask(X, Y);

if Clicked then
begin
FState := bsDown;
Repaint;
end;
end;
end;

procedure TNoShape.MouseMove(Shift: TShiftState; X, Y: Integer);
var NewState: TButtonState;
InMask: Boolean;
begin
inherited MouseMove(Shift, X, Y);
InMask := PtInMask(X, Y);

if FPreciseShowHint and not InMask then
begin

if not FPrevShowHintSaved then
begin

ParentShowHint := False;
FPrevShowHint := ShowHint;
ShowHint := False;
FPrevShowHintSaved := True;
end;
end
else IF not InMask then
begin
if not FPrevCursorSaved then
begin
FPrevCursor := Cursor;
Cursor := crDefault;
FPrevCursorSaved := True;
end;
end
else
begin
if FPrevShowHintSaved then
begin

ShowHint := FPrevShowHint;
FPrevShowHintSaved := False;
end;
if FPrevCursorSaved then
begin
Cursor := FPrevCursor;
FPrevCursorSaved := False;
end;
end;

end;

procedure TNoShape.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
var
DoClick: Boolean;
begin
inherited MouseUp(Button, Shift, X, Y);
DoClick := PtInMask(X, Y);
if (FState = bsDown) then
begin
FState := bsUp;
Repaint;
end;
if DoClick then Click;
end;

procedure TNoShape.Click;
begin
inherited Click;
end;

function TNoShape.GetPalette: HPALETTE;
begin
Result := FBitmap.Palette;
end;

procedure TNoShape.SetBitmap(Value: TBitmap);
begin
FBitmap.Assign(Value);
end;

procedure TNoShape.SetBitmapUp(Value: TBitmap);
begin
FBitmapUp.Assign(Value);
end;

procedure TNoShape.SetBitmapDown(Value: TBitmap);
begin
FBitmapDown.Assign(Value);
end;

procedure TNoShape.BitmapChanged(Sender: TObject);
var OldCursor: TCursor;
W, H: Integer;
begin
AdjustBounds;

if not ((csReading in ComponentState) or (csLoading in ComponentState)) then
begin
if FBitmap.Empty then
begin

SetBitmapUp(nil);
SetBitmapDown(nil);
end
else
begin
W := FBitmap.Width;
H := FBitmap.Height;
OldCursor := Screen.Cursor;
Screen.Cursor := crHourGlass;
try
if (FBitmapUp.Width <> W) or (FBitmapUp.Height <> H) or
(FBitmapDown.Width <> W) or (FBitmapDown.Height <> H) then
begin
FBitmapUp.Width := W;
FBitmapUp.Height := H;
FBitmapDown.Width := W;
FBitmapDown.Height := H;
end;
Create3DBitmap(FBitmap, bsUp, FBitmapUp);
Create3DBitmap(FBitmap, bsDown, FBitmapDown);

FHitTestMask.Free;
FHitTestMask := MakeMask(FBitmapUp, FBitmap.TransparentColor);

finally
Screen.Cursor := OldCursor;
end;
end;
end;
Invalidate;

end;

procedure TNoShape.CMDialogChar(var Message: TCMDialogChar);
begin
with Message do
if IsAccel(CharCode, Caption) and Enabled then
begin
Click;
Result := 1;
end else
inherited;
end;

procedure TNoShape.CMFontChanged(var Message: TMessage);
begin
Invalidate;
end;

procedure TNoShape.CMTextChanged(var Message: TMessage);
begin
Invalidate;
end;

procedure TNoShape.CMSysColorChange(var Message: TMessage);
begin
BitmapChanged(Self);
end;

function TNoShape.BevelColor(const AState: TButtonState; const TopLeft: Boolean): TColor;
begin
if (AState = bsUp) then
begin
if TopLeft then Result := clBtnHighlight
else Result := clBtnShadow
end
else { bsDown }
begin
if TopLeft then Result := clBtnShadow
else Result := clBtnHighlight;
end;
end;


procedure TNoShape.Create3DBitmap(Source: TBitmap; const AState: TButtonState; Target: TBitmap);
type OutlineOffsetPts = Array[1..3, 0..1, 0..12] of Apair;
const
OutlinePts: OutlineOffsetPts =
( (((1,-1),(1,0),(1,1),(0,1),(-1,1),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0)),
((-1,0),(-1,-1),(0,-1),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0))),
(((2,-2),(2,-1),(2, 0),(2, 1),(2, 2),(1, 2),(0, 2),(-1,2),(-2,2),(0,0),(0,0),(0,0),(0,0)),
((-2,1),(-2,0),(-2,-1),(-2,-2),(-1,-2),(0,-2),(1,-2),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0))),
(((3,-3),(3,-2),(3,-1),(3,0),(3,1),(3,2),(3,3),(2,3),(1,3),(0,3),(-1,3),(-2,3),(-3,3)),
((-3,2),(-3,1),(-3,0),(-3,-1),(-3,-2),(-3,-3),(-2,-3),(-1,-3),(0,-3),(1,-3),(2,-3),(0,0),(0,0)))
);
var I, J, W, H, Outlines: Integer;
R: TRect;
OutlineMask, Overlay, NewSource: TBitmap;
begin
if (Source = nil) or (Target = nil) then
Exit;

W := Source.Width;
H := Source.Height;
R := Rect(0, 0, W, H);

Overlay := TBitmap.Create;
NewSource := TBitmap.Create;

try

NewSource.Width := W;
NewSource.Height := H;


Target.Canvas.CopyMode := cmSrcCopy;
Target.Canvas.CopyRect(R, Source.Canvas, R);

Overlay.Width := W;
Overlay.Height := H;

Outlines := FBevelWidth;
Inc(Outlines);

for I := 1 to Outlines do
begin
with NewSource.Canvas do
begin
CopyMode := cmSrcCopy;
CopyRect(R, Target.Canvas, R);
end;

for J := 0 to 1 do
begin
if (AState = bsDown) and (I = Outlines) and (J = 0) then
Continue;

OutlineMask := MakeBorder(Source, NewSource, OutlinePts[I, J],
FBitmap.TransparentColor);
try
with Overlay.Canvas do
begin
if (I = Outlines) then
Brush.Color := clBlack
else
Brush.Color := BevelColor(AState, (J = 1));
CopyMode := $0030032A; { PSna }
CopyRect(R, OutlineMask.Canvas, R);
end;

with Target.Canvas do
begin

CopyMode := cmSrcAnd; { DSa }
CopyRect(R, OutlineMask.Canvas, R);

CopyMode := cmSrcPaint; { DSo }
CopyRect(R, Overlay.Canvas, R);
CopyMode := cmSrcCopy;
end;

finally
OutlineMask.Free;
end;

end;
end;

finally
Overlay.Free;
NewSource.Free;

end;
end;

procedure TNoShape.DrawButtonText(Canvas: TCanvas; const Caption: String;
TextBounds: TRect; State: TButtonState);
var
CString: array[0..255] of Char;
begin
StrPCopy(CString, Caption);
Canvas.Brush.Style := bsClear;
if State = bsDown then OffsetRect(TextBounds, 1, 1);
DrawText(Canvas.Handle, CString, -1, TextBounds,
DT_CENTER or DT_VCENTER or DT_SINGLELINE);
end;

procedure TNoShape.Loaded;
var BigMask: TBitmap;
R: TRect;
begin
inherited Loaded;
if (FBitmap <> nil) and (FBitmap.Width > 0) and (FBitmap.Height > 0) then
begin
FHitTestMask.Free;
FHitTestMask := MakeMask(FBitmap, FBitmap.TransparentColor);
BigMask := MakeMask(FBitmapUp, FBitmap.TransparentColor);
try
R := Rect(0, 0, FBitmap.Width, FBitmap.Height);
FHitTestMask.Canvas.CopyMode := cmSrcAnd;
FHitTestMask.Canvas.CopyRect(R, BigMask.Canvas, R);
finally
BigMask.Free;
end;
end;
end;


procedure TNoShape.DefineProperties(Filer: TFiler);
begin
inherited DefineProperties(Filer);
Filer.DefineBinaryProperty('BitmapUp', ReadBitmapUpData, WriteBitmapUpData, not FBitmapUp.Empty);
Filer.DefineBinaryProperty('BitmapDown', ReadBitmapDownData, WriteBitmapDownData, not FBitmapDown.Empty)
end;

procedure TNoShape.ReadBitmapUpData(Stream: TStream);
begin
FBitmapUp.LoadFromStream(Stream);
end;

procedure TNoShape.WriteBitmapUpData(Stream: TStream);
begin
FBitmapUp.SaveToStream(Stream);
end;

procedure TNoShape.ReadBitmapDownData(Stream: TStream);
begin
FBitmapDown.LoadFromStream(Stream);
end;

procedure TNoShape.WriteBitmapDownData(Stream: TStream);
begin
FBitmapDown.SaveToStream(Stream);
end;

procedure TNoShape.AdjustBounds;
begin
SetBounds(Left, Top, Width, Height);
end;

procedure TNoShape.AdjustSize(var W, H: Integer);
begin
if not (csReading in ComponentState) and FAutoSize and not FBitmap.Empty then
begin
W := FBitmap.Width;
H := FBitmap.Height;
end;
end;

procedure TNoShape.SetAutoSize(Value: Boolean);
begin
if FAutoSize <> Value then
begin
FAutoSize := Value;
AdjustBounds;
end;
end;

procedure TNoShape.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
var W, H: Integer;
begin
W := AWidth;
H := AHeight;
AdjustSize(W, H);
inherited SetBounds(ALeft, ATop, W, H);
end;

procedure TNoShape.Invalidate;
var R: TRect;
begin
if (Visible or (csDesigning in ComponentState)) and
(Parent <> nil) and Parent.HandleAllocated then
begin
R := BoundsRect;
InvalidateRect(Parent.Handle, @R, True);
end;
end;

procedure Register;
begin
RegisterComponents('Test', [TNoShape]);
end;
end.

君之代码有如滔滔江水连绵不绝
楼上不是讲了吗
用第三方控件就OK
没有必要每件东西都要从底层做起吧
这也太浪费时间了
如果是学习另当别论

混蛋！我贴故我在。夸夸其谈做什么？我就是来混分的，君子混分有道，不给代码瞎说什么？