Mega Code Archive
Functional 3D Label RV3DLabel
<![CDATA[
Title: Functional 3D Label RV3DLabel
Question: How can I create a custom 3D Label?
Answer:
unit RV3DLabel;
interface
uses
SysUtils, windows, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls,Menus;
type
T3DEffect = (Normal3d,Resit3d,Raised3d,Shadowed3d);
TRV3DLabel = class(TLabel)
private
procedure setStyleEffect(Value : T3DEffect);
procedure SetShadowColor(Value:TColor);
procedure SetWhiteColor(Value:TColor);
procedure DoDrawText(var Rect: TRect; Flags: Word);
procedure SetFhOffSet(Value: Integer);
procedure SetFvOffSet(Value: Integer);
procedure SetShadeLT(Value: Boolean);
procedure WMMouseMove(var Msg: TWMMouseMove); message WM_MOUSEMOVE;
procedure DoMouseOut(Msg: TWMMouseMove);
protected
MouseOut:TNotifyEvent;
F3DEffect: T3DEffect;
FShadowColor: TColor;
FWhiteColor: TColor;
FLast: TColor;
FhOffSet,FvOffSet: Integer;
FShadeLTSet: Boolean;
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Align;
property Caption;
property AStyle3D: T3DEffect read F3DEffect write setStyleEffect default Normal3d;
property AShadeRightBottom: TColor read FShadowColor write SetShadowColor default clGray;
property AShadeLeftTop: TColor read FWhiteColor write SetWhiteColor default clWhite;
property AHShadeOffSet: Integer read FhOffSet write SetFhOffSet default 5;
property AVShadeOffSet: Integer read FvOffSet write SetFvOffSet default -5;
property AShadeLTSet: Boolean read FShadeLTSet write setShadeLT default true;
property DragCursor;
property DragMode;
property Enabled;
property Font;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Visible;
property Transparent;
property Width;
property Top;
property Left;
property Height;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnMouseOut:TNotifyEvent read MouseOut write MouseOut;
end;
procedure Register;
implementation
constructor TRV3DLabel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Transparent:=True;
ParentColor:=False;
FShadowColor:=clGray;
FWhiteColor:=clWhite;
FhOffSet:=5;
FvOffSet:=-5;
FLast:=clWhite;
end;
destructor TRV3DLabel.Destroy;
begin
inherited Destroy;
end;
procedure TRV3DLabel.DoDrawText(var Rect: TRect; Flags: Word);
var
Text : PChar;
Size : Byte;
TmpRect : TRect;
UpperColor: TColor;
LowerColor: TColor;
begin
Size:=GetTextLen;
Inc(Size);
GetMem(Text,Size);
GetTextBuf(Text,Size);
if (Flags and DT_CALCRECT0) and
((Text[0]=#0) or ShowAccelChar and
(Text[0]='&') and (Text[1]=#0)) then
StrCopy(Text,' ');
if not ShowAccelChar then Flags:=Flags or DT_NOPREFIX;
Canvas.Font:=Font;
if F3DEffect=Resit3d then
begin
UpperColor:=FShadowColor;
LowerColor:=FWhiteColor;
end
else
begin
UpperColor:=FWhiteColor;
LowerColor:=FShadowColor;
end;
if F3DEffect in [Resit3d,Raised3d] then
begin
TmpRect:=Rect;
OffsetRect(TmpRect,1,1);
Canvas.Font.Color:=LowerColor;
DrawText(Canvas.Handle,Text,StrLen(Text),TmpRect,Flags);
TmpRect:=Rect;
OffsetRect(TmpRect,-1,-1);
Canvas.Font.Color:=UpperColor;
DrawText(Canvas.Handle,Text,StrLen(Text),TmpRect,Flags);
end
else if F3DEffect=Shadowed3d then
begin
TmpRect:=Rect;
OffsetRect(TmpRect,FhOffSet,FvOffSet);
Canvas.Font.Color:=LowerColor;
DrawText(Canvas.Handle,Text,StrLen(Text),TmpRect,Flags);
end;
Canvas.Font.Color:=Font.Color;
if not Enabled then Canvas.Font.Color:=clGrayText;
DrawText(Canvas.Handle,Text,StrLen(Text),Rect,Flags);
FreeMem(Text,Size);
end;
procedure TRV3DLabel.Paint;
const
Alignments: array[TAlignment] of Word = (DT_LEFT,DT_RIGHT,DT_CENTER);
var
Rect : TRect;
Calcrect: TRect;
Flags : LongInt;
begin
with Canvas do
begin
if not Transparent then
begin
Brush.Color:=Self.Color;
Brush.Style:=bsSolid;
FillRect(ClientRect);
end;
Brush.Style:=bsClear;
Rect:=ClientRect;
Flags := DT_EXPANDTABS or DT_WORDBREAK or Alignments[Alignment];
if Layout tlTop then
begin
CalcRect := Rect;
DoDrawText(CalcRect,Flags or DT_CALCRECT);
if Layout = tlBottom then
OffsetRect(Rect,0,Height - CalcRect.Bottom)
else
OffsetRect(Rect,0,(Height - CalcRect.Bottom) div 2);
end;
DoDrawText(Rect,Flags);
end;
end;
procedure TRV3DLabel.SetShadowColor(Value: TColor);
begin
if not (FShadowColor=Value) then
begin
FShadowColor:=Value;
invalidate;
end;
end;
procedure TRV3DLabel.SetFhOffSet(Value: Integer);
begin
if ValueFhOffSet then
begin
FhOffSet:=Value;
invalidate;
end;
end;
procedure TRV3DLabel.SetFvOffSet(Value: Integer);
begin
if ValueFvOffSet then
begin
FvOffSet:=Value;
invalidate;
end;
end;
procedure TRV3DLabel.SetWhiteColor(Value: TColor);
begin
if not (FWhiteColor=Value) and (FShadeLTSet=false) then
begin
FWhiteColor:=Value;
invalidate;
end;
end;
procedure TRV3DLabel.setStyleEffect(Value: T3DEffect);
begin
if F3DEffectValue then
begin
F3DEffect:=Value;
invalidate;
end;
end;
procedure TRV3DLabel.SetShadeLT(Value: Boolean);
begin
if FShadeLTSetValue then
begin
FShadeLTSet:=Value;
if FShadeLTSet=True then
begin
FLast:=FWhiteColor;
FWhiteColor:=clWhite;
end
else
FWhiteColor:=Flast;
end;
invalidate;
end;
procedure TRV3DLabel.WMMouseMove(var Msg: TWMMouseMove);
begin
if not MouseCapture then SetCaptureControl(Self);
if MouseCapture and ((Msg.XPosWidth) or
(Msg.YPosHeight)) then {MouseOut}
begin
SetCaptureControl(Nil);
DoMouseOut(Msg);
end;
end;
procedure TRV3DLabel.DoMouseOut(Msg: TWMMouseMove);
begin
if Assigned(MouseOut) then MouseOut(self);
end;
procedure Register;
begin
RegisterComponents('Rendez-vous', [TRV3DLabel]);
end;
end.
]]>