Justified Text Label Component

[typo]

I don't know whether it is the best approach, but it works. There is an unsolved problem on SetNextLabel procedure which causes an access violation at design time.

It can set Columns and Lines like in a newspaper and can send text to the NextLabel. Several labels can be concatenated, each one sending SurplusText to the next one.

You need to set MaxLines and Columns properties at design time and Text property at run time.

Code: [Select]

unit columnlabel;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, StdCtrls, Controls, Windows, LResources, StrUtils;

type
  TColumnLabel = class (TCustomLabel)
  private
    FCompleteJustification :boolean;
    FNextLabel :TCustomLabel;
    FSurplusText,
    FJustifiedText,
    FNormalText :string;
    FMaxLines,
    FColumns,
    FLines,
    FMaxLineWidth :integer;
    function MyWrapText(AText :string; MaxCol :integer): string;
    function Justify(AText :string; AColumns :integer) :string;
    function GetText :string;
    function GetMaxLines :integer;
    procedure SetColumns(AValue :integer);
    procedure SetText(AValue :TCaption);
    procedure SetNextLabel(ALabel :TCustomLabel);
    procedure SetMaxLines(AValue :integer);
  public
    constructor Create(AOwner :TComponent);override;
    property Lines :integer read FLines;
  published
    property Text :TCaption read GetText write SetText;
    property Columns :integer read FColumns write SetColumns;
    property MaxLines :integer read GetMaxLines write SetMaxLines;
    property NextLabel :TCustomLabel read FNextLabel write SetNextLabel;
    property CompleteJustification :boolean read FCompleteJustification write FCompleteJustification;
    property MaxLineWidth :integer read FMaxLineWidth write FMaxLineWidth;
    property Align;
    property Alignment;
    property Anchors;
    property BidiMode;
    property BorderSpacing;
    property Color;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Font;
    //property Layout;
    property ParentBidiMode;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Transparent;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnChangeBounds;
    property OnContextPopup;
    property OnResize;
    property OnStartDrag;
    //property OptimalFill;
  end;

procedure Register;

implementation

function TColumnLabel.MyWrapText(AText :string; MaxCol :integer): string;
const
  NewLine = #13#10;
  LastNewLineChar = #10;
var
  i, j, n :integer;
  s, ss :string;
begin
  Result := AText;
  if Length(AText) <= MaxCol then Exit;
  ss := '';
  repeat
    s := Copy2SymbDel(AText, LastNewLineChar);
    s := Trim(s);
    j := 0;
    n := 0;
    while j <= Length(s) do
    begin
      inc(j);
      if (j mod MaxCol) = 0 then
      begin
        i := j;
        while s[i] <> ' ' do
          Dec(i);
        if Pos(' ', s) > 0 then
        begin
          System.Insert(NewLine, s, i + 1);
          Inc(n, Length(NewLine));
          inc(j, 2);
        end
        else
        begin
          System.Insert(NewLine, s, j);
          Inc(n, Length(NewLine));
          inc(j, 2);
        end;
      end;
    end;
    ss := ss + s + NewLine;
  until AText = '';
  Result := Trim(ss);
end;

function TColumnLabel.Justify(AText :string; AColumns :integer) :string;
var
  s, ss, a, sss, s4, wrappedtext :string;
  maxwidth, l, n :integer;
  ByteSet :set of byte;
