translabel.pas

这部分与维生素D3

unit TransLabel;
{
	TTransLabel By Paul van Dinther Copyright Diprode 24-01-2000
	e-mail: [e-mail]
	Website: http://www.diprode.com

	TTransLabel inherits from TCustomTransCanvas. Normally you'd find the paint
	method to be overridden. In this case the DoPaint OnPaint eventhandler
	encapsulation is being overriden. Thus providing a tidy integration with
	TCustomTransCanvas. TTransLabel is like a TLabel component but it can render
	transparent and render with an additional transparent shadow.

	Have a look at GIFLine Pro on http://www.diprode.com/giflinepro.htm to see
	this component in action.
}
interface

uses
	Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
	TransCanvas;

type
	TTextLayout = (tlTop, tlCenter, tlBottom);
	TTransLabel = class(TCustomTransCanvas)
	private
		FFocusControl: TWinControl;
		FTransParent: Boolean;
		FAlignment: TAlignment;
		FAutoSize: Boolean;
		FLayout: TTextLayout;
		FWordWrap: Boolean;
		FShowAccelChar: Boolean;
		procedure AdjustBounds;
		procedure DoDrawText(PCanvas: TCanvas; var PRect: TRect; Flags: Word);
		procedure SetAlignment(Value: TAlignment);
		procedure SetFocusControl(Value: TWinControl);
		procedure SetShowAccelChar(Value: Boolean);
		procedure SetTransparent(Value: Boolean);
		procedure SetLayout(Value: TTextLayout);
    procedure SetWordWrap(Value: Boolean);
		procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
		procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
  protected
		function GetLabelText: string; virtual;
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
		procedure DoPaint(PCanvas: TCanvas); override;
		procedure SetAutoSize(Value: Boolean); virtual;
	public
		constructor Create(AOwner: TComponent); override;
		property Canvas;
	published
	published
		property Alignment: TAlignment read FAlignment write SetAlignment	default taLeftJustify;
		property AutoSize: Boolean read FAutoSize write SetAutoSize default True;
		property FocusControl: TWinControl read FFocusControl write SetFocusControl;
		property ShowAccelChar: Boolean read FShowAccelChar write SetShowAccelChar default True;
		property Transparent: Boolean read FTransparent write SetTransparent;
		property Layout: TTextLayout read FLayout write SetLayout default tlTop;
		property WordWrap: Boolean read FWordWrap write SetWordWrap default False;
		property UseCalcEvent;
		property OnCalc;
		property CanvasType;
		property TransFade;
		property TransType;
		property TransPercent;
		property TransMinCutoff;
		property TransMaxCutoff;
		property TransKeyColor;
		property TransBiasPercent;
		property ScreenBiasPercent;
		property Inverse;
		property OnPaint;
		//Standard Properties
		property Align;
		property Caption;
		property Color;
		property DragCursor;
		property DragMode;
		property Enabled;
		property Font;
		property ParentColor;
		property ParentFont;
    property ParentShowHint;
    property PopupMenu;
		property ShowHint;
		property Visible;
		property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnMouseDown;
		property OnMouseMove;
    property OnMouseUp;
		property OnStartDrag;
	end;

procedure Register;

implementation

uses consts;

procedure Register;
begin
	RegisterComponents('Diprode', [TTransLabel]);
end;

constructor TTransLabel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
	ControlStyle := ControlStyle + [csOpaque, csReplicatable];
	Width := 65;
	Height := 17;
	FAutoSize := True;
	FTransparent := True;
	FShowAccelChar := True;
end;

function TTransLabel.GetLabelText: string;
begin
	Result := Caption;
end;

procedure TTransLabel.DoDrawText(PCanvas: TCanvas; var PRect: TRect; Flags: Word);
var
	Text: string;
