Adding BCListBoxEx

bclistboxex.pas

@@ -0,0 +1,238 @@
+unit BCListBoxEx;
+
+{$mode delphi}
+
+interface
+
+uses
+  Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs,
+  LCLType;
+
+type
+  TBCListBoxEx = class(TCustomControl)
+  private
+    mousepos: TPoint;
+    scrolly: integer;
+    fitems: TStringList;
+    itemselected: integer;
+    itemheight: integer;
+    lastitem: integer;
+    invalidatecount: integer;
+    scrollwidth: integer;
+    function GetItemRect(index: integer): TRect;
+    function GetItemVertically(y: integer): integer;
+    procedure ScrollToItemTop();
+    procedure ScrollToItemBottom();
+    procedure ScrollToItem(index: integer);
+    function ItemIsVisible(index: integer): boolean;
+  protected
+    procedure Click; override;
+    procedure KeyDown(var Key: word; Shift: TShiftState); override;
+    procedure MouseMove(Shift: TShiftState; X, Y: integer); override;
+    function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): boolean; override;
+    function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): boolean; override;
+    procedure Paint; override;
+  public
+    constructor Create(AOwner: TComponent); override;
+    destructor Destroy; override;
+  published
+    property Align;
+    property Items: TStringList read Fitems;
+  end;
+
+procedure Register;
+
+implementation
+
+procedure Register;
+begin
+  RegisterComponents('BGRA Controls', [TBCListBoxEx]);
+end;
+
+procedure TBCListBoxEx.Click;
+var
+  tempitem: integer;
+begin
+  tempitem := GetItemVertically(mousepos.Y);
+  if tempitem <> itemselected then
+  begin
+    itemselected := tempitem;
+    Invalidate;
+  end;
+end;
+
+constructor TBCListBoxEx.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  scrolly := 0;
+  itemheight := 150;
+  scrollwidth := 20;
+  lastitem := -1;
+  invalidatecount := 0;
+  itemselected := -1;
+  fitems := TStringList.Create;
+end;
+
+destructor TBCListBoxEx.Destroy;
+begin
+  items.Free;
+end;
+
+procedure TBCListBoxEx.KeyDown(var Key: word; Shift: TShiftState);
+var
+  tempitem: integer;
+begin
+  case key of
+    vk_down:
+    begin
+      tempitem := itemselected + 1;
+      if (tempitem < items.Count) then
+      begin
+        itemselected := tempitem;
+        if not ItemIsVisible(itemselected) then
+          ScrollToItemBottom();
+        if not ItemIsVisible(itemselected) then
+          ScrollToItem(itemselected);
+        Invalidate;
+      end;
+    end;
+    vk_up:
+    begin
+      tempitem := itemselected - 1;
+      if (tempitem >= 0) then
+      begin
+        itemselected := tempitem;
+        if not ItemIsVisible(itemselected) then
+          ScrollToItemTop();
+        if not ItemIsVisible(itemselected) then
+          ScrollToItem(itemselected);
+        Invalidate;
+      end;
+    end;
+  end;
+end;
+
+procedure TBCListBoxEx.MouseMove(Shift: TShiftState; X, Y: integer);
+var
+  tempitem: integer;
+begin
+  mousepos := Point(x, y);
+  tempitem := GetItemVertically(mousepos.Y);
+  if tempitem <> lastitem then
+  begin
+    lastitem := tempitem;
+    Invalidate;
+  end;
+end;
+
+function TBCListBoxEx.DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): boolean;
+var
+  r: TRect;
+begin
+  result := False;
+  r := GetItemRect(items.Count - 1);
+  if (r.Bottom >= Height) then
+  begin
+    result := True;
+    scrolly := scrolly - itemheight;
+    Invalidate;
+  end;
+end;
+
+function TBCListBoxEx.DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): boolean;
+var
+  lastscroll: integer;
+begin
+  result := False;
+  lastscroll := scrolly;
+  scrolly := scrolly + itemheight;
+  if (scrolly > 0) then
+    scrolly := 0;
+  if scrolly <> lastscroll then
+  begin
+    result := True;
+    Invalidate;
+  end;
+end;
+
+procedure TBCListBoxEx.Paint;
+var
+  i: integer;
+  r: TRect;
+  style: TTextStyle;
+  start: integer;
+begin
+  style.Alignment := taCenter;
+  style.Layout := tlCenter;
+  start := -1;
+
+  for i := trunc(abs(scrolly) / itemheight) to items.Count - 1 do
+  begin
+    r := GetItemRect(i);
+
+    if (r.Top < Height) then
+    begin
+      if start = -1 then
+        start := i;
+      Canvas.Brush.Color := clGreen;
+      if (GetItemVertically(mousepos.Y) = i) then
+        canvas.Brush.Color := clMoneyGreen;
+      if (itemselected = i) then
+        canvas.Brush.Color := clBlue;
+      Canvas.Rectangle(r);
+      Canvas.Font.Color := clWhite;
+      Canvas.TextRect(r, 0, 0, items[i], style);
+      Caption := IntToStr(start) + '..' + IntToStr(i);
+    end
+    else
+      break;
+  end;
+
+  Canvas.Brush.Color := clGray;
+  Canvas.Rectangle(Width - scrollwidth, 0, Width, Height);
+
+  Canvas.Font.Color := clRed;
+  Canvas.TextOut(10, 10, IntToStr(invalidatecount));
+  Inc(invalidatecount);
+end;
+
+function TBCListBoxEx.GetItemRect(index: integer): TRect;
+begin
+  Result := Rect(0, (index * itemheight) + scrolly, Width - scrollwidth,
+    (index * itemheight) + scrolly + itemheight);
+end;
+
+function TBCListBoxEx.GetItemVertically(y: integer): integer;
+var
+  i: integer;
+begin
+  i := trunc(abs(scrolly) / itemheight);
+  Result := i + trunc(y / itemheight);
+  if (Result > items.Count) or (Result < 0) then
+    Result := -1;
+end;
+
+procedure TBCListBoxEx.ScrollToItemTop();
+begin
+  scrolly := scrolly + itemheight;
+end;
+
+procedure TBCListBoxEx.ScrollToItemBottom();
+begin
+  scrolly := scrolly - itemheight;
+end;
+
+procedure TBCListBoxEx.ScrollToItem(index: integer);
+begin
+  scrolly := -itemheight * index;
+end;
+
+function TBCListBoxEx.ItemIsVisible(index: integer): boolean;
+var
+  r: TRect;
+begin
+  r := GetItemRect(index);
+  Result := Rect(0, 0, Width, Height).Contains(r);
+end;
+
+end.

