scrolllabel -> kann einer eine komponente daraus machen?

[100nF]

hallo zusammen,

ich habe einen code für einen lauftext geschrieben, und es wäre schön wenn man daraus eine komponente machen könnte. ich kenn mich halt nicht aus mit komponenten selber machen, und darum wollte ich fragen ob das einer von euch erledigen könnte.
eigentlich sollte es genau ein Tlabel sein, nur mit der zusatzfunktion active (boolean). falls true, läuft die schrift, bei false steht sie. dann sollte man noch die geschwindigkeit einstellen können (beim timer der intervall) und die variablen vorne+hinten sollte man ändern können.

hier mein code:

Delphi-Quellcode:

var 
  scrolllabel2: tlabel;
  vorne, hinten: integer;

////////////////////////////////////////

procedure TForm1.FormCreate(Sender: TObject);
begin
  vorne := 0;
  hinten := form1.ClientWidth;
  label1.Left := vorne;
  scrolllabel2 := tlabel.Create(self);
  scrolllabel2.Parent := label1.Parent;
  scrolllabel2.Align := alcustom;
  label1.Align := alcustom;
  scrolllabel2.Left := hinten;
end;

///////////////////////////////////////////////

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  scrolllabel2.caption := label1.caption;
  scrolllabel2.Top := label1.Top;
  Label1.Left := Label1.Left -1;
  scrolllabel2.Left := scrolllabel2.Left -1;
  if (scrolllabel2.Left < label1.left+label1.Width+20) and (label1.Left < vorne) then scrolllabel2.Left := label1.left+label1.Width+21 ;
  if (label1.Left < scrolllabel2.left+scrolllabel2.Width+20) and (scrolllabel2.Left < vorne) then label1.Left := scrolllabel2.left+scrolllabel2.Width+21 ;
  if label1.Left = vorne then scrolllabel2.Left := hinten;
  if scrolllabel2.Left = vorne then label1.Left := hinten;
end;

//////////////////////////////////////////////////////

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
scrolllabel2.Free;   // Ist das wichtig??
end;

falls jemand eine erweiterung/änderung hätte für mein code, nur her damit

hat vielleicht jemand den code von einem TLabel? dann könnte ich selber mal ein bisschen probieren...

danke schon im voraus

MFG
urbanbruhin

[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.

[100nF]

hallo turboPASCAL

leider kann ich die komponente nicht installieren, da die .res datei fehlt...brauchts die überhaupt?

der code hat aber nichts mit meinem code zu tun, oder?
es gibt viele scrolllabels im internet, jedoch fast alle unbrauchbar, weil man sieht man zum teil nur wenig oder gar nichts vom text. bei meinem code ist immer so viel wie möglich zu sehen, da es eigentlich zwei labels sind, die hintereinander durchlaufen. ist es das bei deinem code auch?

[turboPASCAL]

@urbanbruhin

Nein deine ist es nicht, kann aber fast alles und noch einiges mehr.

Betr. Zusatzfunktion active (boolean) kann ich jetzt nicht sagen weil ich nicht weis
wie du das meinst zB. wärend dem Scrollen an einer Position stehen lassen?

In der Res ist eigentlich nix, nur ein Bitmap (20x20 mit dem namen der Komponente) für die Komponentenliste.

In der Zip is alles (hoffe ich).

[100nF]

hallo turboPASCAL,

ich konnte es jetzt installieren, jedoch macht es genau nicht das, was mein code macht.
ich probiere es mal zu erklären:
beim GSFormattedLabel läuft der text immer weiter nach links (wenn so eingestellt), bis der letzte buchstabe verschwunden ist. dann ist ganz kurz kein text mehr zu sehen. erst dann taucht der text wieder auf von rechts. das ist dumm, da man ziemlich lange warten muss, bis man den ganzen text gelesen hat.

bei meinem scrolllabel läuft es allerdings so:
sobald der erste buchstabe links verschwindet, taucht es schon rechts wieder auf. so kann man jederzeit den ganzen text sehen.

du kannst ja mal mein code ausprobieren, dann siehst du es...
ich habe bis jetzt noch nirgens eine komponente gesehen, die sowas kann.darum wäre ich froh wenn man aus meinem code eine komponente machen könnte.

also möglich wäre es doch, oder?

ach ja, das mit dem active ist so gemeint. wenn true, läuft die schrift nach links, bei false steht sie ganz links.

edit: ich habe den code beim ersten beitrag ein bisschen geändert. ich habe da noch eine frage hingeschrieben, beim onClose ereignis. ich wäre froh wenn ich eine antwort bekommen würde.

MFG
urbanbruhin

[turboPASCAL]

hi urbanbruhin,

jo hab dein code angeschaut. da ist mier aufgefallen, dass du da noch ein poblemchen hast.
versuch doch mal bei deinem label farbe und font zu ändern.
sorry, kann dir zz. keine kompon. erstellen (bräuchte ein paar stunden, bin da nicht mehr so fit darin), versuch es doch mal selber so schwer ist es nicht (). schau mal in die hilfe oder nach einem tut hier im forum.


( alles kleinschreiben müssen, shift-taste klemmt? )

[Jens Schumann]

Hallo,
schau Dir doch mal die anliegende Komponente an

[100nF]

hallo,

Zitat:

versuch doch mal bei deinem label farbe und font zu ändern.

habe ich schon gemerkt, und mit diesem zusätzlichen code ist das problem gelöst:
scrolllabel2.Font := label1.Font;

Zitat:

sorry, kann dir zz. keine kompon. erstellen (bräuchte ein paar stunden, bin da nicht mehr so fit darin)

ist schon ok

Zitat:

versuch es doch mal selber so schwer ist es nicht ().

hab ich schon mal ein bisschen angeschaut, begreife es aber NOCH nicht so ganz. werde es aber noch genauer studieren, sobald ich mein delphi-buch zurück habe.

Zitat:

( alles kleinschreiben müssen, shift-taste klemmt? )

meinst du bei meinem code? geht schneller ohne shift

@Jens Schumann,
habe die komponente mal angeschaut, sieht nicht schlecht aus, hat aber einen kleinen fehler drin. wenn der text nicht in das feld passt, überschneidet er sich...siehe anhang.

vielleicht werde ich mal den code vom JsRunningText genauer anschauen und ev. verbessern.