begin
	Text := GetLabelText;
	if (Flags and DT_CALCRECT <> 0) and ((Text = '') or FShowAccelChar and
		(Text[1] = '&') and (Text[2] = #0)) then Text := Text + ' ';
	if not FShowAccelChar then Flags := Flags or DT_NOPREFIX;
	PCanvas.Font := Font;
	if not Enabled then
	begin
		OffsetRect(PRect, 1, 1);
		PCanvas.Font.Color := clBtnHighlight;
		DrawText(PCanvas.Handle, PChar(Text), Length(Text), PRect, Flags);
		OffsetRect(PRect, -1, -1);
		PCanvas.Font.Color := clBtnShadow;
		DrawText(PCanvas.Handle, PChar(Text), Length(Text), PRect, Flags);
	end
	else
		DrawText(PCanvas.Handle, PChar(Text), Length(Text),PREct , Flags);
end;

procedure TTransLabel.DoPaint(PCanvas: TCanvas);
const
	Alignments: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);
	WordWraps: array[Boolean] of Word = (0, DT_WORDBREAK);
var
	LRect: TRect;
	DrawStyle: Integer;
begin
	inherited DoPaint(PCanvas);
	with PCanvas do
	begin
		if not Transparent then
		begin
			Brush.Color := Self.Color;
			Brush.Style := bsSolid;
			FillRect(ClientRect);
		end;
		Brush.Style := bsClear;
		LRect := ClientRect;
		DrawStyle := DT_EXPANDTABS or WordWraps[FWordWrap] or Alignments[FAlignment];
		{ Calculate vertical layout }
		if FLayout <> tlTop then
		begin
			DoDrawText(PCanvas, LRect, DrawStyle or DT_CALCRECT);
			if FLayout = tlBottom then OffsetRect(LRect, 0, Height - LRect.Bottom)
			else OffsetRect(LRect, 0, (Height - LRect.Bottom) div 2);
		end;
		DoDrawText(PCanvas, LRect, DrawStyle);
	end;
end;

procedure TTransLabel.Loaded;
begin
	inherited Loaded;
	AdjustBounds;
end;

procedure TTransLabel.AdjustBounds;
const
	WordWraps: array[Boolean] of Word = (0, DT_WORDBREAK);
var
	DC: HDC;
	X: Integer;
	Rect: TRect;
begin
	if not (csReading in ComponentState) and FAutoSize then
	begin
		Rect := ClientRect;
		DC := GetDC(0);
		Canvas.Handle := DC;
		DoDrawText(Canvas, Rect, (DT_EXPANDTABS or DT_CALCRECT) or WordWraps[FWordWrap]);
		Canvas.Handle := 0;
		ReleaseDC(0, DC);
		X := Left;
		if FAlignment = taRightJustify then Inc(X, Width - Rect.Right);
		SetBounds(X, Top, Rect.Right, Rect.Bottom);
	end;
end;

procedure TTransLabel.SetAlignment(Value: TAlignment);
begin
  if FAlignment <> Value then
	begin
		FAlignment := Value;
		AdjustBounds;
		Invalidate;
  end;
end;

procedure TTransLabel.SetAutoSize(Value: Boolean);
begin
	if FAutoSize <> Value then
	begin
		FAutoSize := Value;
		AdjustBounds;
	end;
end;

procedure TTransLabel.SetFocusControl(Value: TWinControl);
begin
	FFocusControl := Value;
	if Value <> nil then Value.FreeNotification(Self);
end;

procedure TTransLabel.SetShowAccelChar(Value: Boolean);
begin
	if FShowAccelChar <> Value then
	begin
		FShowAccelChar := Value;
		Invalidate;
	end;
end;

procedure TTransLabel.SetTransparent(Value: Boolean);
begin
	if Transparent <> Value then begin
		FTransParent := Value;
		if FTransParent then ControlStyle := ControlStyle - [csOpaque]
		else ControlStyle := ControlStyle + [csOpaque];
		Invalidate;
	end;
end;

procedure TTransLabel.SetLayout(Value: TTextLayout);
begin
  if FLayout <> Value then
  begin
    FLayout := Value;
    Invalidate;
  end;
end;

procedure TTransLabel.SetWordWrap(Value: Boolean);
begin
  if FWordWrap <> Value then
	begin
		FWordWrap := Value;
		AdjustBounds;
    Invalidate;
	end;
end;

procedure TTransLabel.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = FFocusControl) then
    FFocusControl := nil;
end;

procedure TTransLabel.CMTextChanged(var Message: TMessage);
begin
  Invalidate;
	AdjustBounds;
end;

procedure TTransLabel.CMFontChanged(var Message: TMessage);
begin
  inherited;
	AdjustBounds;
end;

procedure TTransLabel.CMDialogChar(var Message: TCMDialogChar);
begin
  if (FFocusControl <> nil) and Enabled and ShowAccelChar and
    IsAccel(Message.CharCode, Caption) then
    with FFocusControl do
      if CanFocus then
      begin
        SetFocus;
        Message.Result := 1;
      end;
end;


end.