interface

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

type
TShade = record
C: array[0..15] of TColor;
end;

type
TXPButton = class(TButton)
private
FBaseColor: TColor;
FCanvas: TCanvas;
IsFocused: Boolean;
Shade: TShade;
procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
procedure DrawItem(const DrawItemStruct: TDrawItemStruct);
procedure SetBaseColor(Value: TColor);
function LoadShades(BaseColor: TColor): TShade;
function ShadeColor(BaseColor: TColor; Offset: Integer): TColor;
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure SetButtonStyle(ADefault: Boolean); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
//property BaseColor: TColor read FBaseColor write SetBaseColor default $00777777;
property OnClick;
property OnContextPopup;
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;
end;

procedure Register;
implementation

procedure Register;
begin
RegisterComponents('Liren.z', [TXPButton]);
end;

constructor TXPButton.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FCanvas := TCanvas.Create;
FBaseColor := $00DDB9B9; //$00777777;
ControlStyle := ControlStyle - [csDoubleClicks];
Width := 85;
Height := 30;
Shade := LoadShades(FBaseColor);
end;

destructor TXPButton.Destroy;
begin
inherited Destroy;
FCanvas.Free;
end;

procedure TXPButton.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do Style := Style or BS_OWNERDRAW;
end;

procedure TXPButton.CNDrawItem(var Message: TWMDrawItem);
begin
DrawItem(Message.DrawItemStruct^);
end;

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

procedure TXPButton.CMEnabledChanged(var Message: TMessage);
begin
inherited;
Invalidate;
end;

procedure TXPButton.DrawItem(const DrawItemStruct: TDrawItemStruct);
var
IsDown, IsDefault: Boolean;
Rec, FocusRect: TRect;
Flags: Longint;
FilCol, BorCol, CapCol, T1, T2, B1, B2: TColor;
begin
FCanvas.Handle := DrawItemStruct.hDC;
Rec := ClientRect;

with DrawItemStruct do begin
IsDown := itemState and ODS_SELECTED <> 0;
IsDefault := itemState and ODS_FOCUS <> 0;
end;
Flags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;
if IsDown then Flags := Flags or DFCS_PUSHED;
if (DrawItemStruct.itemState and ODS_DISABLED <> 0) then
Flags := Flags or DFCS_INACTIVE;

FCanvas.Font := Font;

if Enabled then begin
BorCol := Shade.C[0];
if IsDown then begin
T1 := Shade.C[4];
T2 := Shade.C[5];
B1 := Shade.C[7];
B2 := Shade.C[8];
FilCol := Shade.C[6];
CapCol := Shade.C[15];
end
else begin
T1 := Shade.C[13];
T2 := Shade.C[15];
B1 := Shade.C[10];
B2 := Shade.C[7];
FilCol := Shade.C[13];
CapCol := Font.Color;
end
end
else begin
BorCol := Shade.C[8];
CapCol := Shade.C[8];
FilCol := Shade.C[13];
end;

with FCanvas do begin
Pen.Style := psSolid;
Brush := Parent.Brush;
FillRect(ClientRect);
Brush.Color := FilCol;
Pen.Color := BorCol;
InflateRect(Rec, -3, -3);
RoundRect(Rec.Left, Rec.Top, Rec.Right, Rec.Bottom, 3, 3);
if Enabled then begin
Pen.Color := T1;
MoveTo(Rec.Left + 1, Rec.Bottom - 3);
LineTo(Rec.Left + 1, Rec.Top + 1);
MoveTo(Rec.Left + 2, Rec.Top + 1);
LineTo(Rec.Right - 2, Rec.Top + 1);
Pen.Color := T2;
MoveTo(Rec.Left + 2, Rec.Bottom - 4);
LineTo(Rec.Left + 2, Rec.Top + 2);
LineTo(Rec.Right - 3, Rec.Top + 2);
Pen.Color := B1;
MoveTo(Rec.Left + 3, Rec.Bottom - 3);
LineTo(Rec.Right - 3, Rec.Bottom - 3);
LineTo(Rec.Right - 3, Rec.Top + 2);
Pen.Color := B2;
MoveTo(Rec.Left + 3, Rec.Bottom - 2);
LineTo(Rec.Right - 2, Rec.Bottom - 2);
MoveTo(Rec.Right - 2, Rec.Bottom - 3);
LineTo(Rec.Right - 2, Rec.Top + 2);

