home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
PC World Komputer 1998 April A
/
Pcwk4a98.iso
/
PROGRAM
/
DELPHI16
/
KTMBEVEL
/
KTMBEVEL.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1997-11-19
|
32KB
|
1,227 lines
unit ktMBevel; { v2.1b 11/20/1997 - Bugfix in bspPortrait painting}
interface
uses
{$IFDEF Win32} Windows, {$ELSE} WinTypes, WinProcs, {$ENDIF} Classes,
ExtCtrls, Controls, Graphics, SysUtils, Messages;
type
TBevelStyle = (bstLowered, bstNone, bstRaised);
TBevelShape = (bspBottomLine, bspLeftLine, bspPortrait, bspRect, bspRightLine,
bspTopLine);
TBevelWidth = 1..MaxInt;
TBorderWidth = 0..MaxInt;
TDensity = 0..100;
TShadowStyle = (ssBlack, ssCopy, ssDithered, ssMask, ssMaskNotPen, ssMerge,
ssMergeNotPen, ssNot, ssNotAND, ssNotCopy, ssNotMask, ssNotMerge,
ssNotOR, ssNotXOR, ssTransparent, ssWhite, ssXOR);
TTransparence = (trNone, trSemi, trTransparent);
type
TktMBevel = class(TGraphicControl)
private
FBevelInner: TBevelStyle;
FBevelOuter: TBevelStyle;
FBevelWidth: TBevelWidth;
FBorderWidth: TBorderWidth;
FColor: TColor;
FColorDensity: TDensity;
FColorFixed: Boolean;
FColorHighlight: TColor;
FColorShadow: TColor;
FDensityDepended: Boolean;
FEdgeSize: Integer;
FShadowColor: TColor;
FShadowDensity: TDensity;
FShadowed: Boolean;
FShadowOffsetX: Integer;
FShadowOffsetY: Integer;
FShadowStyle: TShadowStyle;
FShape: TBevelShape;
FTransparence: TTransparence;
TempDensity: TDensity;
procedure SetBevelInner(Value: TBevelStyle);
procedure SetBevelOuter(Value: TBevelStyle);
procedure SetBevelWidth(Value: TBevelWidth);
procedure SetBorderWidth(Value: TBorderWidth);
procedure SetColor(Value: TColor);
procedure SetColorDensity(Value: TDensity);
procedure SetColorHighlight(Value: TColor);
procedure SetColorFixed(Value: Boolean);
procedure SetColorShadow(Value: TColor);
procedure SetDensityDepended(Value: Boolean);
procedure SetEdgeSize(Value: Integer);
procedure SetShadowColor(Value: TColor);
procedure SetShadowDensity(Value: TDensity);
procedure SetShadowed(Value: Boolean);
procedure SetShadowOffsetX(Value: Integer);
procedure SetShadowOffsetY(Value: Integer);
procedure SetShadowStyle(Value: TShadowStyle);
procedure SetShape(Value: TBevelShape);
procedure SetTransparence(Value: TTransparence);
protected
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Align;
property BevelInner: TBevelStyle read FBevelInner write SetBevelInner
default bstRaised;
property BevelOuter: TBevelStyle read FBevelOuter write SetBevelOuter
default bstLowered;
property BevelWidth: TBevelWidth read FBevelWidth write SetBevelWidth default 1;
property BorderWidth: TBorderWidth read FBorderWidth write SetBorderWidth
default 0;
property Color: TColor read FColor write SetColor default clBtnFace;
property ColorFixed: Boolean read FColorFixed write SetColorFixed default True;
property ColorHighlight: TColor read FColorHighlight write SetColorHighlight
default clBtnHighlight;
property ColorShadow: TColor read FColorShadow write SetColorShadow
default clBtnShadow;
property ColorDensity: TDensity read FColorDensity write SetColorDensity
default 100;
property DensityDepended: Boolean read FDensityDepended write
SetDensityDepended default True;
property EdgeSize: Integer read FEdgeSize write SetEdgeSize default 15;
property ParentShowHint;
property ShadowColor: TColor read FShadowColor write SetShadowColor
default clGray;
property ShadowDensity: TDensity read FShadowDensity write SetShadowDensity
default 60;
property Shadowed: Boolean read FShadowed write SetShadowed default False;
property ShadowOffsetX: Integer read FShadowOffsetX write SetShadowOffsetX
default 3;
property ShadowOffsetY: Integer read FShadowOffsetY write SetShadowOffsetY
default 3;
property ShadowStyle: TShadowStyle read FShadowStyle write SetShadowStyle
default ssDithered;
property Shape: TBevelShape read FShape write SetShape default bspRect;
property ShowHint;
property Transparence: TTransparence read FTransparence write SetTransparence
default trNone;
property Visible;
end;
{ TktMultiBevel Class Inheritance }
TktMultiBevel = class(TktMBevel)
private
protected
public
constructor Create(AOwner: TComponent); override;
published
property Align;
property BevelInner;
property BevelOuter;
property BevelWidth;
property BorderWidth;
property Color;
property ColorFixed;
property ColorHighlight;
property ColorShadow;
property EdgeSize;
property ParentShowHint;
property ShadowColor;
property Shadowed;
property ShadowOffsetX;
property ShadowOffsetY;
property ShadowStyle;
property Shape;
property ShowHint;
property Transparence;
property Visible;
end;
{ TktBevelButton Class Inheritance }
TktBevelButton = class(TktMBevel)
private
FOnEnter: TNotifyEvent;
FOnExit: TNotifyEvent;
FOnMouseDown: TNotifyEvent;
FOnMouseUp: TNotifyEvent;
protected
procedure Paint; override;
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;
procedure CMMouseEnter(var msg:TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var msg: TMessage); message CM_MOUSELEAVE;
published
property Align;
property BevelInner;
property BevelOuter;
property BevelWidth;
property BorderWidth;
property Color;
property ColorDensity;
Property DensityDepended;
property ColorFixed;
property ColorHighlight;
property ColorShadow;
property EdgeSize;
property ParentShowHint;
property ShadowColor;
property ShadowDensity;
property Shadowed;
property ShadowOffsetX;
property ShadowOffsetY;
property ShadowStyle;
property Shape;
property ShowHint;
property Transparence;
property Visible;
property OnClick;
property OnEnter: TNotifyEvent read FOnEnter write FOnEnter;
property OnExit: TNotifyEvent read FOnExit write FOnExit;
property OnMouseDown: TNotifyEvent read FOnMouseDown write FOnMouseDown;
property OnMouseUp: TNotifyEvent read FOnMouseUp write FOnMouseUp;
end;
procedure Register;
implementation
{$IFDEF Win32}
{$R *.d32}
{$ELSE}
{$R *.d16}
{$ENDIF}
procedure Register;
begin
RegisterComponents('Samples',[TktMultiBevel, TktBevelButton]);
end;
{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
{ Utilities }
function Min(X, Y: Integer): Integer;
begin
if X < Y then Result:= X else Result:= Y;
end;
function Max(X, Y: Integer): Integer;
begin
if X > Y then Result:= X else Result:= Y;
end;
function CheckBackground(Canvas: TCanvas; var Rect: TRect): Boolean;
var
x: Integer; SColor: TColor;
begin
Result:= False;
with Canvas, Rect do
begin
SColor:= Pixels[Left,Top];
for x:= Left + 1 to Right - 1 do
begin
Result:= abs((SColor - Pixels[x, Top])) > 2;
if Result = True then Break;
end;
end;
end;
function CorrectColor(C : Real) : Integer;
begin
Result := Round(C);
if Result > 255 then Result := 255;
if Result < 0 then Result := 0;
end;
function MergeColorExt(C1, C2 : TColor; Grade: Byte) : TColor;
var
R, G, B : Real;
begin
R := (GetRValue(C1) * Grade / 100 + GetRValue(C2) * (100-Grade) / 100);
G := (GetGValue(C1) * Grade / 100 + GetGValue(C2) * (100-Grade) / 100);
B := (GetBValue(C1) * Grade / 100 + GetBValue(C2) * (100-Grade) / 100);
Result := RGB(CorrectColor(R), CorrectColor(G), CorrectColor(B));
end;
procedure Frame3DPortrait(Canvas: TCanvas; var Rect: TRect;
topColor, BottomColor: TColor; Width: Integer; Edge: Integer);
var
P1, P2, P3, P4, P5, P6, P7, P8: TPoint;
i: Integer;
begin
dec(Rect.Bottom);
dec(Rect.Right);
for i:= 0 to Width - 1 do
begin
with Canvas, Rect do
begin
P1.x:= Left + i;
P1.y:= Bottom - Edge - i div 2;
P2.x:= P1.x;
P2.y:= Top + Edge + i div 2;
P3.x:= Left + Edge + i div 2;
P3.y:= Top + i;
P4.x:= Right - Edge - i div 2;
P4.y:= P3.y;
P5.x:= Right - i;
P5.y:= P2.y;
P6.x:= P5.x;
P6.y:= P1.y;
P7.x:= P4.x;
P7.y:= Bottom - i;
P8.x:= P3.x;
P8.y:= P7.y;
Pen.Width:= 1;
Pen.Color:= TopColor;
PolyLine([P1, P2, P3, P4, P5]);
Pen.Color:= BottomColor;
PolyLine([P5, P6, P7, P8, P1]);
end;
end;
for i:= 1 to (Width - 1) div 2 do
begin
with Canvas, Rect do
begin
Pen.Color:= TopColor;
P2.x:= Left + 2*i - 1;
P2.y:= Top + Edge + i;
MoveTo(Left + Edge + i - 1,Top + 2*i);
LineTo(P2.x,P2.y);
P5.x:= Right - 2*i + 1;
P5.y:= P2.y;
MoveTo(Right - Edge - i + 1,Top + 2*i);
LineTo(P5.x,P5.y);
Pen.Color:= BottomColor;
P6.x:= P5.x;
P6.y:= Bottom - Edge - i;
MoveTo(Right - Edge - i + 1,Bottom - 2*i);
LineTo(P6.x,P6.y);
P1.x:= P2.x;
P1.y:= P6.y;
MoveTo(Left + Edge + i - 1,Bottom - 2*i);
LineTo(P1.x,P1.y);
end;
end;
end;
procedure EffectRect(Canvas: TCanvas; var Rect: TRect; Pen: TPen);
var
i: Integer;
begin
with Canvas, Rect do
begin
if (Right -Left) < (Bottom -Top) then
begin
for i:= Left to Right do
begin
MoveTo(i, Top);
LineTo(i, Bottom + 1);
end;
end
else
begin
for i:= Top to Bottom do
begin
MoveTo(Left, i);
LineTo(Right + 1, i);
end;
end;
end;
end;
procedure DitheredRect(Canvas: TCanvas; var Rect: TRect; Color: TColor;
Density: Integer);
var
x, y: Integer;
begin
with Canvas, Rect do
begin
for y:= Top to Bottom do
for x:= Left to Right do
Pixels[x, y]:= MergeColorExt(Color, Pixels[x, y], Density);
end;
end;
procedure FrameDitheredRect(Canvas: TCanvas; var Rect: TRect;
Color: TColor; Density, Width: Integer);
var
i, j, k, l, x, y: Integer;
begin
dec(Rect.Right);
dec(Rect.Bottom);
with Canvas, Rect do
begin
i:= Top + Width;
j:= Bottom - Width;
k:= Left + Width - 1;
l:= Right - Width + 1;
for y:= Top to Bottom do
begin
if (y < i) or (y > j) then
for x:= Left to Right do
Pixels[x, y]:= MergeColorExt(Color, Pixels[x, y], Density)
else
begin
for x:= Left to k do
Pixels[x, y]:= MergeColorExt(Color, Pixels[x, y], Density);
for x:= l to Right do
Pixels[x, y]:= MergeColorExt(Color, Pixels[x, y], Density);
end;
end;
end;
end;
procedure FrameDitheredPortrait(Canvas: TCanvas; var Rect: TRect;
Color: TColor; Density, Width, Edge: Integer);
var
P1, P2, P3, P4: TPoint;
i, j, k, l, m, x: Integer;
begin
dec(Rect.Bottom); dec(Rect.Right);
with Canvas, Rect do
begin
j:= Bottom - Top;
for i:= 1 to Width do
begin
P1.x:= Left + Edge - i;
P1.y:= Top + i - 1;
P2.x:= Right - Edge + i;
for x:= P1.x to P2.x do
Pixels[x, P1.y]:= MergeColorExt(Color, Pixels[x, P1.y], Density);
end;
m:= i;
for i:= m to Edge + Width div 3 do
begin
if i <= Edge then
begin
P1.x:= Left + Edge - i;
P2.x:= Right - Edge + i;
P3.x:= P1.x + Width + Width div 3;
P4.x:= P2.x - Width - Width div 3;
end
else
begin
P1.x:= Left;
P2.x:= Right;
P3.x:= P1.x + Width + Width div 3 - (i - Edge);
P4.x:= P2.x - Width - Width div 3 + (i - Edge);
end;
P1.y:= Top + i - 1;
for x:= P1.x to P3.x do
Pixels[x, P1.y]:= MergeColorExt(Color, Pixels[x, P1.y], Density);
for x:= P4.x to P2.x do
Pixels[x, P1.y]:= MergeColorExt(Color, Pixels[x, P1.y], Density);
end;
m:= i;
for i:= m to j - Edge - (Width) div 3 + 1 do
begin
P1.x:= Left;
P2.x:= Right;
P3.x:= Left + Width - 1;
P4.x:= P2.x - Width + 1;
P1.y:= Top + i - 1;
for x:= P1.x to P3.x do
Pixels[x, P1.y]:= MergeColorExt(Color, Pixels[x, P1.y], Density);
for x:= P4.x to P2.x do
Pixels[x, P1.y]:= MergeColorExt(Color, Pixels[x, P1.y], Density);
end;
m:= i;
k:= 0;
for i:= m to j - Width + 1 do
begin
l:= i - m;
begin
if i <= j - Edge + 1 then
begin
P1.x:= Left;
P2.x:= Right;
P3.x:= P1.x + Width + l;
P4.x:= P2.x - Width - l ;
end
else
begin
P1.x:= Left + k;
P2.x:= Right - k;
P3.x:= P1.x + Width + Width div 3;
P4.x:= P2.x - Width - Width div 3;
inc(k);
end;
P1.y:= Top + i - 1;
for x:= P1.x to P3.x do
Pixels[x, P1.y]:= MergeColorExt(Color, Pixels[x, P1.y], Density);
for x:= P4.x to P2.x do
Pixels[x, P1.y]:= MergeColorExt(Color, Pixels[x, P1.y], Density);
end;
end;
m:= i;
for i:= m to j + 1 do
begin
P1.x:= Left + k;
P2.x:= Right - k;
inc(k);
P1.y:= Top + i - 1;
for x:= P1.x to P2.x do
Pixels[x, P1.y]:= MergeColorExt(Color, Pixels[x, P1.y], Density);
end;
end;
end;
{ TktMBevel }
constructor TktMBevel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FBevelInner:= bstRaised;
FBevelOuter:= bstLowered;
FBevelWidth:= 1;
FBorderWidth:= 0;
FColor:= clBtnFace;
FColorDensity:= 100;
FColorFixed:= True;
FColorHighlight:= clBtnHighlight;
FColorShadow:= clBtnShadow;
FDensityDepended:= True;
FShadowDensity:= 50;
FEdgeSize:= 15;
Height:= 50;
FShadowColor:= clGray;
FShadowDensity:= 60;
FShadowed:= False;
FShadowOffsetX:= 3;
FShadowOffsetY:= 3;
FShadowStyle:= ssDithered;
FShape:= bspRect;
FTransparence:= trNone;
TempDensity:= 50;
Width:= 75;
end;
destructor TktMBevel.Destroy;
begin
inherited Destroy;
end;
procedure TktMBevel.SetBevelInner(Value: TBevelStyle);
begin
if Value <> FBevelInner then
begin
FBevelInner:= Value;
Invalidate;
end;
end;
procedure TktMBevel.SetBevelOuter(Value: TBevelStyle);
begin
if Value <> FBevelOuter then
begin
FBevelOuter:= Value;
Invalidate;
end;
end;
procedure TktMBevel.SetBevelWidth(Value: TBevelWidth);
begin
if Value <> FBevelWidth then
begin
FBevelWidth:= Value;
Invalidate;
end;
end;
procedure TktMBevel.SetBorderWidth(Value: TBorderWidth);
begin
if Value <> FBorderWidth then
begin
FBorderWidth:= Value;
Invalidate;
end;
end;
procedure TktMBevel.SetColor(Value: TColor);
begin
if FColor <> Value then FColor:= Value;
if FColorFixed then
begin
if FColor = clBtnFace then
begin
FColorHighlight:= clBtnHighlight;
FColorShadow:= clBtnShadow;
end
else
begin
FColorHighlight:= MergeColorExt(FColor,clWhite,33);
FColorShadow:= MergeColorExt(FColor,clBlack,66);
end;
end;
Invalidate;
end;
procedure TktMBevel.SetColorDensity(Value: TDensity);
begin
if FColorDensity <> Value then
begin
FColorDensity:= Value;
if FTransparence = trSemi then TempDensity:= Value;
if FDensityDepended then FShadowDensity:= Round(FColorDensity * 60 / 100);
Invalidate;
end;
end;
procedure TktMBevel.SetColorHighlight(Value: TColor);
begin
if not FColorFixed then
begin
if Value <> FColorHighlight then
begin
FColorHighlight:= Value;
Invalidate;
end;
end;
end;
procedure TktMBevel.SetColorShadow(Value: TColor);
begin
if not FColorFixed then
begin
if Value <> FColorShadow then
begin
FColorShadow:= Value;
Invalidate;
end;
end;
end;
procedure TktMBevel.SetColorFixed(Value: Boolean);
begin
if Value <> FColorFixed then FColorFixed:= Value;
if FColorFixed then SetColor(FColor)
else Invalidate;
end;
procedure TktMBevel.SetDensityDepended(Value: Boolean);
var d: TDensity;
begin
if Value <> FDensityDepended then
begin
FDensityDepended:= Value;
d:= Round(FColorDensity * 60 / 100);
if (FDensityDepended = True) and (FShadowDensity <> d) then
begin
FShadowDensity:= d;
if FShadowStyle = ssDithered then Invalidate;
end;
end;
end;
procedure TktMBevel.SetEdgeSize(Value: Integer);
begin
if Value <> FEdgeSize then
begin
FEdgeSize:= Value;
Invalidate;
end;
end;
procedure TktMBevel.SetShadowColor(Value: TColor);
begin
if Value <> FShadowColor then
begin
FShadowColor:= Value;
Invalidate;
end;
end;
procedure TktMBevel.SetShadowDensity(Value: TDensity);
begin
if not FDensityDepended then
begin
if Value <> FShadowDensity then
begin
FShadowDensity:= Value;
Invalidate;
end;
end;
end;
procedure TktMBevel.SetShadowed(Value: Boolean);
begin
if (Value <> FShadowed) and (FTransparence <> trTransparent) then
begin
FShadowed:= Value;
Invalidate;
end;
end;
procedure TktMBevel.SetShadowOffsetX(Value: Integer);
begin
if Value <> FShadowOffsetX then
begin
FShadowOffsetX:= Value;
Invalidate;
end;
end;
procedure TktMBevel.SetShadowOffsetY(Value: Integer);
begin
if Value <> FShadowOffsetY then
begin
FShadowOffsetY:= Value;
Invalidate;
end;
end;
procedure TktMBevel.SetShadowStyle(Value: TShadowStyle);
begin
if Value <> FShadowStyle then
begin
FShadowStyle:= Value;
Invalidate;
end;
end;
procedure TktMBevel.SetShape(Value: TBevelShape);
begin
if Value <> FShape then
begin
FShape:= Value;
Invalidate;
end;
end;
procedure TktMBevel.SetTransparence(Value: TTransparence);
begin
if Value <> FTransparence then
begin
FTransparence:= Value;
case FTransparence of
trTransparent : begin
FShadowed:= False;
SetColorDensity(0);
end;
trNone : SetColorDensity(100);
trSemi : SetColorDensity(TempDensity);
end;
end;
end;
procedure TktMBevel.Paint;
var
Rc, RectA: TRect;
s, s1, s2, ox, oy: Integer;
P1, P2, P3, P4, P5: TPoint;
procedure CalcShadow;
begin
case FShape of
bspTopLine : begin
P1.x:= max(ox, 0);
P1.y:= max(oy, 0);
P2.x:= min(Rc.Right, Rc.Right + ox);
P2.y:= P1.y + s - 1;
end;
bspBottomLine : begin
P1.x:= max(ox, 0);
P2.y:= min(Rc.Bottom + oy - 1, Rc.Bottom - 1);
P2.x:= min(Rc.Right, Rc.Right + ox);
P1.y:= P2.y - s + 1;
end;
bspLeftLine : begin
P1.x:= max(ox, 0);
P1.y:= max(oy, 0);
P2.x:= P1.x + s - 1;
P2.y:= min(Rc.Bottom - 1, Rc.Bottom + oy - 1);
end;
bspRightLine : begin
P2.x:= min(Rc.Right - 1, Rc.Right + ox - 1);
P1.y:= max(oy, 0);
P1.x:= P2.x - s + 1;
P2.y:= min(Rc.Bottom + oy - 1, Rc.Bottom - 1);
end;
bspPortrait,
bspRect : begin
P1.x:= max(ox, 0);
P1.y:= max(oy, 0);
P2.x:= min(Rc.Right, Rc.Right + ox);
P2.y:= min(Rc.Bottom, Rc.Bottom + oy);
end;
end;
P3.x:= P2.x;
P3.y:= P1.y;
P4.x:= P1.x;
P4.y:= P2.y;
P5:= P1;
RectA:= rect(P1.x, P1.y, P2.x, P2.y);
end;
procedure PaintDithered;
begin
with Canvas do
begin
Pen.Mode:= pmCopy;
case Shape of
bspBottomLine,
bspLeftLine,
bspRightLine,
bspTopLine : DitheredRect(Canvas, RectA, FShadowColor, FShadowDensity);
bspRect : FrameDitheredRect(Canvas, RectA, FShadowColor, FShadowDensity, s);
bspPortrait : FrameDitheredPortrait(Canvas, RectA, FShadowColor, FShadowDensity,
s, FEdgeSize);
end;
end;
end;
procedure PaintShadow;
var
i: Integer;
begin
with Canvas do
begin
Pen.Width:= 1;
Pen.Color:= FShadowColor;
case FShadowStyle of
ssBlack : Pen.Mode:= pmBlack;
ssCopy : Pen.Mode:= pmCopy;
ssDithered : begin
if CheckBackGround(Canvas, RectA) then
begin
PaintDithered;
Exit;
end
else
begin
Pen.Mode:= pmCopy;
Pen.Color:= MergeColorExt(FShadowColor,
Pixels[RectA.Left, RectA.Top],FShadowDensity);
end;
end;
ssMask : Pen.Mode:= pmMask;
ssMaskNotPen : Pen.Mode:= pmMaskNotPen;
ssMerge : Pen.Mode:= pmMerge;
ssMergeNotPen : Pen.Mode:= pmMergeNotPen;
ssNot : Pen.Mode:= pmNot;
ssNotAND : Pen.Mode:= pmMaskPenNot;
ssNotCopy : Pen.Mode:= pmNotCopy;
ssNotMask : Pen.Mode:= pmNotMask;
ssNotMerge : Pen.Mode:= pmNotMerge;
ssNotOR : Pen.Mode:= pmMergePenNot;
ssNotXOR : Pen.Mode:= pmNotXor;
ssTransparent : Pen.Mode:= pmNop;
ssWhite : Pen.Mode:= pmWhite;
ssXOR : Pen.Mode:= pmXor;
end;
case FShape of
bspRect : begin
for i:= 1 to s do
begin
dec(P2.x);
dec(P2.y);
P3.x:= P2.x;
P4.y:= P2.y;
PolyLine([P1, P3, P2, P4, P1]);
inc(P1.x);
inc(P1.y);
P3.y:= P1.y;
P4.x:= P1.x;
end;
end;
bspPortrait : Frame3DPortrait(Canvas, RectA, Pen.Color, Pen.Color,
s, FEdgeSize);
bspBottomLine,
bspLeftLine,
bspRightLine,
bspTopLine : EffectRect(Canvas, RectA, Pen);
end;
Pen.Mode:= pmCopy;
Pen.Style:= psSolid;
end;
end;
procedure CalcBevelOuter;
begin
case FShape of
bspTopLine : begin
P1.x:= max(-ox, 0);
P1.y:= max(-oy, 0);
P2.x:= min(Rc.Right, Rc.Right - ox);
P2.y:= P1.y + s;
end;
bspBottomLine : begin
P1.x:= max(-ox, 0);
P2.y:= min(Rc.Bottom, Rc.Bottom - oy);
P2.x:= min(Rc.Right, Rc.Right - ox);
P1.y:= P2.y - s;
end;
bspLeftLine : begin
P1.x:= max(-ox, 0);
P1.y:= max(-oy, 0);
P2.x:= P1.x + s;
P2.y:= min(Rc.Bottom, Rc.Bottom - oy);
end;
bspRightLine : begin
P2.x:= min(Rc.Right, Rc.Right - ox);
P1.y:= max(-oy, 0);
P1.x:= P2.x - s;
P2.y:= min(Rc.Bottom, Rc.Bottom - oy);
end;
bspRect, bspPortrait: begin
P1.x:= max(-ox, 0);
P1.y:= max(-oy, 0);
P2.x:= min(Rc.Right, Rc.Right - ox);
P2.y:= min(Rc.Bottom, Rc.Bottom - oy);
end;
end;
RectA:= rect(P1.x, P1.y, P2.x, P2.y);
end;
procedure PaintBevelOuter;
begin
with Canvas, RectA do
begin
if FShape = bspPortrait then
begin
case FBevelOuter of
bstLowered: Frame3DPortrait(Canvas, RectA, FColorShadow, FColorHighlight,
FBevelWidth, FEdgeSize);
bstRaised : Frame3DPortrait(Canvas, RectA, FColorHighlight, FColorShadow,
FBevelWidth, FEdgeSize);
end;
end
else
case FBevelOuter of
bstLowered: Frame3D(Canvas, RectA, FColorShadow, FColorHighlight, FBevelWidth);
bstRaised : Frame3D(Canvas, RectA, FColorHighlight, FColorShadow, FBevelWidth);
end;
end;
end;
procedure CalcBorder;
var v: Integer;
begin
if FBevelOuter <> bstNone then
begin
case FShape of
bspTopLine : begin
P1.x:= max(FBevelWidth - ox, FBevelWidth);
P1.y:= max(FBevelWidth - oy, FBevelWidth);
P2.x:= min(Rc.Right - FBevelWidth - 1, Rc.Right - ox
- FBevelWidth - 1);
P2.y:= P1.y + FBorderwidth - 1;
end;
bspBottomLine : begin
P1.x:= max(FBevelWidth - ox, FBevelWidth);
P2.y:= min(Rc.Bottom - 1 - FBevelWidth, Rc.Bottom - 1
- oy - FBevelWidth);
P2.x:= min(Rc.Right - 1 - FBevelWidth, Rc.Right - 1
- ox - FBevelWidth);
P1.y:= P2.y - FBorderwidth + 1;
end;
bspLeftLine : begin
P1.x:= max(FBevelWidth - ox, FBevelWidth);
P1.y:= max(FBevelWidth - oy, FBevelWidth);
P2.x:= P1.x + FBorderWidth - 1;
P2.y:= min(Rc.Bottom - FBevelWidth - 1, Rc.Bottom - oy
- FBevelWidth - 1);
end;
bspRightLine : begin
P2.x:= min(Rc.Right - FBevelWidth - 1, Rc.Right - ox
- FBevelWidth - 1);
P1.y:= max(FBevelWidth - oy, FBevelWidth);
P1.x:= P2.x - FBorderWidth + 1;
P2.y:= min(Rc.Bottom - FBevelWidth - 1, Rc.Bottom - oy
- FBevelWidth - 1);
end;
bspRect, bspPortrait: begin
P1.x:= max(FBevelWidth - ox, FBevelWidth);
P1.y:= max(FBevelWidth - oy, FBevelWidth);
P2.x:= min(Rc.Right - FBevelWidth, Rc.Right - ox
- FBevelWidth);
P2.y:= min(Rc.Bottom - FBevelWidth, Rc.Bottom - oy
- FBevelWidth);
end;
end;
end
else
begin
case FShape of
bspTopLine : begin
P1.x:= max(- ox, 0);
P1.y:= max(- oy, 0);
P2.x:= min(Rc.Right - 1, Rc.Right - 1 - ox);
P2.y:= P1.y + FBorderwidth - 1;
end;
bspBottomLine : begin
P1.x:= max(- ox, 0);
P2.y:= min(Rc.Bottom - 1, Rc.Bottom - 1 - oy);
P2.x:= min(Rc.Right - 1, Rc.Right - 1 - ox);
P1.y:= P2.y - FBorderwidth + 1;
end;
bspLeftLine : begin
P1.x:= max(- ox, 0);
P1.y:= max(- oy, 0);
P2.x:= P1.x + FBorderWidth - 1;
P2.y:= min(Rc.Bottom - 1, Rc.Bottom - 1 - oy);
end;
bspRightLine : begin
P2.x:= min(Rc.Right, Rc.Right - ox);
P1.y:= max(- oy, 0);
P1.x:= P2.x - FBorderWidth + 1;
P2.y:= min(Rc.Bottom - 1, Rc.Bottom - 1 - oy);
end;
bspRect, bspPortrait: begin
P1.x:= max(-ox, 0);
P1.y:= max(-oy, 0);
P2.x:= min(Rc.Right, Rc.Right - ox);
P2.y:= min(Rc.Bottom, Rc.Bottom - oy);
end;
end;
end;
RectA:= rect(P1.x, P1.y, P2.x, P2.y);
end;
procedure PaintDitheredBorder;
begin
case FShape of
bspPortrait : if FBevelOuter <> bstNone then
FrameDitheredPortrait(Canvas, RectA, FColor, FColorDensity,
FBorderWidth, FEdgeSize - (FBevelWidth) div 2)
else
FrameDitheredPortrait(Canvas, RectA, FColor, FColorDensity,
FBorderWidth, FEdgeSize);
bspRect : FrameDitheredRect(Canvas, RectA, FColor, FColorDensity,
FBorderWidth);
bspBottomLine,
bspLeftLine,
bspRightLine,
bspTopLine : DitheredRect(Canvas, RectA, FColor, FColorDensity);
end;
end;
procedure PaintFilledBorder(Color: TColor);
var
i: Integer;
begin
with Canvas do
case FShape of
bspPortrait : Frame3DPortrait(Canvas, RectA, Color, Color, FBorderWidth,
FEdgeSize - FBevelWidth div 2 - 1);
bspRect : begin
Brush.Color:= Color;
for i:= 1 to FBorderWidth do
begin
FrameRect(RectA);
inc(P1.x);
inc(P1.y);
dec(P2.x);
dec(P2.y);
RectA:= rect(P1.x, P1.y, P2.x, P2.y);
end;
end;
bspBottomLine,
bspLeftLine,
bspRightLine,
bspTopLine : begin
Pen.Width:= 1;
Pen.Color:= Color;
Pen.Mode:= pmCopy;
EffectRect(Canvas, RectA, Pen);
end;
end;
end;
procedure PaintBorder;
begin
with Canvas, RectA do
begin
if (FTransparence = trSemi) or (FColorDensity < 100) then
begin
if FShadowed or CheckBackGround(Canvas, RectA) then PaintDitheredBorder
else
PaintFilledBorder(MergeColorExt(FColor, Pixels[RectA.Left, RectA.Top],
FColorDensity));
end
else PaintFilledBorder(FColor);
end;
end;
procedure CalcBevelInner;
begin
P1.x:= max(s1 - ox, s1);
P1.y:= max(s1 - oy, s1);
P2.x:= min(Rc.Right - s1, Rc.Right - ox - s1);
P2.y:= min(Rc.Bottom - s1, Rc.Bottom - oy - s1);
RectA:= rect(P1.x, P1.y, P2.x, P2.y);
end;
procedure PaintBevelInner;
var E: Integer;
begin
with Canvas, RectA do
begin
if Shape = bspPortrait then
begin
if FBorderWidth > 0 then
begin
if FBevelOuter <> bstNone then
E:= FEdgeSize - (FBevelWidth + 2) div 2 - (FBorderWidth + 2) div 2
else
E:= FEdgeSize - 1 - (FBorderWidth + 2) div 2;
end
else
begin
if FBevelOuter <> bstNone then
E:= FEdgeSize - (FBevelWidth + 2) div 2
else
E:= FEdgeSize;
end;
case FBevelInner of
bstLowered: Frame3DPortrait(Canvas, RectA, FColorShadow, FColorHighlight,
FBevelWidth, E);
bstRaised : Frame3DPortrait(Canvas, RectA, FColorHighlight, FColorShadow,
FBevelWidth, E);
end;
end
else
case FBevelInner of
bstLowered: Frame3D(Canvas, RectA, FColorShadow, FColorHighlight, FBevelWidth);
bstRaised : Frame3D(Canvas, RectA, FColorHighlight, FColorShadow, FBevelWidth);
end;
end;
end;
procedure BevelRect;
begin
if (FBevelInner <> bstNone) and ((FShape = bspRect) or
(FShape = bspPortrait)) then s2:= FBevelWidth
else s2:= 0;
if FBevelOuter = bstNone then s1:= FBorderWidth
else
case FShape of
bspRect,bspPortrait : s1:= FBevelWidth + FBorderWidth;
bspBottomLine, bspLeftLine, bspRightLine, bspTopLine:
s1:= 2*FBevelWidth + FBorderWidth;
end;
s:= s1 + s2;
if not FShadowed then
begin
ox:= 0;
oy:= 0;
end
else
begin
if s > 0 then
begin
ox:= FShadowOffsetX;
oy:= FShadowOffsetY;
CalcShadow;
PaintShadow;
end;
end;
if (FBorderWidth > 0) and (FTransparence <> trTransparent) then
begin
CalcBorder;
PaintBorder;
end;
if FBevelOuter <> bstNone then
begin
CalcBevelOuter;
PaintBevelOuter;
end;
if (FBevelInner <> bstNone)
and ((FShape = bspRect) or (FShape = bspPortrait)) then
begin
CalcBevelInner;
PaintBevelInner;
end;
end;
begin
Rc:= GetClientRect;
BevelRect;
end;
{ TktMultiBevel }
constructor TktMultiBevel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
end;
{ TktBevelButton }
constructor TktBevelButton.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle:= [csCaptureMouse, csClickEvents, csFramed];
FBevelOuter:= bstNone;
Height:= 35;
Width:= 90;
end;
procedure TktBevelButton.Paint;
var
RectA, Rc: TRect;
P1, P2: TPoint;
ox, oy: Integer;
begin
inherited Paint;
if csDesigning in ComponentState then
begin
Rc:= GetClientRect;
if not FShadowed then
begin
P1.x:= Rc.Left;
P1.y:= Rc.Top;
P2.x:= Rc.Right;
P2.y:= Rc.Bottom;
end
else
begin
ox:= FShadowOffsetX;
oy:= FShadowOffsetY;
P1.x:= max(-ox, 0);
P1.y:= max(-oy, 0);
P2.x:= min(Rc.Right, Rc.Right - ox);
P2.y:= min(Rc.Bottom, Rc.Bottom - oy);
end;
RectA:= Rect(P1.x, P1.y, P2.x, P2.y);
Frame3D(Canvas, RectA, clBlack, clBlack, 1);
end;
end;
procedure TktBevelButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
SetBevelOuter(bstLowered);
inherited MouseDown(Button, Shift, X, Y);
if Assigned(FOnMouseDown) then FOnMouseDown(Self);
end;
procedure TktBevelButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
SetBevelOuter(bstRaised);
inherited MouseUp(Button, Shift, X, Y);;
if Assigned(FOnMouseUp) then FOnMouseUp(Self);
end;
procedure TktBevelButton.CMMouseEnter(var msg:TMessage);
begin
inherited;
SetBevelOuter(bstRaised);
if Assigned(FOnEnter) then FOnEnter(Self);
end;
procedure TktBevelButton.CMMouseLeave(var msg: TMessage);
begin
inherited;
SetBevelOuter(bstNone);
if Assigned(FOnExit) then FOnExit(Self);
end;
end.