bgracontrols.lpk

@@ -34,7 +34,7 @@
     <Description Value="BGRA Controls is a set of graphical UI elements that you can use with Lazarus LCL applications."/>
     <License Value="Modified LGPL"/>
     <Version Major="6" Minor="9"/>
-    <Files Count="59">
+    <Files Count="60">
       <Item1>
         <Filename Value="atshapelinebgra.pas"/>
         <HasRegisterProc Value="True"/>
@@ -322,6 +322,11 @@
         <AddToUsesPkgSection Value="False"/>
         <UnitName Value="MouseAndKeyInput"/>
       </Item59>
+      <Item60>
+        <Filename Value="bclistboxex.pas"/>
+        <HasRegisterProc Value="True"/>
+        <UnitName Value="BCListBoxEx"/>
+      </Item60>
     </Files>
     <CompatibilityMode Value="True"/>
     <LazDoc Paths="fpdoc"/>

bgracontrols.pas

@@ -19,7 +19,7 @@ uses
   BGRAShape, BGRASpeedButton, BGRASpriteAnimation, BGRATheme, BGRAThemeButton, 
   BGRAThemeCheckBox, BGRAThemeRadioButton, BGRAVirtualScreen, 
   ColorSpeedButton, DTAnalogClock, DTAnalogCommon, DTAnalogGauge, 
-  dtthemedclock, dtthemedgauge, MaterialColors, LazarusPackageIntf;
+  dtthemedclock, dtthemedgauge, MaterialColors, BCListBoxEx, LazarusPackageIntf;
 
 implementation
 
@@ -65,6 +65,7 @@ begin
   RegisterUnit('DTAnalogGauge', @DTAnalogGauge.Register);
   RegisterUnit('dtthemedclock', @dtthemedclock.Register);
   RegisterUnit('dtthemedgauge', @dtthemedgauge.Register);
+  RegisterUnit('BCListBoxEx', @BCListBoxEx.Register);
 end;
 
 initialization

