unit BLabel; 
 
interface 
 
uses 
  Windows, 
  SysUtils, 
  Classes, 
  Graphics, 
  StdCtrls; 
 
type 
  TBlabelChange = procedure(Sender: TObject; TextBreite: Integer) of object; 
  TBLabel = class(TCustomLabel) 
  private 
    FChange: TBlabelChange; 
    farb, merk: string; 
    sl: TStringlist; 
    bu: TFontname; 
    gr, l, verl, vrt, wl: integer; 
    bld: boolean; 
    links, rechts: TColor; 
  protected 
    procedure setfarb(s: string); 
    procedure setbu(f: TFontname); 
    procedure setgr(i: integer); 
    procedure dazu; 
    procedure machvrt; 
    procedure setbld(b: boolean); 
    procedure verlauf; 
    function wandeln(s: string): TColor; 
    procedure position; 
    procedure loaded; override; 
  public 
    procedure paint; override; 
    constructor Create(Owner: TComponent); override; 
    destructor Destroy; override; 
  published 
    property OnCaptionChange: TBlabelChange read fchange write fchange; 
    property Bunt: string read farb write setfarb; 
    property FontName: TFontname read bu write setbu; 
    property FontSize: integer read gr write setgr; 
    property FontBold: boolean read bld write setbld; 
    property Autosize; 
    property Color; 
    property Enabled; 
    property Caption; 
    property Visible; 
    property Transparent; 
    property OnClick; 
    property OnDblClick; 
    property OnMouseDown; 
    property OnMouseMove; 
    property OnMouseUp; 
    property Alignment; 
    property Layout; 
  end; 
 
procedure Register; 
 
implementation 
 
constructor TBLabel.Create(Owner: TComponent); 
begin 
  inherited Create(Owner); 
  farb := '1 CLBLUE 5 $55FF 2 $9900'; 
  sl := TStringlist.create; 
  bu := font.name; 
  gr := font.size; 
  sl.commatext := farb; 
  dazu; 
end; 
 
procedure TBLabel.dazu; 
begin 
  if odd(sl.count) then sl.add('0'); 
  sl.add('255'); 
  sl.add('0'); 
end; 
 
destructor TBLabel.Destroy; 
begin 
  sl.free; 
  inherited Destroy; 
end; 
 
procedure TBLabel.loaded; 
begin 
  merk := caption; 
  inherited; 
end; 
 
procedure TBLabel.setbu(f: TFontname); 
begin 
  if f = bu then exit; 
  bu := f; 
  canvas.font.name := bu; 
  font.name := bu; 
end; 
 
procedure TBLabel.setgr(i: integer); 
begin 
  if i = gr then exit; 
  gr := i; 
  canvas.font.size := gr; 
  font.size := gr; 
end; 
 
procedure TBlabel.machvrt; 
var h: integer; 
begin 
  h := canvas.textheight(caption); 
  case layout of 
    tlBottom: vrt := height - h; 
    tlCenter: vrt := (height - h) div 2; 
    tlTop: vrt := 0; 
  end; 
end; 
 
function TBLabel.wandeln(s: string): TColor; 
begin 
  try 
    result := StringToColor(s); 
  except 
    result := $FFFFFF; 
  end; 
end; 
 
procedure TBLabel.position; 
var x, lks: integer; 
begin 
  wl := 0; 
  l := length(caption); 
  with canvas do begin 
    for x := 1 to l do wl := wl + textwidth(caption[x]); 
    if (width < wl) and autosize then begin 
      if alignment = tarightjustify then left := left - wl + width; 
      width := wl; 
    end; 
    if alignment = tarightjustify then lks := width - wl else 
      if alignment = tacenter then lks := (width - wl) div 2 else 
        lks := 0; 
    moveto(lks, vrt); 
  end; 
end; 
 
procedure TBLabel.verlauf; 
var x, r1, r2, g1, g2, b1, b2, r, g, b: integer; 
begin 
  r1 := getrvalue(links); 
  g1 := getgvalue(links); 
  b1 := getbvalue(links); 
  r2 := getrvalue(rechts); 
  g2 := getgvalue(rechts); 
  b2 := getbvalue(rechts); 
  r := (r2 - r1) div l; 
  g := (g2 - g1) div l; 
  b := (b2 - b1) div l; 
  with canvas do begin 
    for x := 1 to (l div verl) do begin 
      font.color := rgb(r1, g1, b1); 
      textout(penpos.x, vrt, caption[x]); 
      inc(r1, r * verl); 
      inc(g1, g * verl); 
      inc(b1, b * verl); 
    end; 
    if verl = 2 then 
      for x := (l div 2) + 1 to l do begin 
        font.color := rgb(r1, g1, b1); 
        textout(penpos.x, vrt, caption[x]); 
        dec(r1, r * 2); 
        dec(g1, g * 2); 
        dec(b1, b * 2); 
      end; 
  end; 
end; 
 
procedure TBLabel.Paint; 
var x, j, k: integer; 
  b: byte; 
begin 
  if (not enabled) then inherited 
  else begin 
    machvrt; 
    with canvas do begin 
      if transparent then brush.style := bsclear 
      else begin 
        brush.color := color; 
        brush.style := bssolid; 
        canvas.fillrect(canvas.cliprect); 
      end; 
      position; 
      if merk <> caption then begin 
        if assigned(fchange) then fchange(self, wl); 
        merk := caption; 
      end; 
      if caption <> '' then begin 
        if verl > 0 then 
          verlauf else begin 
          j := 0; k := 1; 
          repeat 
            if j < sl.count then 
              font.color := wandeln(sl.strings[j + 1]); 
            try 
              b := abs(strtoint(sl.strings[j])); 
            except b := 0; end; 
            for x := 0 to b - 1 do begin 
              textout(penpos.x, vrt, caption[x + k]); 
              if x + k = l then exit; 
            end; 
            inc(k, b); 
            inc(j, 2); 
          until false; 
        end; 
      end; 
    end; 
  end; 
end; 
 
procedure TBLabel.setbld(b: boolean); 
begin 
  if b = bld then exit; 
  bld := b; 
  if b then font.style := font.style + [fsbold] 
  else font.style := font.style - [fsbold]; 
  canvas.font.style := font.style; 
end; 
 
procedure TBLabel.setfarb(s: string); 
begin 
  if farb = s then exit; 
  farb := s; 
  sl.commatext := farb; 
  dazu; 
  sl.strings[0] := uppercase(sl.strings[0]); 
  if (sl.strings[0] = 'VERLAUF1') 
    or (sl.strings[0] = 'VERLAUF2') 
    then begin 
    verl := strtoint(sl.strings[0][8]); 
    links := wandeln(sl.strings[1]); 
    rechts := wandeln(sl.strings[2]); 
  end else verl := 0; 
  repaint; 
end; 
 
procedure Register; 
begin 
  RegisterComponents('DBR', [TBLabel]); 
end; 
 
end.