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.