{ Make pixel-perfect modifications }
if IsDown then begin
Pixels[Rec.Left + 2, Rec.Top + 2] := T1;
Pixels[Rec.Left + 3, Rec.Top + 3] := T2;
Pixels[Rec.Left + 2, Rec.Bottom - 2] := B1;
Pixels[Rec.Right - 2, Rec.Top + 2] := B1;
Pixels[Rec.Right - 3, Rec.Bottom - 3] := B2;
Pixels[Rec.Right - 4, Rec.Bottom - 4] := B1;
end
else begin
Pixels[Rec.Left + 1, Rec.Top + 2] := Shade.C[11];
Pixels[Rec.Left + 2, Rec.Top + 1] := Shade.C[11];
Pixels[Rec.Left + 3, Rec.Top + 3] := T2;
Pixels[Rec.Left + 1, Rec.Bottom - 3] := Shade.C[11];
Pixels[Rec.Left + 2, Rec.Bottom - 2] := Shade.C[11];
Pixels[Rec.Right - 3, Rec.Top + 1] := Shade.C[11];
Pixels[Rec.Right - 2, Rec.Top + 2] := Shade.C[11];
Pixels[Rec.Right - 4, Rec.Bottom - 4] := B1;
Pixels[Rec.Right - 3, Rec.Bottom - 3] := B2;
end;

end;
InflateRect(Rec, -8, -4);
Font.Color := CapCol;
Rec.Top := Rec.Top - 1;
DrawText(Handle, PChar(Caption), Length(Caption), Rec,
DT_CENTER or DT_VCENTER or DT_SINGLELINE);

if Enabled then begin
FocusRect := Rect(6, 6, width - 6, height - 6);
if IsFocused then
DrawFocusRect(FocusRect);
end;
end;
FCanvas.Handle := 0;
end;

procedure TXPButton.SetButtonStyle(ADefault: Boolean);
begin
if (ADefault <> IsFocused) then begin
IsFocused := ADefault;
Invalidate;
end;
end;

procedure TXPButton.SetBaseColor(Value: TColor);
begin
if (Value <> FBaseColor) then begin
FBaseColor := Value;
Shade := LoadShades(FBaseColor);
Repaint;
end;
end;

function TXPButton.LoadShades(BaseColor: TColor): TShade;
var
Index: Integer;
begin
for Index := 0 to 7 do
Result.C[Index] := ShadeColor(BaseColor, -(7 - Index) * 17);
for Index := 8 to 15 do
Result.C[Index] := ShadeColor(BaseColor, (Index - 7) * 17);
end;

function TXPButton.ShadeColor(BaseColor: TColor; Offset: Integer): TColor;
var
Red, Green, Blue: Integer;
begin
Red := (BaseColor and $FF) + Offset;
Green := ((BaseColor and $FF00) div 256) + Offset;
Blue := ((BaseColor and $FF0000) div 65536) + Offset;
if (Red > $FF) then Red := $FF;
if (Red < $00) then Red := $00;
if (Green > $FF) then Green := $FF;
if (Green < $00) then Green := $00;
if (Blue > $FF) then Blue := $FF;
if (Blue < $00) then Blue := $00;
Result := (Blue * 65536) + (Green * 256) + Red;
end;

end.

制作特殊窗体=========================================================

