www.pudn.com > SubTitle.rar > SubTitle.pas

unit SubTitle; 
 
interface 
uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, 
  Dialogs, StdCtrls; 
 
type 
  TSubTitleLabel = class(TGraphicControl) 
  private 
    FFocusControl: TWinControl; 
    FAlignment: TAlignment; 
    FAutoSize: Boolean; 
    FLayout: TTextLayout; 
    FWordWrap: Boolean; 
    FShowAccelChar: Boolean; 
    FOnMouseLeave: TNotifyEvent; 
    FOnMouseEnter: TNotifyEvent; 
    FShadowColor : TColor; 
    FShadowWidth : Integer; 
    FShadowStyle : Integer; 
    function GetTransparent: Boolean; 
    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 SetShadowColor(Value : TColor); 
    procedure SetShadowWidth(Value : Integer); 
    procedure SetShadowStyle(Value : Integer); 
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED; 
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED; 
    procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; 
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER; 
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE; 
  protected 
    procedure AdjustBounds; dynamic; 
    procedure DoDrawText(var Rect: TRect; Flags: Longint); dynamic; 
    function GetLabelText: string; virtual; 
    procedure Loaded; override; 
    procedure Notification(AComponent: TComponent; 
      Operation: TOperation); override; 
    procedure Paint; override; 
    procedure SetAutoSize(Value: Boolean);// override; 
    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 GetTransparent write SetTransparent default False; 
    property Layout: TTextLayout read FLayout write SetLayout default tlTop; 
    property WordWrap: Boolean read FWordWrap write SetWordWrap default False; 
  public 
    constructor Create(AOwner: TComponent); override; 
    property Caption; 
    property Canvas; 
    property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter; 
    property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave; 
    property ShadowColor : TColor read FShadowColor write SetShadowColor; 
    property ShadowWidth : Integer read FShadowWidth write SetShadowWidth; 
    property ShadowStyle : Integer read FShadowStyle write SetShadowStyle; 
  end; 
 
  TSubTitle = class(TSubTitleLabel) 
  published 
    property Align; 
    property Alignment; 
    property Anchors; 
    property AutoSize; 
    property BiDiMode; 
    property Caption; 
    property Color; 
    property Constraints; 
    property DragCursor; 
    property DragKind; 
    property DragMode; 
    property Enabled; 
    property FocusControl; 
    property Font; 
    property ParentBiDiMode; 
    property ParentColor; 
    property ParentFont; 
    property ParentShowHint; 
    property PopupMenu; 
    property ShowAccelChar; 
    property ShowHint; 
    property Transparent; 
    property Layout; 
    property Visible; 
    property WordWrap; 
    property ShadowColor; 
    property ShadowWidth; 
    property ShadowStyle; 
    property OnClick; 
    property OnContextPopup; 
    property OnDblClick; 
    property OnDragDrop; 
    property OnDragOver; 
    property OnEndDock; 
    property OnEndDrag; 
    property OnMouseDown; 
    property OnMouseMove; 
    property OnMouseUp; 
    property OnMouseEnter; 
    property OnMouseLeave; 
    property OnStartDock; 
    property OnStartDrag; 
  end; 
procedure Register; 
 
implementation 
 
procedure TSubTitleLabel.SetShadowColor(Value : TColor); 
begin 
  FShadowColor := Value; 
  Invalidate; 
end; 
 
procedure TSubTitleLabel.SetShadowWidth(Value : Integer); 
begin 
  FShadowWidth := Value; 
  Invalidate; 
end; 
 
constructor TSubTitleLabel.Create(AOwner: TComponent); 
begin 
  inherited Create(AOwner); 
  ControlStyle := ControlStyle + [csOpaque, csReplicatable]; 
  Width := 65; 
  Height := 17; 
  FAutoSize := True; 
  FShowAccelChar := True; 
  FShadowWidth := 0; 
  FShadowColor := clWhite; 
  FShadowStyle := 1; 
end; 
 
function TSubTitleLabel.GetLabelText: string; 
begin 
  Result := Caption; 
end; 
 
procedure TSubTitleLabel.DoDrawText(var Rect: TRect; Flags: Longint); 
var 
  Text: string; 
  x,y:integer; 
  len:integer; 
  r : TRect; 
  s : Pchar; 
begin 
  Text := GetLabelText; 
