[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]

    Try a rewritten label component that uses a bitmap instead of the straight
    canvas:

    unit Freelbl;

    interface

    uses
      SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
      Forms, Dialogs;

    type
      TFreeLabel = class(TGraphicControl)
      private
        { Private declarations }
        procedure WMERASEBKGND(var msg:TWMERASEBKGND); message WM_ERASEBKGND;
        procedure CMFONTCHANGED(var msg:TMsg); message CM_FONTCHANGED;
        procedure CMTEXTCHANGED(var msg:TMsg); message CM_TEXTCHANGED;
      protected
        { Protected declarations }
      public
        { Public declarations }
        constructor Create(Aowner:TComponent); override;
        procedure Paint; override;
      published
        { Published declarations }
        property Caption;
        property Align;
        property Color;
        property Font;
      end;

    procedure Register;

    implementation

    procedure Register;
    begin
      RegisterComponents('Samples', [TFreeLabel]);
    end;

    constructor TFreeLabel.Create(Aowner:TComponent);
    begin
     inherited Create(Aowner);
     ControlStyle := [csOpaque];
    end;

    procedure TFreeLabel.Paint;
    var t:TBitmap;
        r:TRect;
        Text:array[0..255] of Char;
    begin
     T:=TBitmap.Create;
     t.width:=width;
     t.height:=height;

     with t.canvas do
      begin
       brush.color:=self.color;
       r:=Rect(0,0,width,height);

       fillrect(r);

       font:=self.font;

       StrPCopy(Text, Caption);
       DrawText(t.canvas.Handle, Text, StrLen(Text), R, DT_CENTER or
          DT_VCENTER or DT_WORDBREAK);
      end;
     canvas.draw(0,0,t);
     t.free;
    end;

    procedure TFreeLabel.CMFONTCHANGED(var msg:TMsg);
    begin
     invalidate;
    end;

    procedure TFreeLabel.CMTEXTCHANGED(var msg:TMsg);
    begin
     invalidate;
    end;

    procedure TFreeLabel.WMERASEBKGND(var msg:TWMERASEBKGND);
    begin
     { Since we blot out the background in the paint method, there is no need
       to be redundant. }
     msg.result:=1;
    end;

    end.

[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]