{*******************************************************}
{ }
{ ImgForm v1.01 }
{ }
{ Copyright (c) 2002-1 Liren Zhao BeiJing China }
{ }
{ HomePage: Http://Stef.533.net/54 }
{ Http://Aojianjianghu.126.com }
{ Address:Beijing Syntong Tech Delvelop co.,LTD }
{ Email:[email protected] }
{ }
{*******************************************************}
unit ImgForm;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls;

type
EImgFormError = class(Exception);
TImgForm = class(TCustomPanel) //TGraphicControl
private
FPicture:TBitMap;
FMoveForm:Boolean;
FormHandle:Hwnd;
procedure SetPicture(Value: TBitMap);
procedure PictureChange(Sender: TObject);

protected
procedure paint;override;
procedure MouseMove(Shift: TShiftState; X,Y: Integer);Override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Execute;
procedure HideInTaskBar;
published
property Picture: TBitMap read FPicture write SetPicture;
property MoveForm:boolean read FMoveForm write FMoveForm ;
property PopupMenu;
property DragCursor;
property DragKind;
property DragMode;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('Liren.z', [TImgForm]);
end;

{ TImgForm }

constructor TImgForm.Create(AOwner: TComponent);
begin
//记得以后加上，判断Parent是不是窗体，还有就是self的个数只能为一个
inherited Create(AOwner);

if not (AOwner is TForm) then //
raise EImgFormError.Create('Control parent must be a form!')
else
with (AOwner as TForm) do begin
AutoSize:=true;
BorderStyle:=bsNone;
FormHandle:=Handle;
end;

Align:=alClient;
FMoveForm:=true;
FPicture :=TBitMap.Create;
FPicture.OnChange:=PictureChange;
end;

destructor TImgForm.Destroy;
begin
FPicture.Free;
inherited Destroy;
end;

procedure TImgForm.paint;
const
XorColor = $00FFD8CE;
begin
with Canvas do begin
if (csDesigning in ComponentState) then begin
Pen.Style := psDot;
Pen.Mode := pmXor;
Pen.Color := XorColor;
Brush.Style := bsClear;
Rectangle(0, 0, ClientWidth, ClientHeight);
TextOut(5,5,'ImgForm');
moveto(0,0);
Lineto(Width,height);
moveto(0,Height);
Lineto(Width,0);
end;

if not FPicture.Empty then
Draw(0,0,FPicture);
end;
// inherited Paint; // 如果控件从TGraphicControl继承，就不要注释这里
end;

procedure TImgForm.PictureChange(Sender: TObject);
begin
if not FPicture.Empty then begin
Align:=alNone;
Width:=FPicture.Width;
Height:=FPicture.Height;
end
else
Align:=alClient;
end;

procedure TImgForm.Execute;
var
h,w,i,j:integer;
tc:Tcolor;
hrgn1,hrgn3:HRGN;
begin
if not FPicture.Empty then begin
tc:=FPicture.Canvas.Pixels[0,0];
h:=FPicture.Canvas.ClipRect.Bottom -FPicture.Canvas.ClipRect.top ;
w:=FPicture.Canvas.ClipRect.Right -FPicture.Canvas.ClipRect.left ;
hrgn3:=createrectrgn(0,0,w,h);
try
for i:=0 to w-1 do
for j:=0 to h-1 do
begin
if FPicture.Canvas.Pixels[i,j]=tc then
begin
deleteobject(hrgn1);
hrgn1:=CreateRectRgn(i,j,i+1,j+1);
if hrgn1<>0 then
begin
CombineRgn(hrgn3,hrgn3,hrgn1,RGN_DIFF);
end;
end;
end;
deleteobject(hrgn1);
setwindowrgn(FormHandle,hrgn3,true);
except
//RaiseException Here
end;
end;
end;

procedure TImgForm.SetPicture(Value: TBitMap);
begin
FPicture.Assign(Value);
Invalidate;
end;

procedure TImgForm.MouseMove(Shift: TShiftState; X,
Y: Integer);
begin
inherited;
if FMoveForm then begin
ReleaseCapture;
(Parent as TForm).perform(WM_SysCommand, $F012, 0);
end;
end;

procedure TImgForm.HideInTaskBar;
var
ExtendedStyle : Integer;
begin
ExtendedStyle := GetWindowLong (Application.Handle, GWL_EXSTYLE);
SetWindowLong(Application.Handle, GWL_EXSTYLE, ExtendedStyle OR WS_EX_TOOLWINDOW AND NOT WS_EX_APPWINDOW);
end;

end.

使用图片做按扭的控件=========================================

{*******************************************************}
{ }
{ ImgButton v2.01 (Freeware) }
{ }
{ Copyright (c) 2002-1 Liren Zhao BeiJing China }
{ }
{ HomePage: Http://Stef.533.net/54 }
{ Http://Aojianjianghu.126.com }
{ }
{ Email:[email protected] }
{ }
{*******************************************************}

unit ImgButton;

interface

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

type
TImgButton = class(TGraphicControl)
private
FGNormal: TBitmap;
FGMouseDown: TBitMap;
FGMouseUp: TBitMap;
FGDisabled: TBitMap;
tmpBitmap: TBitMap;
FCaption: String;
FShowCaption: Boolean;
FModalResult: TModalResult;
FFont:TFont;
procedure SetGNormal(Value: TBitMap);
procedure SetGMouseDown(Value: TBitMap);
procedure SetGMouseUp(Value: TBitMap);
procedure SetGDisabled(Value: TBitMap);
procedure SetCaption(Value:String);
procedure Resize(Sender: TObject);
procedure SetShowCaption(Value:Boolean);
procedure DrawCaption;
procedure SetFont(Value:TFont);
protected
procedure paint;override;
procedure MouseEnter(var Msg: TMessage); message CM_MOUSEENTER;
procedure MouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property PictureEnter: TBitMap read FGMouseUp write SetGMouseUp;
property PictureDown: TBitMap read FGMouseDown write SetGMouseDown;
property PictureNormal: TBitMap read FGNormal write SetGNormal;
property PictureDisable: TBitMap read FGDisabled write SetGDisabled;
property ModalResult: TModalResult read FModalResult write FModalResult default 0;
property Caption: String read FCaption write SetCaption;
property ShowCaption:Boolean read FShowCaption write SetShowCaption;
property Font:TFont read FFont write SetFont;
property Action;
property Anchors;
property Enabled;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Visible;
property OnClick;
property OnDblClick;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('Liren.z', [TImgButton]);
end;

{ TImgButton }

constructor TImgButton.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Width := 100;
Height := 100;
FGNormal :=TBitMap.Create;
FGMouseDown :=TBitMap.Create;
FGMouseUp :=TBitMap.Create;
FGDisabled :=TBitMap.Create;
tmpBitmap :=TBitMap.Create;
OnResize:=Resize;
With Canvas.Font do begin
Charset:=GB2312_CHARSET;
Color:= clWindowText;
Height:=-12;
Name:='宋体';
Pitch:=fpDefault;
Size:=9;
end;
FFont:=Canvas.Font;
end;

destructor TImgButton.Destroy;
begin
FGNormal.Free;
FGMouseDown.Free;
FGMouseUp.Free;
FGDisabled.Free;
tmpBitMap:=nil;
tmpBitmap.Free;
inherited Destroy;
end;

procedure TImgButton.paint;
const
XorColor = $00FFD8CE;
begin
with Canvas do begin
if (csDesigning in ComponentState) then begin
Pen.Style := psDot;
Pen.Mode := pmXor;
Pen.Color := XorColor;
Brush.Style := bsClear;
Rectangle(0, 0, ClientWidth, ClientHeight);
end;

if not Enabled then
if not FGDisabled.Empty then
tmpBitmap:= FGDisabled
else
tmpBitMap:=FGNormal
else
tmpBitMap:=FGNormal;

Canvas.StretchDraw(ClientRect, tmpBitmap);
DrawCaption;
end;
end;

procedure TImgButton.SetGDisabled(Value: TBitMap);
begin
FGDisabled.Assign(Value);
Invalidate;
end;

procedure TImgButton.SetGMouseDown(Value: TBitMap);
begin
FGMouseDown.Assign(Value);
Invalidate;
end;

procedure TImgButton.SetGNormal(Value: TBitMap);
begin
FGNormal.Assign(Value);
tmpBitmap:= FGNormal;
Width:=FGNormal.Width;
Height:=FGNormal.Height;
Repaint;
Canvas.StretchDraw(ClientRect, FGNormal);
Invalidate;
end;

procedure TImgButton.SetGMouseUp(Value: TBitMap);
begin
FGMouseUp.Assign(Value);
Invalidate;
end;

procedure TImgButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X,Y: Integer);
begin
if (x>0) and (x<Width) and (y>0) and (y<Height) then begin
if button = mbLeft then begin
Repaint;
Canvas.StretchDraw(ClientRect, FGMouseDown);
DrawCaption;
end;
end;
inherited;
end;

procedure TImgButton.MouseEnter(var Msg: TMessage);
begin
if Enabled then begin
Repaint;
Canvas.StretchDraw(ClientRect, FGMouseUp);
DrawCaption;
end;
end;

procedure TImgButton.MouseLeave(var Msg: TMessage);
begin
if Enabled then begin
Repaint;
Canvas.StretchDraw(ClientRect, FGNormal);
DrawCaption;
end;
end;

procedure TImgButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
if (x>0) and (x<Width) and (y>0) and (y<Height) then begin
if button = mbLeft then begin
Repaint;
Canvas.StretchDraw(ClientRect, FGMouseUp);
DrawCaption;
end;
end;
inherited;
end;

procedure TImgButton.Resize(Sender: TObject);
begin
if not FGNormal.Empty then begin
Width:=FGNormal.Width;
Height:=FGNormal.Height;
DrawCaption;
end;
end;

procedure TImgButton.SetCaption(Value: String);
begin
FCaption:=Value;
DrawCaption;
Invalidate;
end;

procedure TImgButton.DrawCaption;
var
x,y:integer;
begin
if FShowCaption then begin
with Canvas do begin
Brush.Style := bsClear;
x:=Round((Width-TextWidth(Caption))/2);
y:=Round((Height-TextHeight(Caption))/2);
TextOut(x,y,Caption);
end;
end;
end;

procedure TImgButton.SetShowCaption(Value: Boolean);
begin
FShowCaption:=Value;
Invalidate;
end;

procedure TImgButton.SetFont(Value: TFont);
begin
FFont:=Value;
Canvas.Font:=Value;
Invalidate;
end;

end.