用delphi编程实现XP界面效果

2024-04-17 14:32•服务端开发•阅读 621

给你个按扭=========================================================

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

{ }

{ 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.

上一篇 »delphi下实现ribbon界面的方法，一
下一篇 »用API函数在DELPHI中实现“非典型”窗体

用delphi编程实现XP界面效果

相关推荐

用delphi制作无界面的activex控件

用Delphi实现自定义颜色对话框及其构件

Anchors设定在Delphi界面设计中的用处 - 癫狂编程

Anchors设定在Delphi界面设计中的用处

delphi 用Indy实现FTP客户端

问题-delphi在某电脑，win7上是界面超乱 DPL

Delphi中根据分类数据生成树形结构的最优方法 - 癫狂编程

DELPHI实现类似仿360桌面的程序界面