Recent

Author Topic: Scroll Label Demo (TWpLabel aka TScrollLabel)  (Read 224 times)

RAW

  • Hero Member
  • *****
  • Posts: 781
Scroll Label Demo (TWpLabel aka TScrollLabel)
« on: July 30, 2019, 04:30:03 pm »
I know this little control isn't part of the LCL, but I think it's incredible useful (especially with a classic theme) and it could be part of it. Anyway this way it's easier to find it I guess...

Code: Pascal  [Select]
  1. UNIT uWpLabelBasic;
  2. {$MODE OBJFPC}{$H+}
  3.  
  4. INTERFACE
  5.  
  6. USES
  7.   Classes,
  8.   Controls,
  9.   Graphics;
  10.  
  11. TYPE
  12.   TScrollBasic = Class(TGraphicControl)
  13.    PRIVATE
  14.     slItems    : TStrings;
  15.     iTopLine   : Integer;
  16.     iItemHeight: Integer;
  17.     iAddHeight : Integer; // additional space between text and top/bottom (sum)
  18.     iTextPos   : Integer;
  19.     bsBrush    : TBrushStyle;
  20.     Function  GetCaption   : String;
  21.     Procedure SetCaption   (Const str: String);
  22.     Function  GetFont      : TFont;
  23.     Procedure SetFont      (Const Ft: TFont);
  24.     Procedure SetItems     (Const sl: TStrings);
  25.     Procedure SetBrush     (Const bs: TBrushStyle);
  26.     Procedure SetAddHeight (Const i: Integer);
  27.     Procedure SetTextPos   (Const i: Integer);
  28.    PUBLIC
  29.     Constructor Create           (AOwner: TComponent); Override;
  30.     Destructor  Destroy;         Override;
  31.     Procedure   Paint;           Override;
  32.     Function    ItemsPerPage     : Integer;
  33.     Procedure   ScrollBy         (i: Integer);
  34.     Procedure   ScrollTo         (i: Integer);
  35.     Procedure   MouseWheelScroll (iLeft, iMaxLine, iScroll: Integer;
  36.                                   Shift: TShiftState; WheelDelta: Integer);
  37.     Procedure  KeyboardVkRight (iMaxLine, iScroll: Integer; Shift: TShiftState);
  38.     Procedure  KeyboardVkLeft  (iLeft, iScroll: Integer; Shift: TShiftState);
  39.    PUBLISHED
  40.     Property Color;
  41.     Property TopLine: Integer Read iTopLine;
  42.     Property AddHeight: Integer Read iAddHeight Write SetAddHeight Default 0;
  43.     Property TextPos: Integer Read iTextPos Write SetTextPos Default 0;
  44.     Property Items: TStrings Read slItems Write SetItems;
  45.     Property Font: TFont Read GetFont Write SetFont;
  46.     Property Caption: String Read GetCaption Write SetCaption;
  47.     Property BrushStyle: TBrushStyle Read bsBrush Write SetBrush;
  48.     Property OnMouseMove;
  49.     Property OnMouseDown;
  50.   End;
  51.  
  52. IMPLEMENTATION
  53.  
  54. Constructor TScrollBasic.Create(AOwner: TComponent);
  55. Begin
  56.   Inherited;
  57.   slItems:= TStringList.Create;
  58. End;
  59.  
  60. Destructor TScrollBasic.Destroy;
  61. Begin
  62.   slItems.Free;
  63.   Inherited;
  64. End;
  65.  
  66. Function TScrollBasic.GetCaption: String;
  67. Begin
  68.   Result:= slItems.Text;
  69. End;
  70.  
  71. Procedure TScrollBasic.SetCaption(Const str: String);
  72. Begin
  73.   slItems.Text:= str;
  74.   iTopLine:= 0;
  75.   Invalidate;
  76. End;
  77.  
  78. Function TScrollBasic.GetFont: TFont;
  79. Begin
  80.   Result:= Inherited Font;
  81. End;
  82.  
  83. Procedure TScrollBasic.SetFont(Const Ft: TFont);
  84. Begin
  85.   Inherited Font:= Ft;
  86.   Canvas.Font:= Ft;
  87.   iItemHeight:= Canvas.TextHeight('Û')+iAddHeight;
  88. End;
  89.  
  90. Procedure TScrollBasic.SetItems(Const sl: TStrings);
  91. Begin
  92.   slItems.Assign(sl);
  93.   iTopLine:= 0;
  94.   Invalidate;
  95. End;
  96.  
  97. Function TScrollBasic.ItemsPerPage: Integer;
  98. Begin
  99.   Result:= Height Div iItemHeight;
  100. End;
  101.  
  102. Procedure TScrollBasic.SetAddHeight(Const i: Integer);
  103. Begin
  104.   iAddHeight:= i;
  105.   Invalidate;
  106. End;
  107.  
  108. Procedure TScrollBasic.SetTextPos(Const i: Integer);
  109. Begin
  110.   iTextPos:= i;
  111. End;
  112.  
  113. Procedure TScrollBasic.SetBrush(Const bs: TBrushStyle);
  114. Begin
  115.   bsBrush:= bs;
  116.   Invalidate;
  117. End;
  118.  
  119. Procedure TScrollBasic.Paint;
  120. Var
  121.  i, iy: Integer;
  122. Begin
  123.   Canvas.Font.Assign(Font);
  124.    If iItemHeight = 0
  125.    Then iItemHeight:= Canvas.TextHeight('Û')+iAddHeight;
  126.   Canvas.Brush.Style:= bsBrush;
  127.    If (Canvas.Brush.Style <> bsClear)
  128.    Then
  129.     Begin
  130.       Canvas.Brush.Color:= Color;
  131.       Canvas.FillRect(Rect(0, 0, Width, Height));
  132.     End;
  133.  
  134.    i:= iTopLine;
  135.    iy:= 0;
  136.  
  137.   While (iy < Height) And (i < slItems.Count)
  138.   Do
  139.    Begin
  140.     Canvas.TextOut(iTextPos, iy+(iAddHeight SHR 1), slItems[i]);
  141.     Inc(iy, iItemHeight);
  142.     Inc(i);
  143.    End;
  144. End;
  145.  
  146. Procedure TScrollBasic.ScrollTo(i: Integer);
  147. Begin
  148.   If slItems.Count <= ItemsPerPage Then Exit;
  149.   If i < 0 Then i:= 0
  150.   Else
  151.    Begin
  152.     If i+ItemsPerPage >= slItems.Count
  153.     Then i:= slItems.Count-ItemsPerPage;
  154.    End;
  155.   iTopLine:= i;
  156.   Invalidate;
  157. End;
  158.  
  159. Procedure TScrollBasic.ScrollBy(i: Integer);
  160. Begin
  161.   ScrollTo(iTopLine+i);
  162. End;
  163.  
  164. Procedure TScrollBasic.KeyboardVkLeft
  165. (iLeft, iScroll: Integer; Shift: TShiftState);
  166. Begin
  167.   If Shift = [ssSHIFT]
  168.   Then
  169.    Begin
  170.      iTextPos:= iLeft;
  171.      Invalidate;
  172.    End
  173.   Else If Shift = []
  174.   Then
  175.    Begin
  176.      iTextPos:= iTextPos+iScroll;
  177.      If iTextPos > iLeft Then iTextPos:= iLeft;
  178.      Invalidate;
  179.    End;
  180. End;
  181.  
  182. Procedure TScrollBasic.KeyboardVkRight
  183. (iMaxLine, iScroll: Integer; Shift: TShiftState);
  184. Begin
  185.   If Shift = [ssSHIFT]
  186.   Then
  187.    Begin
  188.      If iMaxLine > Width
  189.      Then
  190.       Begin
  191.         iTextPos:= Width-iMaxLine-10;
  192.         Invalidate;
  193.       End;
  194.    End
  195.   Else If Shift = []
  196.   Then
  197.    Begin
  198.      If iMaxLine > Width
  199.      Then
  200.       Begin
  201.         iTextPos:= iTextPos-iScroll;
  202.         If iTextPos < Width-iMaxLine
  203.         Then iTextPos:= Width-iMaxLine-10;
  204.         Invalidate;
  205.       End;
  206.    End;
  207. End;
  208.  
  209. Procedure TScrollBasic.MouseWheelScroll
  210. (iLeft, iMaxLine, iScroll: Integer; Shift: TShiftState; WheelDelta: Integer);
  211. Begin
  212.   If Shift = []
  213.   Then
  214.    Begin
  215.      If WheelDelta > 0
  216.      Then ScrollBy(-1)
  217.      Else ScrollBy(+1);
  218.    End
  219.   Else If Shift = [ssCTRL]
  220.   Then
  221.    Begin
  222.      If WheelDelta > 0
  223.      Then ScrolLBy(-ItemsPerPage)
  224.      Else ScrolLBy(+ItemsPerPage);
  225.    End
  226.   Else If Shift = [ssSHIFT]
  227.   Then
  228.    Begin
  229.     If WheelDelta > 0
  230.     Then
  231.      Begin
  232.       If iMaxLine > Width
  233.       Then
  234.        Begin
  235.          iTextPos:= iTextPos+iScroll;
  236.          If iTextPos > iLeft Then iTextPos:= iLeft;
  237.          Invalidate;
  238.        End;
  239.      End
  240.     Else
  241.      Begin
  242.       If iMaxLine > Width
  243.       Then
  244.        Begin
  245.          iTextPos:= iTextPos-iScroll;
  246.          If iTextPos < Width-iMaxLine
  247.          Then iTextPos:= Width-iMaxLine-10;
  248.          Invalidate;
  249.        End;
  250.      End;
  251.    End;
  252. End;
  253.  
  254. {
  255. Procedure TWndMain.FormKeyDown
  256. (Sender: TObject; Var Key: Word; Shift: TShiftState);
  257. Begin
  258.   Case Key Of
  259.    VK_UP   : wpLabel.ScrollBy(-1);
  260.    VK_DOWN : wpLabel.ScrollBy(+1);
  261.    VK_PRIOR: wpLabel.ScrolLBy(-wpLabel.ItemsPerPage);
  262.    VK_NEXT : wpLabel.ScrollBy(+wpLabel.ItemsPerPage);
  263.    VK_HOME : wpLabel.ScrollTo(0);
  264.    VK_END  : wpLabel.ScrollTo(wpLabel.Items.Count);
  265.    VK_LEFT : wpLabel.KeyboardVkLeft(0, 30, Shift);
  266.    VK_RIGHT: wpLabel.KeyboardVkRight(iLongLine, 30, Shift);
  267.   End;
  268. End;
  269.  
  270. Procedure TwndMain.FormMouseWheel
  271. (Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint;
  272.  Var Handled: Boolean);
  273. Begin
  274.   wpLabel.MouseWheelScroll(0, iLongLine, 30, Shift, WheelDelta);
  275. End;
  276.  
  277. Procedure TwndMain.FormResize(Sender: TObject);
  278. Begin
  279.   wpLabel.TextPos:= 0;
  280.   wpLabel.SetBounds(0, 0, ClientWidth, ClientHeight);
  281. End;
  282. }
  283. END.

The original can be found here:
https://forum.lazarus.freepascal.org/index.php/topic,38151.msg258636.html#msg258636
« Last Edit: August 15, 2019, 11:54:23 pm by RAW »
Windows 7 Pro (x64 Sp1) And Windows XP Pro (x86 Sp3) - LAZARUS 2.0.4 FPC 3.0.4 - TRUNK 2.1.0 FPC 3.3.1