unit LWGradientPanel;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics,
Controls, Forms, Dialogs, ExtCtrls;
{$R LWGradientPanel.dcr}
type
TLWFillDirection = (fdTopToBottom, fdBottomToTop,
fdLeftToRight, fdRightToLeft);
TLWGradientPanel = class(TCustomPanel)
private
{ Private declarations }
FGradientStartColor : TColor;
FGradientEndColor : TColor;
FGradient : boolean;
FGradientFillDir : TLWFillDirection;
FTextFillsPanel : boolean;
FIcon : TPicture;
procedure SetGradientStartColor(value : TColor);
procedure SetGradientEndColor(value : TColor);
procedure SetGradient(value : boolean);
procedure SetGradientFillDir(value : TLWFillDirection);
procedure SetTextFillsPanel(value : boolean);
procedure SetIcon(value : TPicture);
protected
{ Protected declarations }
procedure paint; override;
constructor create(AOwner : TComponent); override;
destructor destroy; override;
procedure loaded; override;
public
{ Public declarations }
published
{ Published declarations }
property GradientStartColor : TColor read FGradientStartColor
write SetGradientStartColor;
property GradientEndColor : TColor read FGradientEndColor
write SetGradientEndColor;
property Gradient : boolean read FGradient write SetGradient;
property GradientFillDir : TLWFillDirection
read FGradientFillDir write SetGradientFillDir;
property TextFillsPanel : boolean read FTextFillsPanel
write SetTextFillsPanel;
property Icon : TPicture read FIcon write SetIcon;
property Align;
property Alignment;
property BevelInner;
property BevelOuter;
property BevelWidth;
property BorderWidth;
property BorderStyle;
property DragCursor;
property DragMode;
property Enabled;
property FullRepaint;
property Caption;
property Color;
property Ctl3D;
property Font;
property Locked;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property TabOrder;
property TabStop;
property Visible;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnResize;
property OnStartDrag;
end;
procedure Register;
implementation
function Min(A, B: Longint): Longint;
begin
if A < B then Result := A
else Result := B;
end;
function Max(A, B: Longint): Longint;
begin
if A > B then Result := A
else Result := B;
end;
function WidthOf(R: TRect): Integer;
begin
Result := R.Right - R.Left;
end;
function HeightOf(R: TRect): Integer;
begin
Result := R.Bottom - R.Top;
end;
procedure GradientFillRect(Canvas: TCanvas; ARect: TRect; StartColor,
EndColor: TColor; Direction: TLWFillDirection; Colors: Byte);
var
StartRGB: array[0..2] of Byte; { Значения RGB }
RGBDelta: array[0..2] of Integer;
ColorBand: TRect;
I, Delta: Integer;
Brush: HBrush;
begin
if IsRectEmpty(ARect) then Exit;
if Colors < 2 then begin
Brush := CreateSolidBrush(ColorToRGB(StartColor));
FillRect(Canvas.Handle, ARect, Brush);
DeleteObject(Brush);
Exit;
end;
StartColor := ColorToRGB(StartColor);
EndColor := ColorToRGB(EndColor);
case Direction of
fdTopToBottom, fdLeftToRight: begin
{ Set the Red, Green and Blue colors }
StartRGB[0] := GetRValue(StartColor);
StartRGB[1] := GetGValue(StartColor);
StartRGB[2] := GetBValue(StartColor);
{ Calculate the difference between begin and end RGB values }
RGBDelta[0] := GetRValue(EndColor) - StartRGB[0];
RGBDelta[1] := GetGValue(EndColor) - StartRGB[1];
RGBDelta[2] := GetBValue(EndColor) - StartRGB[2];
end;
fdBottomToTop, fdRightToLeft: begin
{ Set the Red, Green and Blue colors }
{ Reverse of TopToBottom and LeftToRight directions }
StartRGB[0] := GetRValue(EndColor);
StartRGB[1] := GetGValue(EndColor);
StartRGB[2] := GetBValue(EndColor);
{ Calculate the difference between begin and end RGB values }
{ Reverse of TopToBottom and LeftToRight directions }
RGBDelta[0] := GetRValue(StartColor) - StartRGB[0];
RGBDelta[1] := GetGValue(StartColor) - StartRGB[1];
RGBDelta[2] := GetBValue(StartColor) - StartRGB[2];
end;
end; {case}
{ Calculate the color band's coordinates }
ColorBand := ARect;
if Direction in [fdTopToBottom, fdBottomToTop] then begin
Colors := Max(2, Min(Colors, HeightOf(ARect)));
Delta := HeightOf(ARect) div Colors;
end
else begin
Colors := Max(2, Min(Colors, WidthOf(ARect)));
Delta := WidthOf(ARect) div Colors;
end;
with Canvas.Pen do begin { Set the pen style and mode }
Style := psSolid;
Mode := pmCopy;
end;
{ Perform the fill }
if Delta > 0 then begin
for I := 0 to Colors do begin
case Direction of
{ Calculate the color band's top and bottom coordinates }
fdTopToBottom, fdBottomToTop: begin
ColorBand.Top := ARect.Top + I * Delta;
ColorBand.Bottom := ColorBand.Top + Delta;
end;
{ Calculate the color band's left and right coordinates }
fdLeftToRight, fdRightToLeft: begin
ColorBand.Left := ARect.Left + I * Delta;
ColorBand.Right := ColorBand.Left + Delta;
end;
end; {case}
{ Calculate the color band's color }
Brush := CreateSolidBrush(RGB(
StartRGB[0] + MulDiv(I, RGBDelta[0], Colors - 1),
StartRGB[1] + MulDiv(I, RGBDelta[1], Colors - 1),
StartRGB[2] + MulDiv(I, RGBDelta[2], Colors - 1)));
FillRect(Canvas.Handle, ColorBand, Brush);
DeleteObject(Brush);
end;
end;
if Direction in [fdTopToBottom, fdBottomToTop] then
Delta := HeightOf(ARect) mod Colors
else Delta := WidthOf(ARect) mod Colors;
if Delta > 0 then begin
case Direction of
{ Calculate the color band's top and bottom coordinates }
fdTopToBottom, fdBottomToTop: begin
ColorBand.Top := ARect.Bottom - Delta;
ColorBand.Bottom := ColorBand.Top + Delta;
end;
{ Calculate the color band's left and right coordinates }
fdLeftToRight, fdRightToLeft: begin
ColorBand.Left := ARect.Right - Delta;
ColorBand.Right := ColorBand.Left + Delta;
end;
end; {case}
case Direction of
fdTopToBottom, fdLeftToRight:
Brush := CreateSolidBrush(EndColor);
else {fdBottomToTop, fdRightToLeft }
Brush := CreateSolidBrush(StartColor);
end;
FillRect(Canvas.Handle, ColorBand, Brush);
DeleteObject(Brush);
end;
end;
procedure TLWGradientPanel.Loaded;
begin
inherited loaded;
end;
procedure TLWGradientPanel.paint;
var
r : Trect;
x,y : integer;
begin
r := ClientRect;
if BevelOuter <> bvNone then
if BevelOuter = bvRaised then
Frame3D(Canvas, r, clBtnHighlight, clBtnShadow, BevelWidth)
else
Frame3D(Canvas, r, clBtnShadow, clBtnHighlight, BevelWidth);
if BevelInner <> bvNone then
if BevelInner = bvRaised then
Frame3D(Canvas, r, clBtnHighlight, clBtnShadow, BevelWidth)
else
Frame3D(Canvas, r, clBtnShadow, clBtnHighlight, BevelWidth);
if FGradient then
begin
GradientFillRect(canvas, r, FGradientStartColor,
FGradientEndColor, FGradientFillDir, 255)
end;
if not FGradient then
begin
canvas.brush.color := color;
canvas.fillrect(r);
end;
canvas.brush.style := bsClear;
canvas.Font.assign(font);
if TextFillsPanel and (caption <> '') then
begin
if (canvas.TextWidth(caption) < ClientWidth) and (
canvas.TextHeight(caption) < ClientHeight) then
begin
while (canvas.TextWidth(caption) < ClientWidth - 10)
and (canvas.TextHeight(caption) < ClientHeight - 10) do
canvas.font.Size := canvas.font.Size + 1;
canvas.font.Size := canvas.font.Size - 1;
end;
end;
if FIcon.graphic = nil then
drawtextex(canvas.handle, pchar(caption), length(caption), r,
DT_END_ELLIPSIS + DT_CENTER + DT_VCENTER + DT_SINGLELINE, nil);
if FIcon.graphic <> nil then
begin
x := (self.Width div 2) - (FIcon.Width div 2);
y := (self.height div 2) - (FIcon.height div 2);
canvas.Draw(x, y, FIcon.Graphic);
end;
end;
constructor TLWGradientPanel.create(AOwner : TComponent);
begin
inherited;
FGradient := true;
FGradientEndColor := clMaroon;
FGradientStartColor := clWhite;
FTextFillsPanel := false;
FIcon := TPicture.create;
end;
destructor TLWGradientPanel.destroy;
begin
FIcon.free;
inherited;
end;
procedure TLWGradientPanel.SetIcon(value : TPicture);
begin
FIcon.assign(value);
Invalidate;
end;
procedure TLWGradientPanel.SetGradientStartColor(value : TColor);
begin
FGradientStartColor := value;
invalidate;
end;
procedure TLWGradientPanel.SetGradientEndColor(value : TColor);
begin
FGradientEndColor := value;
invalidate;
end;
procedure TLWGradientPanel.SetGradient(value : boolean);
begin
FGradient := value;
invalidate;
end;
procedure TLWGradientPanel.SetTextFillsPanel(value : boolean);
begin
FTextFillsPanel := value;
invalidate;
end;
procedure TLWGradientPanel.SetGradientFillDir(value : TLWFillDirection);
begin
FGradientFillDir := value;
invalidate;
end;
procedure Register;
begin
RegisterComponents('Lummie Wares', [TLWGradientPanel]);
end;
end.
Комментарии