1: 2: 3: 4: 5: 6: 7: 8: 9: 10: 11: 12: 13: 14: 15: 16: 17: 18: 19: 20: 21: 22: 23: 24: 25: 26: 27: 28: 29: 30: 31: 32: 33: 34: 35: 36: 37: 38: 39: 40: 41: 42: 43: 44: 45: 46: 47: 48: 49: 50: 51: 52: 53: 54: 55: 56: 57: 58: 59: 60: 61: 62: 63: 64: 65: 66: 67: 68: 69: 70: 71: 72: 73: 74: 75: 76: 77: 78: 79: 80: 81: 82: 83: 84: 85: 86: 87: 88: 89: 90: 91: 92: 93: 94: 95: 96: 97: 98: 99: 100: 101: 102: 103: 104: 105: 106: 107: 108: 109: 110: 111: 112: 113: 114: 115: 116: 117: 118: 119: 120: 121: 122: 123: 124: 125: 126: 127: 128: 129: 130: 131: 132: 133: 134: 135: 136: 137: 138: 139: 140: 141: 142: 143: 144: 145: 146: 147: 148: 149: 150: 151: 152: 153: 154: 155: 156: 157: 158: 159: 160: 161: 162: 163: 164: 165: 166: 167: 168: 169: 170: 171: 172: 173: 174: 175: 176: 177: 178: 179: 180: 181: 182: 183: 184: 185: 186: 187: 188: 189: 190: 191: 192: 193: 194: 195: 196: 197: 198: 199: 200: 201: 202: 203: 204: 205: 206: 207: 208: 209: 210: 211: 212: 213: 214: 215: 216: 217: 218: 219: 220: 221: 222: 223: 224: 225: 226: 227: 228: 229: 230: 231: 232: 233: 234: 235: 236: 237: 238: 239: 240: 241: 242: 243: 244: 245: 246: 247: 248: 249: 250: 251: 252: 253: 254: 255: 256: 257: 258: 259: 260: 261: 262: 263: 264: 265: 266: 267: 268: 269: 270: 271: 272: 273: 274: 275: 276: 277: 278: 279: 280: 281: 282: 283: 284: 285: 286: 287: 288: 289: 290: 291: 292: 293: 294: 295: 296: 297: 298: 299: 300: 301: 302: 303: 304: 305: 306: 307: 308: 309: 310: 311: 312: 313: 314: 315: 316: 317: 318: 319: 320: 321: 322: 323: 324: 325: 326: 327: 328: 329: 330: 331: 332: 333: 334: 335: 336: 337: 338: 339: 340: 341: 342: 343: 344: 345: 346: 347: 348: 349: 350: 351: 352: 353: 354: 355: 356: 357: 358: 359: 360: 361: 362: 363: 364: 365: 366: 367: 368: 369: 370: 371: 372: 373: 374: 375: 376: 377: 378: 379: 380: 381: 382: 383: 384: 385: 386: 387: 388: 389: 390: 391: 392: 393: 394: 395: 396: 397: 398: 399: 400: 401: 402: 403: 404: 405: 406: 407: 408: 409: 410: 411: 412: 413: 414: 415: 416: 417: 418: 419: 420: 421: 422: 423: 424: 425: 426: 427: 428: 429: 430: 431: 432: 433: 434: 435: 436: 437: 438: 439: 440: 441: 442: 443: 444: 445: 446: 447: 448: 449: 450: 451: 452: 453: 454: 455: 456: 457: 458: 459: 460: 461: 462: 463: 464: 465: 466: 467: 468: 469: 470: 471: 472: 473: 474: 475: 476: 477: 478: 479: 480: 481: 482: 483: 484: 485: 486: 487: 488: 489: 490: 491: 492: 493: 494: 495: 496: 497: 498: 499: 500: 501: 502: 503: 504: 505: 506: 507: 508: 509: 510: 511: 512: 513: 514: 515: 516: 517: 518: 519: 520: 521: 522: 523: 524: 525: 526: 527: 528: 529: 530: 531: 532: 533: 534: 535: 536: 537: 538: 539: 540: 541: 542: 543: 544: 545: 546: 547: 548: 549: 550: 551: 552: 553: 554: 555: 556: 557: 558: 559: 560: 561: 562: 563: 564: 565: 566: 567: 568: 569: 570: 571: 572: 573: 574: 575: 576: 577: 578: 579: 580: 581: 582: 583: 584: 585: 586: 587: 588: 589: 590: 591: 592: 593: 594: 595: 596: 597: 598: 599: 600: 601: 602: 603: 604: 605: 606: 607: 608: 609: 610: 611: 612: 613: 614: 615: 616:
| unit GSFormattedLabel;
interface
uses SysUtils, Classes, Graphics, Controls, ExtCtrls, Messages, Dialogs;
type TScrollOrientation = (soUp, soDown, soLeft, soRight);
type TGSFormattedLabel = class(TGraphicControl) private vLines: TStringlist; vColor: TColor; vDefaultFont: TFont; vResetFontEachLine: boolean; vTransparent: boolean; vAutoSize: boolean; vAlignment: TAlignment;
vScrolling: boolean; vScrollOrientation: TScrollOrientation; vScrollSpeed: integer; vScrollSteps: integer;
vScrollTimer: TTimer; vScrollVal: Integer;
vImageList: TImageList;
AboutStr: string;
vTempFont: TFont;
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);
procedure OnTimer(Sender: TObject);
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;
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;
property Align; property Visible; property Hint; property ShowHint; property PopUpMenu;
property OnClick; property OnContextPopUp; property OnDblClick; property OnMouseActivate; property OnMouseDown; property OnMouseMove; property OnMouseUp; end;
procedure Register;
implementation
procedure Register; begin RegisterComponents('Genie-Soft', [TGSFormattedLabel]); end;
procedure TGSFormattedLabel.WndProc(var Message: TMessage); begin 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;
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';
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;
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;
procedure TGSFormattedLabel.SetLines(Lines: TStringlist); var i: integer; begin vLines.Text := Lines.Text;
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;
function GetColor(ColorName: string): TColor; begin try 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;
function TGSFormattedLabel.DoCanvasAction(vArg, vParam: string): boolean; begin result := true; try if vArg = 'c' then begin if vParam = 'def' then Canvas.Font.Color := vDefaultFont.Color else Canvas.Font.Color := GetColor(vParam) end else if vArg = 'fs' then begin if vParam = 'def' then Canvas.Font.Style := vDefaultFont.Style else Canvas.Font.Style := GetFontStyle(vParam); end else if vArg = 'n' then begin if vParam = 'def' then Canvas.Font.Name := vDefaultFont.Name else Canvas.Font.Name := vParam; end else if vArg = 's' then begin if vParam = 'def' then Canvas.Font.Size := vDefaultFont.Size else Canvas.Font.Size := StrToInt(vParam); end else if vArg = 'bc' then 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;
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 if Text[curletter] = '<' then begin inc(curletter); arg := '';
while (Text[curletter] <> '=') do begin arg := arg + Text[curletter]; inc(curletter); end;
inc(curletter); param := '';
while Text[curletter] <> '>' do begin param := param + Text[curletter]; inc(curletter);
end;
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 end;
Canvas.Font.Assign(vTempFont);
Canvas.Brush.Color := bc; Canvas.Brush.Style := bcS; end;
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;
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;
if vResetFontEachLine then begin Canvas.Font.Assign(vDefaultFont);
if vTransparent then Canvas.Brush.Style := bsClear else Canvas.Brush.Color := vColor;
Orientation := vAlignment; end;
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;
if Orientation = taLeftJustify then curx := 0 else if Orientation = taRightJustify then curx := width - w else curx := width div 2 - w div 2;
if Scrolling then case vScrollorientation of soLeft: dec(curx, vScrollVal); soRight: inc(curx, vScrollVal); end;
try while curletter <= Length(vLines[curline]) do begin if vLines[curline][curletter] = '<' then begin inc(curletter); arg := '';
while (vLines[curline][curletter] <> '=') do begin arg := arg + vLines[curline][curletter]; inc(curletter); end;
inc(curletter); param := '';
while vLines[curline][curletter] <> '>' do begin param := param + vLines[curline][curletter]; inc(curletter); end;
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 Canvas.TextOut(curx, curgroundline - Canvas.TextHeight(vLines[curline][curletter]), vLines[curline][curletter]); inc(curx, Canvas.TextWidth(vLines[curline][curletter])); end;
inc(curletter); end; except end; if w > maxx then maxx := w; inc(maxy, h);
inc(curline); end;
if (vAutoSize) and (Align = alNone) then if (curgroundline <> height) or (maxx <> width) then begin height := curgroundline; width := maxx; Repaint; end;
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. |