Title: xp GroupBox
Question: I Can Create Some Xp Control That Work In Win 98 But I Wanna Try For Create Button Forms And Other I Know a little about How I can Do This But I Have Some Problem In Loading Bmp Into Canvas That If I Resize A Control The Bmp Can Resize And The Quality of That Bmp Don't Change Can Any One Help Me ?
Tanks With Best Regards HbtTundar@Gmail.com
Answer:
unit HbtXPGroupBox;
interface
uses
SysUtils,
Classes,
Controls,
Graphics,
windows,
Forms,
StdCtrls;
Const
HbtXPGroupBoxVersion=$1;// ** 1.00 **
type
TXpStyle =(StxpBlue ,StxpSilver ,StxpOliveGreen,stCoughDropLicorice,
stCoughDropBerry,stCoughDropCherry,stCoughDropCinnamon,
stCoughDropGrape,stCoughDropLime,stCoughDropOrange,stGucciBlue,
stGucciGreen,StPearl);
THbtXPGroupBox = class(TCustomGroupBox)
private
FVersion:Integer;
FParentForm :TForm;
FBorderColor :TColor;
FCaptionColor :Tcolor;
FXpStyle : TxpStyle;
procedure SetBorderColor(const Value: TColor);
procedure SetCaptiponColor(const Value: TColor);
function GetVersion: string;
procedure SetVersion(const Value: string);
procedure setxpStyle(const Value: TxpStyle);
protected
procedure Paint; override;
public
constructor Create(Owner:TComponent);override;
destructor Destroy;override;
published
property Align;
property Anchors;
property BiDiMode;
property Caption;
property Constraints;
property DockSite;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Font;
property ParentBackground default True;
property ParentBiDiMode;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property TabOrder;
property TabStop;
property Visible;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDockDrop;
property OnDockOver;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnGetSiteInfo;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
property OnUnDock;
property BorderColor :TColor read FBorderColor Write SetBorderColor default $00C8D0D4;//$00C8D0D4{SilverStyle};//$00C8D0D4{Oliva Green Style}{$00C69C9C CoughtDrop Licorice}
property CaptionColor :TColor read FCaptionColor Write SetCaptiponColor default $00E35400; //{Oliva Green} $0000509F
property xpStyle : TxpStyle read FXpStyle Write setxpStyle default StXpblue;
property Version :string read GetVersion Write SetVersion;
end;
Procedure Register;
implementation
{ THbtXPGroupBox }
constructor THbtXPGroupBox.Create(Owner: TComponent);
begin
FParentForm := TForm(Owner);
FCaptionColor := $00E35400;
FBorderColor := $00C8D0D4;
FVersion := HbtXPGroupBoxVersion;
inherited;
Color := FParentForm.Color;
end;
destructor THbtXPGroupBox.Destroy;
begin
inherited;
end;
function THbtXPGroupBox.GetVersion: string;
begin
Result := Format( '%d.%d', [ Hi( FVersion ), Lo( FVersion ) ] );
end;
procedure THbtXPGroupBox.Paint;
var
H: Integer;
R: TRect;
Flags: Longint;
CaptionRect,
OuterRect: TRect;
Size: TSize;
begin
with Canvas do
begin
Font := Self.Font;
H := TextHeight('0');
R := Rect(0, H div 2 - 1, Width, Height);
Brush.Color := Color;
Brush.Style := bsClear;
Pen.Color := FBorderColor;
Pen.Width :=1;
Canvas.RoundRect(0,H div 2 -1 ,Width,Height,5,5);
if Text '' then
begin
Brush.Style := bsClear;
Brush.Color := Color;
if not UseRightToLeftAlignment then
begin
R := Rect(8, 0, 0, H);
end
else
begin
R := Rect(R.Right - Canvas.TextWidth(Text) - 8, 0, 0, H);
end;
Flags := DrawTextBiDiModeFlags(DT_SINGLELINE);
DrawText(Handle, PChar(Text), Length(Text), R, Flags or DT_CALCRECT);
SetTextColor(Handle,FCaptionColor);
DrawText(Handle, PChar(Text), Length(Text), R, Flags);
end;
end;
end;
procedure THbtXPGroupBox.SetBorderColor(const Value: TColor);
begin
FBorderColor := Value;
end;
procedure THbtXPGroupBox.SetCaptiponColor(const Value: TColor);
begin
FCaptionColor := Value;
end;
procedure THbtXPGroupBox.SetVersion(const Value: string);
begin
// *** Does nothing ***
end;
procedure THbtXPGroupBox.setxpStyle(const Value: TxpStyle);
begin
FXpStyle := Value;
case Value of
StxpBlue :
begin
FBorderColor := $00C8D0D4;
FCaptionColor := $00E35400;
end;
StxpSilver :
begin
FBorderColor := $00C8D0D4;
FCaptionColor := $00E35400;
end;
StxpOliveGreen :
begin
FBorderColor := $00C8D0D4;
FCaptionColor := $0000509F;
end;
stCoughDropLicorice :
begin
FBorderColor := $00C69C9C;
FCaptionColor := $00BE8E8E;
end;
stCoughDropBerry :
begin
FBorderColor := $00FCB05C;
FCaptionColor := $00FEB447;
end;
stCoughDropCherry:
begin
FBorderColor := $005C5CB0;
FCaptionColor := $004747B4;
end;
stCoughDropCinnamon:
begin
FBorderColor := $00B0B0FC;
FCaptionColor := $00B4B4FE;
end;
stCoughDropGrape :
begin
FBorderColor := $00EE727F;
FCaptionColor := $00F36B79;
end;
stCoughDropLime :
begin
FBorderColor := $00408000;
FCaptionColor := $003CAA3C;
end;
stCoughDropOrange :
begin
FBorderColor := $004080FF;
FCaptionColor := $004080FF;
end;
stGucciBlue :
begin
FBorderColor := $00606060;
FCaptionColor := $00242424;
end;
stGucciGreen :
begin
FBorderColor := $00606060;
FCaptionColor := $00242424;
end;
StPearl :
begin
FBorderColor := $00C8D0D4;
FCaptionColor := $00CB8B64;
end;
end;//end of case
Repaint;
end;
Procedure Register;
begin
RegisterComponents('Sample', [THbtXPGroupBox]);
end;
end.