Recent

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

RAW

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

The original can be found here:
https://forum.lazarus.freepascal.org/index.php/topic,38151.msg258636.html#msg258636
« Last Edit: August 28, 2019, 03:22:38 am 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