begin
  fsurplustext := '';
  n := 0;
  ss := '';

  if tag = 1 then
  begin
    repeat
      inc(n);
      s := Copy2SymbDel(AText, #10);
      s := Trim(s);
      if n > FMaxLines then
        FSurplusText := FSurplusText + Trim(s) + #13#10
      else
        ss := ss + Trim(s) + #13#10;
    until AText = '';
    if Assigned(FNextLabel) then
      if FNextLabel is TColumnLabel then
       TColumnLabel(FNextLabel).Text := FSurplusText
      else
        FNextLabel.Caption := FSurplusText;
    Result := Trim(ss);
    Exit;
  end;

  ByteSet := [];
  while pos(#13#10#13#10, atext) > 0 do
    atext := ansireplacestr(atext, #13#10#13#10, '*');
  while pos(#13#10, atext) > 0 do
    atext := ansireplacestr(atext, #13#10, ' ');
  while pos('*', atext) > 0 do
    atext := ansireplacestr(atext, '*', #13#10#13#10);
  while pos('  ', AText) > 0 do
    AText := AnsiReplaceStr(AText, '  ', ' ');
  wrappedtext := MyWrapText(AText, AColumns);

  s4 := '';
  MaxWidth := 0;
  s := wrappedtext;
  n := 0;

  repeat
    Inc(n);
    ss := Copy2SymbDel(s, #10);
    ss := Trim(ss);
    if ss = '' then Include(ByteSet, n);
    if (Canvas.TextWidth(ss) > MaxWidth) then
      MaxWidth := Canvas.TextWidth(ss);
  until s = '';

  Include(ByteSet, n + 1);
  s := wrappedtext;
  n := 0;
  repeat
    Inc(n);
    ss := Copy2SymbDel(s, #10);
    ss := Trim(ss);
    a := ' ';
    sss := Trim(ss);
    l := Length(sss);
    if not((n + 1) in ByteSet) or FCompleteJustification then
      while (Canvas.TextWidth(Trim(sss)) <= MaxWidth - Canvas.TextWidth(' ')) do
      begin
        if Trim(sss) = '' then Break;
        if Pos(' ', sss) = 0 then Break;
        l := RPosEx(a, sss, l - 1);
        if (l > 0) then
        begin
          System.Insert(' ', sss, l);
        end
        else
        begin
          l := Length(sss);
          a := a + ' ';
        end;
      end;
    if n > FMaxLines then
      FSurplusText := FSurplusText + Trim(sss) + #13#10
    else
      s4 := s4 + Trim(sss) + #13#10;
  until s = '';
  FLines := n;
  if Assigned(FNextLabel) then
    if FNextLabel is TColumnLabel then
      TColumnLabel(FNextLabel).Text := FSurplusText
    else
      FNextLabel.Caption := FSurplusText;
  Result := Trim(s4);
end;

constructor TColumnLabel.Create(AOwner :TComponent);
begin
  inherited Create(AOwner);
  FColumns := 40;
  Text := Name;
  MaxLines := 30;
  FLines := 1;
  CompleteJustification := False;
  OptimalFill := False;
  AutoSize := True;
  MaxLineWidth := 200;
  FSurplusText := '';
end;

procedure TColumnLabel.SetNextLabel(ALabel :TCustomLabel);
begin
  if (FNextLabel = ALabel)
    or (FNextLabel = Self) then Exit;
  if FNextLabel <> nil then
    FNextLabel.RemoveFreeNotification(Self);

   FNextLabel := ALabel;
   if fnextlabel <> nil then
   begin
     FNextLabel.Font.Name := font.name;
     FNextLabel.Font.Size := font.size;
     FNextLabel.Tag := 1;
   end;

  if ALabel <> nil then
    FNextLabel.FreeNotification(Self);
end;

procedure TColumnLabel.SetColumns(AValue :integer);
begin
  if FColumns <> AValue then
  begin
    FColumns := AValue;
    SetText(FNormalText);
  end;
end;

function TColumnLabel.GetText :string;
begin
  Result := Caption;
end;

procedure TColumnLabel.SetText(AValue :TCaption);
begin
  if FNormalText = aValue then Exit;
  FNormalText := AValue;
  if FColumns > 0 then
    FJustifiedText := Justify(FNormalText, FColumns)
  else
    FJustifiedText := FNormalText;
  Caption := FJustifiedText;
end;

function TColumnLabel.GetMaxLines :integer;
begin
  Result := FMaxLines;
end;

procedure TColumnLabel.SetMaxLines(AValue :integer);
begin
  if FMaxLines <> AValue then
    FMaxLines := AValue;
  SetText(FNormalText);
end;

procedure Register;
begin
  RegisterComponents('Misc',[TColumnLabel]);
end;

initialization
  {$I columnlabel.lrs}

end.
                   


[Phil]

Do you get the access violation only at design time or at runtime too?

Thanks.

-Phil

[typo]

The access violation occurs when you delete a previously set NexLabel and at design time only.

I have not tried to delete one at run time.

You can compose a newspaper page with several labels and put the whole text on the first one at run time.

[Martin_fr]

Well, you use FreeNotification and RemoveFreeNotification.

but you don't actually override
procedure Notification(Sender..., Operation);


FreeNotification only tells the NextLabel, to call "Notification" on the requestor, if NextLabel is destroyed.

you then need to catch this call, check that the Sender is NextLabel  and the Operation is opRemove, and if so set FNextLabel := nil

[typo]

Well, you use FreeNotification and RemoveFreeNotification.

Well, I use them, but the component has no Notification procedure.

Maybe there is something wrong with my usage.

[Phil]

This probably has nothing to do with your exception, but the first two lines of SetNextLabel:

  if (FNextLabel = ALabel)
    or (FNextLabel = Self) then Exit;

The 2nd line: why would this ever be true (points to itself)? Should this be:

    or (ALabel = Self) then Exit;

Thanks.

-Phil

[typo]

I have written this line there because at desing time all TCustomLabel descendents appear on the NextLabel property editor's combobox, including itself.

[Martin_fr]

Well, you use FreeNotification and RemoveFreeNotification.

Well, I use them, but the component has no Notification procedure.

Maybe there is something wrong with my usage.

The base class has a Notification procedure => you need to override it

within your protected area start typinv

  procedure Notification<ctrl>-c

the code completion should pick up on the inheritable procedure from the base.

It should have sender and operation

[typo]

I have made a little modification on the code and it works fine.

From:

Code: [Select]

procedure TColumnLabel.SetNextLabel(ALabel :TCustomLabel);
begin
  if (FNextLabel = ALabel)
    or (FNextLabel = Self) then Exit;
  if FNextLabel <> nil then
    FNextLabel.RemoveFreeNotification(Self);

   FNextLabel := ALabel;
   if fnextlabel <> nil then
   begin
     FNextLabel.Font.Name := font.name;
     FNextLabel.Font.Size := font.size;
     FNextLabel.Tag := 1;
   end;

  if ALabel <> nil then
    FNextLabel.FreeNotification(Self);
end;

To:

Code: [Select]

procedure TColumnLabel.SetNextLabel(ALabel :TCustomLabel);
begin
  if (FNextLabel = ALabel)
    or (FNextLabel = Self) then Exit;
  if FNextLabel <> nil then
    FNextLabel.RemoveFreeNotification(FNextLabel);

   FNextLabel := ALabel;
   if fnextlabel <> nil then
   begin
     FNextLabel.Font.Name := font.name;
     FNextLabel.Font.Size := font.size;
     FNextLabel.Tag := 1;
   end;

  if ALabel <> nil then
    FNextLabel.FreeNotification(FNextLabel);
end;

The inherited procedures do the job.

[Martin_fr]

I doubt that it fixes the issue.

As long as you do not override "Notification" you always run the risk of accessing a label that is freed already.

You should compile your apps (and lazarus too) with -gt
That will trash any destroyed object, so you will notice the errors.

If you do not use -gt then an object that is destroyed, may still be in memory and "work" => but that is pure random working. It may work with 90% plus chance, but it will fail sometimes.

Your old code "[Remove]Freenotification(Self)" definitely was correct. But as I said, It doesn't do much without you receiving the Notification.

Search other code for FreeNotification, and then look at the "procedure Notification" of the same object....

---------------
Also:

Code: [Select]

if (FNextLabel = ALabel)
    or (FNextLabel = Self) then Exit;

should that not better be

Code: [Select]

if (FNextLabel = ALabel)
    or ( AVALUE = Self) then Exit;

because currently you can set NextLabel to self, but then never change it again?

[typo]

if (FNextLabel = ALabel)
    or ( AVALUE = Self) then Exit;

Yes, you are right.

This seems to work:

Code: [Select]

procedure TColumnLabel.Notification(AComponent : TComponent; Operation : TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (AComponent = FNextLabel) and (Operation = opRemove) then
    FNextLabel := nil;
end;

procedure TColumnLabel.SetNextLabel(ALabel :TCustomLabel);
begin
  if (FNextLabel = ALabel) or (ALabel = Self) then Exit;

  if FNextLabel <> nil then  
    Notification(Self, opRemove);

   FNextLabel := ALabel;
   if fnextlabel <> nil then
   begin
     FNextLabel.Font.Name := font.name;
     FNextLabel.Font.Size := font.size;
     FNextLabel.Tag := 1;
   end;

  if ALabel <> nil then    
    Notification(Self, opInsert);
end;  

A screenshot of my test application attached.

[typo]

I have edited the code a bit to allow cleaning all labels. Just a single line added to the first line of Justify procedure:

FSurplusText := '';

[Martin_fr]

procedure TColumnLabel.Notification(AComponent : TComponent; Operation : TOperation);

is exactly what you need, exactly as you need it.

But you should also keep
 FNextLabel.RemoveFreeNotification(Self);
 FNextLabel.FreeNotification(Self);
in procedure TColumnLabel.SetNextLabel


If you do
  FNextLabel.FreeNotification(Self);
then it means that if FNextLabel gets destroyed it will call Notification on the requestor (the requestor is "self")

So the current label will learn if the other label is destroyed.

"FreeNotification" does *not* mean that "SetNextLabel" is called. That is why you must catch it in "Notification"

-------
you can even go one step further

Code: [Select]

procedure TColumnLabel.Notification(AComponent : TComponent; Operation : TOperation);
begin
  inherited Notification(AComponent, Operation);
  // NextLabel is about to be destroyed, it still exists
  // just overflow to where ever NextLabel did over-flow to
  // if NextLabel didn't overflow, then it will be nil
  if (AComponent = FNextLabel) and (Operation = opRemove) then
    FNextLabel := FNextlabel.NextLabel;
end;

procedure TColumnLabel.SetNextLabel(ALabel :TCustomLabel);
begin
  if (FNextLabel = ALabel) or (ALabel = Self) then Exit;

  if FNextLabel <> nil then
     FNextLabel.RemoveFreeNotification(Self);

   FNextLabel := ALabel;
   if fnextlabel <> nil then
   begin
     FNextLabel.Font.Name := font.name;
     FNextLabel.Font.Size := font.size;
     FNextLabel.Tag := 1;
   end;

 if FNextLabel <> nil then
    FNextLabel.FreeNotification(Self);end;   

Just be sure that
  destructor TColumnLabel.Destroy;
doesn't set FNextLabel to nil, at least not before it does it's inherited call

[typo]

This works, thanks.

[typo]

Similar components to Delphi in general justify on the canvas, stretching the text. On Lazarus I think that it would be a great problem, since it would be necessary to write to each platform.

DrawText seems to have no implementation on Lazarus. So I have made this hard justification.

The component can be downloaded from http://lazarusbrasil.org/ColumnLabelDemo.zip