//  if((text = '') or (not visible))then 
//        exit; 
  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; 
  Flags := DrawTextBiDiModeFlags(Flags); 
  Canvas.Font := Font; 
  if not Enabled then 
  begin 
    OffsetRect(Rect, 1, 1); 
    Canvas.Font.Color := clBtnHighlight; 
    DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags); 
    OffsetRect(Rect, -1, -1); 
    Canvas.Font.Color := clBtnShadow; 
    DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags); 
  end 
  else 
  begin 
{        x := rect.Left; 
        y := rect.top; 
//        OutputDebugString(pchar(inttostr(x)+','+inttostr(y))); 
        Canvas.Font.Color := ShadowColor; 
        Canvas.TextOut(x-ShadowWidth,y-ShadowWidth,pchar(Text)); 
        Canvas.TextOut(x,y-ShadowWidth,pchar(Text)); 
        Canvas.TextOut(x+ShadowWidth,y-ShadowWidth,pchar(Text)); 
 
        Canvas.TextOut(x-ShadowWidth,y,pchar(Text)); 
        Canvas.TextOut(x+ShadowWidth,y,pchar(Text)); 
 
        Canvas.TextOut(x-ShadowWidth,y+ShadowWidth,pchar(Text)); 
        Canvas.TextOut(x,y+ShadowWidth,pchar(Text)); 
        Canvas.TextOut(x+ShadowWidth,y+ShadowWidth,pchar(Text)); 
 
        Canvas.Font.Color := Font.Color; 
        Canvas.TextOut(x,y,pchar(Text));} 
 
        s := PChar(Text); 
        len := Length(Text); 
        r := rect; 
 
        if(ShadowWidth > 0) then 
        begin 
          Canvas.Font.Color := ShadowColor; 
          OutputDebugString('test'); 
 
          if(FShadowStyle =1 ) then 
          begin 
          OffsetRect(r, -ShadowWidth, -ShadowWidth); 
          DrawText(Canvas.Handle, s, len, r, Flags); 
          r := rect; 
 
          OffsetRect(r, 0, -ShadowWidth); 
          DrawText(Canvas.Handle, s, len, r, Flags); 
          r := rect; 
 
          OffsetRect(r, +ShadowWidth, -ShadowWidth); 
          DrawText(Canvas.Handle, s, len, r, Flags); 
          r := rect; 
 
          OffsetRect(r, -ShadowWidth, 0); 
          DrawText(Canvas.Handle, s, len, r, Flags); 
          r := rect; 
 
          OffsetRect(r, +ShadowWidth, 0); 
          DrawText(Canvas.Handle, s, len, r, Flags); 
          r := rect; 
 
          OffsetRect(r, -ShadowWidth, +ShadowWidth); 
          DrawText(Canvas.Handle, s, len, r, Flags); 
          r := rect; 
 
          OffsetRect(r, 0, +ShadowWidth); 
          DrawText(Canvas.Handle, s, len, r, Flags); 
          r := rect; 
 
          OffsetRect(r, +ShadowWidth, +ShadowWidth); 
          DrawText(Canvas.Handle, s, len, r, Flags); 
          r := rect; 
          end; 
            //阴影在右下: 
          if(FShadowStyle = 2)then 
          begin 
            OffsetRect(r, ShadowWidth, ShadowWidth); 
            DrawText(Canvas.Handle, s, len, r, Flags); 
            r := rect; 
          end; 
            //阴影在右上: 
          if(FShadowStyle = 3)then 
          begin 
            OffsetRect(r, ShadowWidth, -ShadowWidth); 
            DrawText(Canvas.Handle, s, len, r, Flags); 
            r := rect; 
          end; 
            //阴影在左下: 
          if(FShadowStyle = 4)then 
          begin 
            OffsetRect(r, -ShadowWidth, ShadowWidth); 
            DrawText(Canvas.Handle, s, len, r, Flags); 
            r := rect; 
          end; 
            //阴影在左上: 
          if(FShadowStyle = 5)then 
          begin 
            OffsetRect(r, -ShadowWidth, -ShadowWidth); 
            DrawText(Canvas.Handle, s, len, r, Flags); 
            r := rect; 
          end; 
        end; 
        Canvas.Font.Color := Font.Color; 
        DrawText(Canvas.Handle, s, len, r, Flags); 
  end; 
end; 
 
procedure TSubTitleLabel.Paint; 
const 
  Alignments: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER); 
  WordWraps: array[Boolean] of Word = (0, DT_WORDBREAK); 
var 
  Rect, CalcRect: TRect; 
  DrawStyle: 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; 
    { DoDrawText takes care of BiDi alignments } 
    DrawStyle := DT_EXPANDTABS or WordWraps[FWordWrap] or Alignments[FAlignment]; 
    { Calculate vertical layout } 
    if FLayout <> tlTop then 
    begin 
      CalcRect := Rect; 
      DoDrawText(CalcRect, DrawStyle or DT_CALCRECT); 
      if FLayout = tlBottom then OffsetRect(Rect, 0, Height - CalcRect.Bottom) 
      else OffsetRect(Rect, 0, (Height - CalcRect.Bottom) div 2); 
    end; 
    DoDrawText(Rect, DrawStyle); 
