xpbutton (dephi)_txpbutton-CSDN博客

本文链接：https://blog.csdn.net/kongchaos/article/details/2097400

推荐一个我自己做的一个电影站,绝对没弹窗:-) www.fastdy.com 速看电影吧,每天都更新,

最新的电影电视剧都在速看电影吧!~

{*******************************************************}

{ }

{ XPButton v1.01 }

{ }

{ HomePage: Http://Stef.533.net/54 }

{ Http://Aojianjianghu.126.com }

{ Address:Beijing Syntong Tech Delvelop co.,LTD }

{ Email:Liren.z@163.com }

{ }

{*******************************************************}

unit xpbutton;

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

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;

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;

FCanvas.Handle := 0;

end;

procedure TXPButton.SetButtonStyle(ADefault: Boolean);

begin

if (ADefault <> IsFocused) then begin

IsFocused := ADefault;

Invalidate;

end;

procedure TXPButton.SetBaseColor(Value: TColor);

begin

if (Value <> FBaseColor) then begin

FBaseColor := Value;

Shade := LoadShades(FBaseColor);

Repaint;

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 }

{ }

{ HomePage: Http://Stef.533.net/54 }

{ Http://Aojianjianghu.126.com }

{ Address:Beijing Syntong Tech Delvelop co.,LTD }

{ Email:Liren.z@163.com }

{ }

{*******************************************************}

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;

deleteobject(hrgn1);

setwindowrgn(FormHandle, hrgn3, true);

except

//RaiseException Here

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;

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) }

{ }

{ HomePage: Http://Stef.533.net/54 }

{ Http://Aojianjianghu.126.com }

{ }

{ Email:Liren.z@163.com }

{ }

{*******************************************************}

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;

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;

inherited;

end;

procedure TImgButton.MouseEnter(var Msg: TMessage);

begin

if Enabled then begin

Repaint;

Canvas.StretchDraw(ClientRect, FGMouseUp);

DrawCaption;

end;

procedure TImgButton.MouseLeave(var Msg: TMessage);

begin

if Enabled then begin

Repaint;

Canvas.StretchDraw(ClientRect, FGNormal);

DrawCaption;

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;

inherited;

end;

procedure TImgButton.Resize(Sender: TObject);

begin

if not FGNormal.Empty then begin

Width := FGNormal.Width;

Height := FGNormal.Height;

DrawCaption;

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;

procedure TImgButton.SetShowCaption(Value: Boolean);

begin

FShowCaption := Value;

Invalidate;

end;

procedure TImgButton.SetFont(Value: TFont);

begin

FFont := Value;

Canvas.Font := Value;

Invalidate;

end;

end.