test/test_bclistboxex/test_bclistboxex.lpi

@@ -0,0 +1,80 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="12"/>
+    <PathDelim Value="\"/>
+    <General>
+      <SessionStorage Value="InProjectDir"/>
+      <Title Value="test_bclistboxex"/>
+      <Scaled Value="True"/>
+      <ResourceType Value="res"/>
+      <UseXPManifest Value="True"/>
+      <XPManifest>
+        <DpiAware Value="True"/>
+      </XPManifest>
+      <Icon Value="0"/>
+    </General>
+    <BuildModes>
+      <Item Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+      <UseFileFilters Value="True"/>
+    </PublishOptions>
+    <RunParams>
+      <FormatVersion Value="2"/>
+    </RunParams>
+    <RequiredPackages>
+      <Item>
+        <PackageName Value="bgracontrols"/>
+      </Item>
+      <Item>
+        <PackageName Value="LCL"/>
+      </Item>
+    </RequiredPackages>
+    <Units>
+      <Unit>
+        <Filename Value="test_bclistboxex.lpr"/>
+        <IsPartOfProject Value="True"/>
+      </Unit>
+      <Unit>
+        <Filename Value="umain.pas"/>
+        <IsPartOfProject Value="True"/>
+        <ComponentName Value="Form1"/>
+        <HasResources Value="True"/>
+        <ResourceBaseClass Value="Form"/>
+      </Unit>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <PathDelim Value="\"/>
+    <Target>
+      <Filename Value="test_bclistboxex"/>
+    </Target>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+      <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
+    </SearchPaths>
+    <Linking>
+      <Options>
+        <Win32>
+          <GraphicApplication Value="True"/>
+        </Win32>
+      </Options>
+    </Linking>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions>
+      <Item>
+        <Name Value="EAbort"/>
+      </Item>
+      <Item>
+        <Name Value="ECodetoolError"/>
+      </Item>
+      <Item>
+        <Name Value="EFOpenError"/>
+      </Item>
+    </Exceptions>
+  </Debugging>
+</CONFIG>

test/test_bclistboxex/test_bclistboxex.lpr

@@ -0,0 +1,25 @@
+program test_bclistboxex;
+
+{$mode objfpc}{$H+}
+
+uses
+  {$IFDEF UNIX}
+  cthreads,
+  {$ENDIF}
+  {$IFDEF HASAMIGA}
+  athreads,
+  {$ENDIF}
+  Interfaces, // this includes the LCL widgetset
+  Forms, umain
+  { you can add units after this };
+
+{$R *.res}
+
+begin
+  RequireDerivedFormResource:=True;
+  Application.Scaled:=True;
+  Application.Initialize;
+  Application.CreateForm(TForm1, Form1);
+  Application.Run;
+end.
+

test/test_bclistboxex/umain.lfm

@@ -0,0 +1,18 @@
+object Form1: TForm1
+  Left = 368
+  Height = 694
+  Top = 119
+  Width = 807
+  Caption = 'Form1'
+  ClientHeight = 694
+  ClientWidth = 807
+  OnCreate = FormCreate
+  LCLVersion = '2.1.0.0'
+  object BCListBoxEx1: TBCListBoxEx
+    Left = 0
+    Height = 694
+    Top = 0
+    Width = 807
+    Align = alClient
+  end
+end

test/test_bclistboxex/umain.pas

@@ -0,0 +1,49 @@
+unit umain;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, BCListBoxEx,
+  BCTrackbarupdown;
+
+type
+
+  { TForm1 }
+
+  TForm1 = class(TForm)
+    BCListBoxEx1: TBCListBoxEx;
+    procedure FormCreate(Sender: TObject);
+  private
+
+  public
+
+  end;
+
+var
+  Form1: TForm1;
+
+implementation
+
+{$R *.lfm}
+
+{ TForm1 }
+
+procedure TForm1.FormCreate(Sender: TObject);
+begin
+  with BCListBoxEx1 do
+  begin
+    items.Add('Argentina');
+    items.Add('Brasil');
+    items.Add('Paraguay');
+    items.Add('Uruguay');
+    items.Add('Chile');
+    items.Add('Bolivia');
+    items.Add('Peru');
+    items.Add('Ecuador');
+  end;
+end;
+
+end.
+