//    OutputDebugString('in'); 
  end; 
end; 
 
procedure TSubTitleLabel.Loaded; 
begin 
  inherited Loaded; 
  AdjustBounds; 
end; 
 
procedure TSubTitleLabel.AdjustBounds; 
const 
  WordWraps: array[Boolean] of Word = (0, DT_WORDBREAK); 
var                                    
  DC: HDC; 
  X: Integer; 
  Rect: TRect; 
  AAlignment: TAlignment; 
begin 
  if not (csReading in ComponentState) and FAutoSize then 
  begin 
    Rect := ClientRect; 
    DC := GetDC(0); 
    Canvas.Handle := DC; 
    DoDrawText(Rect, (DT_EXPANDTABS or DT_CALCRECT) or WordWraps[FWordWrap]); 
    Canvas.Handle := 0; 
    ReleaseDC(0, DC); 
    X := Left; 
    AAlignment := FAlignment; 
    if UseRightToLeftAlignment then ChangeBiDiModeAlignment(AAlignment); 
    if AAlignment = taRightJustify then Inc(X, Width - Rect.Right); 
    SetBounds(X-2, Top-2, Rect.Right+2, Rect.Bottom+2); 
  end; 
end; 
 
procedure TSubTitleLabel.SetAlignment(Value: TAlignment); 
begin 
  if FAlignment <> Value then 
  begin 
    FAlignment := Value; 
    Invalidate; 
  end; 
end; 
 
procedure TSubTitleLabel.SetAutoSize(Value: Boolean); 
begin 
  if FAutoSize <> Value then 
  begin 
    FAutoSize := Value; 
    AdjustBounds; 
  end; 
end; 
 
function TSubTitleLabel.GetTransparent: Boolean; 
begin 
  Result := not (csOpaque in ControlStyle); 
end; 
 
procedure TSubTitleLabel.SetFocusControl(Value: TWinControl); 
begin 
  FFocusControl := Value; 
  if Value <> nil then Value.FreeNotification(Self); 
end; 
 
procedure TSubTitleLabel.SetShowAccelChar(Value: Boolean); 
begin 
  if FShowAccelChar <> Value then 
  begin 
    FShowAccelChar := Value; 
    Invalidate; 
  end; 
end; 
 
procedure TSubTitleLabel.SetTransparent(Value: Boolean); 
begin 
  if Transparent <> Value then 
  begin 
    if Value then 
      ControlStyle := ControlStyle - [csOpaque] else 
      ControlStyle := ControlStyle + [csOpaque]; 
    Invalidate; 
  end; 
end; 
 
procedure TSubTitleLabel.SetLayout(Value: TTextLayout); 
begin 
  if FLayout <> Value then 
  begin 
    FLayout := Value; 
    Invalidate; 
  end; 
end; 
 
procedure TSubTitleLabel.SetWordWrap(Value: Boolean); 
begin 
  if FWordWrap <> Value then 
  begin 
    FWordWrap := Value; 
    AdjustBounds; 
    Invalidate; 
  end; 
end; 
 
procedure TSubTitleLabel.Notification(AComponent: TComponent; 
  Operation: TOperation); 
begin 
  inherited Notification(AComponent, Operation); 
  if (Operation = opRemove) and (AComponent = FFocusControl) then 
    FFocusControl := nil; 
end; 
 
procedure TSubTitleLabel.CMTextChanged(var Message: TMessage); 
begin 
  Invalidate; 
  AdjustBounds; 
end; 
 
procedure TSubTitleLabel.CMFontChanged(var Message: TMessage); 
begin 
  inherited; 
  AdjustBounds; 
end; 
 
procedure TSubTitleLabel.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; 
 
procedure TSubTitleLabel.CMMouseEnter(var Message: TMessage); 
begin 
  inherited; 
  if Assigned(FOnMouseEnter) then 
    FOnMouseEnter(Self); 
end; 
 
procedure TSubTitleLabel.CMMouseLeave(var Message: TMessage); 
begin 
  inherited; 
  if Assigned(FOnMouseLeave) then 
    FOnMouseLeave(Self); 
end; 
 
procedure Register; 
begin 
  RegisterComponents('luke', [TSubtitle]); 
end; 
 
 
procedure TSubTitleLabel.SetShadowStyle(Value: Integer); 
begin 
  FShadowStyle := Value; 
  Invalidate; 
end; 
 
end.