scrolllabel -> kann einer eine komponente daraus machen?

[turboPASCAL]

Alles was ein Label so Braucht !

Delphi-Quellcode:

unit GSFormattedLabel;

// TGSFormattedLabel \\
// © 2005 by GSE, Genie-Soft.de \\

// Date          : 2005-04-13
// Version       : 1.0.0.0
// Author        : René Bergelt a.k.a GSE
// URL           : [url]www.Genie-Soft.de[/url]
// Copyright     : © 2005 by René Bergelt

// see the readme.txt for information about installation and usage

{*******************************************************************************
 Copyright © 2005, René Bergelt ["copyright holder(s)"]
 All rights reserved.
 Redistribution and use in source and binary forms, with or without
 modification, are permitted provided that the following conditions are met:
 1. Redistributions of source code must retain the above copyright notice, this
    list of conditions and the following disclaimer.
 2. Redistributions in binary form must reproduce the above copyright notice,
    this list of conditions and the following disclaimer in the documentation
    and/or other materials provided with the distribution.
 3. The name(s) of the copyright holder(s) may not be used to endorse or
    promote products derived from this software without specific prior written
    permission.
 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
 AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
 DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY
 DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
 (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
 ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*******************************************************************************}

interface

uses
  SysUtils, Classes, Graphics, Controls, ExtCtrls, Messages, Dialogs;

type
  TScrollOrientation = (soUp, soDown, soLeft, soRight);

type
  TGSFormattedLabel  = class(TGraphicControl)
  private
    vLines: TStringlist; // caption of the label (multiline!)
    vColor: TColor; // default background color
    vDefaultFont: TFont; // default font
    vResetFontEachLine: boolean;
    vTransparent: boolean;
    vAutoSize: boolean;
    vAlignment: TAlignment;

    // scrolling
    vScrolling: boolean;
    vScrollOrientation: TScrollOrientation;
    vScrollSpeed: integer;
    vScrollSteps: integer;

    vScrollTimer: TTimer;
    vScrollVal: Integer;

    // to display images we use a ImageList
    vImageList: TImageList;

    AboutStr: string;

    // temporary
    vTempFont: TFont;

    // some methods and functions

    procedure SetLines(Lines: TStringlist);
    procedure SetFont(Font: TFont);
    procedure SetBackColor(Color: TColor);
    procedure SetRFEL(RFEL: boolean);
    procedure SetTransparency(Transparent: boolean);
    procedure SetAlignment(Alignment: TAlignment);
    procedure SetAutoSize(AutoSize: boolean);

    procedure SetScrolling(Scrolling: boolean);
    procedure SetScrollSpeed(Speed: integer);
    procedure SetScrollSteps(Steps: integer);

    // scrolling
    procedure OnTimer(Sender: TObject);

    // drawing
    function DoCanvasAction(vArg, vParam: string): boolean;
    procedure GetTextDimensions(Text: string; var w, h: integer);
    procedure DrawText;

    procedure WndProc(var Message: TMessage); override;
  protected

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property About: string read AboutStr;

    property Lines: TStringlist read vLines write SetLines;
    property Color: TColor read vColor write SetBackColor;
    property Font: TFont read vDefaultFont write SetFont;
    property ResetFontEachLine: boolean read vResetFontEachLine write SetRFEL;
    property Transparent: boolean read vTransparent write SetTransparency;
    property AutoSize: boolean read vAutoSize write SetAutoSize;
    property Alignment: TAlignment read vAlignment write SetAlignment;

    // scrolling
    property Scrolling: boolean read vScrolling write SetScrolling;
    property ScrollOrientation: TScrollOrientation read vScrollOrientation write vScrollOrientation;
    property ScrollSpeed: integer read vScrollSpeed write SetScrollSpeed;
    property ScrollSteps: integer read vScrollSteps write SetScrollSteps;

    property ImageList: TImageList read vImageList write vImageList;

    // inherit from TGraphicControl
    property Align;
    property Visible;
    property Hint;
    property ShowHint;
    property PopUpMenu;

    // Events
    property OnClick;
    property OnContextPopUp;
    property OnDblClick;
    {property OnMouseActivate;} // no support under Delphi 6, just delete
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

procedure Register;

implementation

{$R *.Res}

procedure Register;
begin
  RegisterComponents('Eigenes', [TGSFormattedLabel]);
end;

procedure TGSFormattedLabel.WndProc(var Message: TMessage);
begin
  // the Label must be repainted
  if (Message.Msg = WM_Paint) then DrawText;
  if (Message.Msg = WM_ERASEBKGND) then exit;

  inherited;
end;

constructor TGSFormattedLabel.Create(AOwner: TComponent);
begin
  inherited;

  AboutStr := '© 2005 by GSE, Genie-Soft.de';

  vLines := TStringList.Create;
  vDefaultFont := TFont.Create;
  vTempFont := TFont.Create;

 // set the standard text
 // vLines.Text := '<s=16><bc=yellow>TGSFormattedLabel<bc=def><s=def>'#13 +
 //   '© <fs=ub>2005<fs=> by <c=red>Genie-Soft.de<c=def> '#13'<n=Wingdings>Some Symbols';
  vLines.Text := '<s=16><bc=yellow>GS<bc=def><bc=yellow><bc=blue>Formatted<bc=red>Label';

  vAlignment := taLeftJustify;
  vScrolling := False;
  vAutoSize := True;
  vTransparent := False;
  vResetFontEachLine := False;
  vColor := clBtnFace;

  vScrolling := False;
  vScrollSpeed := 500;
  vScrollSteps := 2;
  vScrollOrientation := soUp;
  vScrollTimer := TTimer.Create(self);
  vScrollTimer.Enabled := False;
  vScrollTimer.OnTimer := OnTimer;
  vScrollTimer.Interval := vScrollSpeed;
end;

destructor TGSFormattedLabel.Destroy;
begin
  vScrollTimer.Free;
  vDefaultFont.Free;
  vTempFont.Free;
  vLines.Free;

  inherited;
end;


// property methods \\

// scrolling \\

procedure TGSFormattedLabel.OnTimer(Sender: TObject);
begin
  inc(vScrollVal, vScrollSteps);
  Repaint;
end;

procedure TGSFormattedLabel.SetScrolling(Scrolling: boolean);
begin
  vScrollVal := 0;
  vAutoSize := false;
  vScrollTimer.Enabled := Scrolling;
  vScrolling := Scrolling;
  Repaint;
end;

procedure TGSFormattedLabel.SetScrollSpeed(Speed: integer);
begin
  if Speed < 0 then Speed := 0;

  vScrollTimer.Interval := Speed;
  vScrollSpeed := Speed;
end;

procedure TGSFormattedLabel.SetScrollSteps(Steps: integer);
begin
  if Steps < 1 then Steps := 1;

  vScrollSteps := Steps;
end;


// misc \\

procedure TGSFormattedLabel.SetLines(Lines: TStringlist);
var
  i: integer;
begin
  vLines.Text := Lines.Text;

 // fill empty lines with one space (" ")
  for i := 0 to vLines.Count - 1 do
    if vLines[i] = '' then vLines[i] := ' ';

  Repaint;
end;

procedure TGSFormattedLabel.SetBackColor(Color: TColor);
begin
  vColor := Color;
  Repaint;
end;

procedure TGSFormattedLabel.SetFont(Font: TFont);
begin
  vDefaultFont.Assign(Font);
  Repaint;
end;

procedure TGSFormattedLabel.SetAlignment(Alignment: TAlignment);
begin
  vAlignment := Alignment;
  Repaint;
end;

procedure TGSFormattedLabel.SetAutoSize(AutoSize: boolean);
begin
  if not vScrolling then vAutoSize := AutoSize;
  Repaint;
end;

procedure TGSFormattedLabel.SetRFEL(RFEL: boolean);
begin
  vResetFontEachLine := RFEL;
  Repaint;
end;

procedure TGSFormattedLabel.SetTransparency(Transparent: boolean);
begin
  vTransparent := Transparent;

  Repaint;
end;

// drawing \\

function GetColor(ColorName: string): TColor;
begin
  try
 // if ColorName is no delphi color name, the it's hex

    if (ColorName[1] <> '$') or (Copy(ColorName, 1, 2) <> 'cl') then
      ColorName := 'cl' + ColorName;

    result := StringToColor(ColorName);

  except
    result := clBlack;
  end;
end;

function GetFontStyle(StyleString: string): TFontStyles;
begin
  result := [];

  if Pos('b', StyleString) > 0 then result := result + [fsBold];
  if Pos('i', StyleString) > 0 then result := result + [fsItalic];
  if Pos('s', StyleString) > 0 then result := result + [fsStrikeOut];
  if Pos('u', StyleString) > 0 then result := result + [fsUnderline];
end;

// tag handling

function TGSFormattedLabel.DoCanvasAction(vArg, vParam: string): boolean;
begin
  result := true;
  try
    if vArg = 'c' then // color
    begin
      if vParam = 'def' then
        Canvas.Font.Color := vDefaultFont.Color
      else
        Canvas.Font.Color := GetColor(vParam)
    end else
      if vArg = 'fs' then // style
      begin
        if vParam = 'def' then
          Canvas.Font.Style := vDefaultFont.Style
        else
          Canvas.Font.Style := GetFontStyle(vParam);
      end else
        if vArg = 'n' then // font name
        begin
          if vParam = 'def' then
            Canvas.Font.Name := vDefaultFont.Name
          else
            Canvas.Font.Name := vParam;
        end else
          if vArg = 's' then // size
          begin
            if vParam = 'def' then
              Canvas.Font.Size := vDefaultFont.Size
            else
              Canvas.Font.Size := StrToInt(vParam);
          end else
            if vArg = 'bc' then // background color
            begin
              if vParam = '' then
                Canvas.Brush.Style := bsClear
              else
                if vParam = 'def' then
                begin
                  if vTransparent then
                    Canvas.Brush.Style := bsClear
                  else
                  begin
                    Canvas.Brush.Style := bsSolid;
                    Canvas.Brush.Color := Color;
                  end;
                end else
                begin
                  Canvas.Brush.Style := bsSolid;
                  Canvas.Brush.Color := GetColor(vParam);
                end;
            end
            else
              result := false;
  except
    result := false;
  end;
end;

// gets width and height of a line

procedure TGSFormattedLabel.GetTextDimensions(Text: string; var w, h: integer);
var
  curletter: integer;
  arg, param: string;
  bc: TColor;
  bcs: TBrushStyle;
begin
  vTempFont.Assign(Canvas.Font);
  bc := Canvas.Brush.Color;
  bcS := Canvas.Brush.Style;

  h := 0;
  w := 0;
  curletter := 1;
  while curletter <= Length(Text) do
  try
   // test letter for letter

   // commands start with "<"
    if Text[curletter] = '<' then
    begin
      inc(curletter);
      arg := '';

    // get the tagname
      while (Text[curletter] <> '=') do
      begin
        arg := arg + Text[curletter];
        inc(curletter);
      end;

      inc(curletter);
      param := '';


    // get the tagvalue
      while Text[curletter] <> '>' do
      begin
        param := param + Text[curletter];
        inc(curletter);

      end;

      // image?
      if (arg = 'i') and (Assigned(vImageList)) then
      begin
        if vImageList.Height > h then h := vImageList.Height;

        w := w + vImageList.Width;
      end else
        DoCanvasAction(arg, param);

    end else
    begin
      if Canvas.TextHeight(Text[curletter]) > h then h := Canvas.TextHeight(Text[curletter]);

      w := w + Canvas.TextWidth(Text[curletter]);
    end;

    inc(curletter);
  except
   // nothing
  end;

  // set back old font settings
  Canvas.Font.Assign(vTempFont);

  Canvas.Brush.Color  := bc;
  Canvas.Brush.Style := bcS;
end;

// draws the label

procedure TGSFormattedLabel.DrawText;
var
  curline: integer;
  curletter: integer;
  curgroundline, curx: integer;
  arg, param: string;
  maxx, maxy: integer;
  w, h: integer;
  Orientation: TAlignment;
begin
  width := self.Width;
  height := self.Height;

  curline := 0;
  curx := 0;
  maxx := 0;
  maxy := 0;
  Orientation := vAlignment;

  // scroll ?
  if vScrolling then
  begin
    case vScrollOrientation of
      soUp: curgroundline := -vScrollval;
      soDown: curgroundline := vScrollval;
    end;
  end
  else
    curgroundline := 0;

  if vTransparent then
    Canvas.Brush.Style := bsClear
  else
  begin
    Canvas.Brush.Color := vColor;
    Canvas.FillRect(Rect(0, 0, Width, Height));
  end;

  Canvas.Font.Assign(vDefaultFont);

  while curline < vLines.Count do
  begin
    curletter := 1;

  // reset font?
    if vResetFontEachLine then
    begin
      Canvas.Font.Assign(vDefaultFont);

      if vTransparent then
        Canvas.Brush.Style := bsClear
      else
        Canvas.Brush.Color := vColor;

      Orientation := vAlignment;
    end;

  // if there is "<o" at line start the set the alignment
    if Copy(vLines[curline], 1, 3) = '<o=' then
    begin
      curletter := 6;

      case vLines[curline][4] of
        'l': Orientation := taLeftJustify;
        'c': Orientation := taCenter;
        'r': Orientation := taRightJustify;
      else
        begin
          Orientation := vAlignment;
          curletter := 8;
        end;
      end;
    end;

    if vLines[curline] = '' then vLines[curline] := ' ';

    GetTextDimensions(vLines[curline], w, h);
    curgroundline := curgroundline + h;

    // alignment
    if Orientation = taLeftJustify then curx := 0 else
      if Orientation = taRightJustify then curx := width - w else
        curx := width div 2 - w div 2;

    // scrolling
    if Scrolling then
      case vScrollorientation of
        soLeft: dec(curx, vScrollVal);
        soRight: inc(curx, vScrollVal);
      end;

    try
      while curletter <= Length(vLines[curline]) do
      begin
   // test letter for letter

   // Befehle beginnen mit "<"
        if vLines[curline][curletter] = '<' then
        begin
          inc(curletter);
          arg := '';

    // get tagname
          while (vLines[curline][curletter] <> '=') do
          begin
            arg := arg + vLines[curline][curletter];
            inc(curletter);
          end;

          inc(curletter);
          param := '';

    // get tagvalue
          while vLines[curline][curletter] <> '>' do
          begin
            param := param + vLines[curline][curletter];
            inc(curletter);
          end;

      // image?
          if (arg = 'i') and (Assigned(vImageList)) then
          begin
            vImageList.Draw(Canvas, curx, curgroundline - vImageList.Height, StrToInt(param));

            inc(curx, vImageList.Width);
          end else
            DoCanvasAction(arg, param);
        end else begin
    // i fno command then draw as letter
          Canvas.TextOut(curx, curgroundline - Canvas.TextHeight(vLines[curline][curletter]), vLines[curline][curletter]);
          inc(curx, Canvas.TextWidth(vLines[curline][curletter]));
        end;

        inc(curletter);
      end;
    except
   // nothing
    end;
    if w > maxx then maxx := w;
    inc(maxy, h);

    inc(curline);
  end;

  // autosize
  if (vAutoSize) and (Align = alNone) then
    if (curgroundline <> height) or (maxx <> width) then
    begin
      height := curgroundline;
      width := maxx;
      Repaint;
    end;

  // scrolling
  // if scrolled through, restart
  if Scrolling then
    case vScrollOrientation of
      soUp: if (vScrollVal > maxy) then vScrollVal := -height;
      soDown: if (vScrollVal > height) then vScrollVal := -maxy;

      soLeft: if (vScrollVal > maxx) then vScrollVal := -width;
      soRight: if (vScrollVal > width) then vScrollVal := -maxx;
    end;
end;

end.