{
Copyright (C) 2015 Antônio Galvão
This is the file COPYING.modifiedLGPL, it applies to several units in the
Lazarus sources.
All files contain headers showing the appropriate license. See there if this
modification can be applied.
These files are distributed under the Library GNU General Public License
(see the file COPYING.LGPL) with the following modification:
As a special exception, the copyright holders of this library give you
permission to link this library with independent modules to produce an
executable, regardless of the license terms of these independent modules,
and to copy and distribute the resulting executable under terms of your choice,
provided that you also meet, for each linked independent module, the terms
and conditions of the license of that module. An independent module is a
module which is not derived from or based on this library. If you modify this
library, you may extend this exception to your version of the library, but
you are not obligated to do so. If you do not wish to do so, delete this
exception statement from your version.
If you didn't receive a copy of the file COPYING.LGPL, contact:
Free Software Foundation, Inc.,
675 Mass Ave
Cambridge, MA 02139
USA
}
unit JustifiedLabelUnit;
{$mode objfpc}{$H+}
interface
uses
Windows, Classes, SysUtils, StdCtrls, Forms, Controls, Graphics, StrUtils,
LazUTF8;
{ TJustifiedLabel }
type
TJustifiedLabel = class(TCustomLabel)
private
FAutoSize,
FAlreadyPainted,
FWordWrap :boolean;
protected
procedure SetAutoSize(Value: Boolean); override;
public
constructor Create(TheOwner: TComponent); override;
procedure Loaded; override;
procedure Paint; override;
{Makes WordWrap property inaccessible}
property WordWrap: boolean read FWordWrap write FWordWrap default False;
published
property Align;
//property Alignment;
property Anchors;
property AutoSize: Boolean read FAutoSize write SetAutoSize;
property BidiMode;
//property BorderSpacing;
property Caption;
property Color;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property FocusControl;
property Font;
//property Layout;
property ParentBidiMode;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowAccelChar;
property ShowHint;
property Transparent;
property Visible;
property OnChangeBounds;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
property OnMouseWheelDown;
property OnMouseWheelUp;
property OnResize;
property OnStartDrag;
// property OptimalFill;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Natural', [TJustifiedLabel]);
end;
{ TJustifiedLabel }
procedure TJustifiedLabel.Paint;
var
R : TRect;
TextLeft: integer = 0;
TextTop: integer = 0;
LabelText: string;
OldFontColor: TColor;
NumberOfLines :Integer = 0;
i :Integer;
Extra :Integer;
Blanks :Integer;
LastLineEndingChar :Char;
ALine :String;
Cols :Integer;
AverageCharWidth :Integer;
s: TCaption;
ByteSet: set of byte = [];
s1: String;
WrappedText :String;
procedure BeSureFontIsValid;
begin
Self.Canvas.Font.Name := 'Tahoma';
end;
procedure AdjustHeight;
begin
if NumberOfLines > 0 then
Self.Height := NumberOfLines * Canvas.TextHeight('A');
end;
procedure MarkParagraphEndings;
begin
s := LabelText;
i := 0;
while Pos(LineEnding, S) > 0 do
begin
s1 := Trim(Copy2SymbDel(s, LineEnding[Length(LineEnding)]));
if Trim(s1) = '' then
if not (i in ByteSet) then
Include(ByteSet, i);
Inc(i);
end;
end;
procedure AdjustInitialWidth;
begin
// Adjust the width for the initial caption
if not FAlreadyPainted and (csDesigning in ComponentState)
and (Pos(#32, Caption) = 0) then
begin
FAlreadyPainted := True;
// The inherited SetAutosize cannot be called from Create or Loaded.
if Self.Width < Canvas.TextWidth(Caption) then
inherited SetAutoSize(True);
end
else
inherited SetAutoSize(False);
end;
procedure DrawInitialCaption;
begin
if not Enabled then
begin
Self.Canvas.Font.Color := clBtnHighlight;
Self.Canvas.TextOut(1, 1, LabelText);
Self.Canvas.Font.Color := clBtnShadow;
end;
Self.Canvas.TextOut(0, 0, LabelText);
Self.Canvas.Font.Color := OldFontColor;
if FAutoSize then
AdjustHeight;
end;
begin
if Self.Width < 40 then Exit;
AdjustInitialWidth;
BeSureFontIsValid;
R := Rect(0,0,Self.Width,Self.Height);
with Self.Canvas do
begin
Brush.Color := Self.Color;
if (Color <> clNone) and not Transparent then
begin
Brush.Style := bsSolid;
FillRect(R);
end;
Brush.Style := bsClear;
Font := Self.Font;
DoMeasureTextPosition(TextTop, TextLeft);
OldFontColor := Canvas.Font.Color;
LabelText := Trim(Caption);
if Pos(#32, LabelText) = 0 then
begin
DrawInitialCaption;
Exit;
end;
AverageCharWidth := (TextWidth(Caption) div UTF8Length(Caption));
Cols := (Self.Width div (AverageCharWidth + 1));
//if Cols > 0 then
WrappedText := Trim(UTF8WrapText(Caption, Cols));
LabelText := WrappedText;
MarkParagraphEndings;
if not IsEnabled then
begin
Self.Canvas.Font.Color := clBtnHighlight;
NumberOfLines := 1 + (Length(LabelText) - Length(StringReplace(LabelText, LineEnding, '', [rfReplaceAll]))) div length(lineending);
for i := 1 to NumberOfLines - 1 do
begin
LastLineEndingChar := LineEnding[Length(LineEnding)];
ALine := Trim(Copy2SymbDel(labeltext, LastLineEndingChar));
Extra := Self.Width - Canvas.TextWidth(ALine);
Blanks := (UTF8Length(ALine) - UTF8Length(StringReplace(ALine, #32, '', [rfReplaceAll])));
if not (i in ByteSet) then
SetTextJustification(Canvas.Handle, Extra, Blanks);
Canvas.TextOut(R.Left + TextLeft + 1, TextTop + 1 + R.Top + (i - 1) * Canvas.TextHeight('A'), aline);
SetTextJustification(Canvas.Handle, 0, 0);
end;
ALine := Trim(Copy2SymbDel(labeltext, LastLineEndingChar));
TextOut(R.Left + TextLeft + 1, TextTop + 1 + R.Top + (NumberOfLines - 1) * Canvas.TextHeight('A'), aline);
Canvas.Font.Color := clBtnShadow;
end;
LabelText := WrappedText;
NumberOfLines := 1 + (Length(LabelText) - Length(StringReplace(LabelText, LineEnding, '', [rfReplaceAll]))) div length(lineending);
for i := 1 to NumberOfLines - 1 do
begin
LastLineEndingChar := LineEnding[Length(LineEnding)];
ALine := Trim(Copy2SymbDel(labeltext, LastLineEndingChar));
Extra := Self.Width - Canvas.TextWidth(ALine);
Blanks := (UTF8Length(ALine) - UTF8Length(StringReplace(ALine, #32, '', [rfReplaceAll])));
if not (i in ByteSet) then
SetTextJustification(Canvas.Handle, Extra, Blanks);
Canvas.TextOut(R.Left, R.Top + (i - 1) * Canvas.TextHeight('A'), ALine);
SetTextJustification(Canvas.Handle, 0, 0);
end;
ALine := Trim(Copy2SymbDel(labeltext, LastLineEndingChar));
Canvas.TextOut(R.Left, R.Top + (NumberOfLines - 1) * Canvas.TextHeight('A'), ALine);
Canvas.Font.Color := OldFontColor;
end;
if FAutoSize then
AdjustHeight;
end;
constructor TJustifiedLabel.Create(TheOwner :TComponent);
begin
inherited Create(TheOwner);
Canvas.Font.Name := 'Tahoma';
FAutoSize := True;
end;
procedure TJustifiedLabel.Loaded;
begin
inherited Loaded;
end;
procedure TJustifiedLabel.SetAutoSize(Value :Boolean);
var
NumberOfLines :Integer;
LabelText :TCaption;
begin
if FAutoSize <> Value then
FAutoSize := Value;
if (Caption = '') or not FAutoSize then
Exit;
LabelText := Caption;
NumberOfLines := 1 + (Length(LabelText) - Length(StringReplace(LabelText, LineEnding, '', [rfReplaceAll]))) div length(lineending);
Self.Height := NumberOfLines * Canvas.TextHeight('A');
end;
end.
Recent
