Merge pull request #90 from bgrabitmap/dev-bgracontrols

Dev bgracontrols
bgrabitmap · Oct 18, 2020 · 117d282 · 117d282
2 parents 5aefd5f + 778513f
commit 117d282
Show file tree

Hide file tree

Showing 17 changed files with 857 additions and 150 deletions.
diff --git a/bcbutton.pas b/bcbutton.pas
diff --git a/bccombobox.pas b/bccombobox.pas
diff --git a/bclistboxex.pas b/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.
diff --git a/bctools.pas b/bctools.pas
@@ -19,6 +19,7 @@ interface
   {$IFDEF FPC}LCLType, LCLIntf,{$ENDIF} {$IFNDEF FPC}BGRAGraphics, GraphType, FPImage, {$ENDIF}
   BGRABitmap, BGRABitmapTypes, bctypes, Controls, BGRAGradientScanner;
 
+function ScaleRect(ARect: TRect; AScale: Single): TRect;
 // This method prepare BGRABitmap for rendering BCFont type
 procedure AssignBCFont(AFont: TBCFont; var ATargetBGRA: TBGRABitmap);
 // Calculate text height and width (doesn't include wordwrap - just single line)
@@ -37,7 +38,8 @@ procedure GetGlyphActualLayout(ACaption: string; AFont: TBCFont;
 // Specify the flag AOldPlacement to have the old (buggy) version
 function ComputeGlyphPosition(var rAvail: TRect;
   AGlyph: TBitmap; AGlyphAlignment: TBCAlignment; AGlyphMargin: integer;
-  ACaption: string; AFont: TBCFont; AOldPlacement: boolean): TRect;
+  ACaption: string; AFont: TBCFont; AOldPlacement: boolean;
+  AGlyphScale: Single = 1): TRect;
 // This method correct TRect to border width. As far as border width is bigger,
 // BGRA drawing rectangle with offset (half border width)
 procedure CalculateBorderRect(ABorder: TBCBorder; var ARect: TRect);
@@ -246,6 +248,13 @@ function BCAlign2VAlign(AAlign: TBCAlignment): TTextLayout;
     Result := tlTop;
 end;
 
+function ScaleRect(ARect: TRect; AScale: Single): TRect;
+begin
+  with ARect do
+    result := rect(round(Left*AScale), round(Top*AScale),
+      round(Right*AScale), round(Bottom*AScale));
+end;
+
 procedure AssignBCFont(AFont: TBCFont; var ATargetBGRA: TBGRABitmap);
 var c: TBitmap;
 begin
@@ -435,7 +444,8 @@ procedure GetGlyphActualLayout(ACaption: string; AFont: TBCFont;
 
 function ComputeGlyphPosition(var rAvail: TRect;
   AGlyph: TBitmap; AGlyphAlignment: TBCAlignment; AGlyphMargin: integer;
-  ACaption: string; AFont: TBCFont; AOldPlacement: boolean): TRect;
+  ACaption: string; AFont: TBCFont; AOldPlacement: boolean;
+  AGlyphScale: Single = 1): TRect;
 var
   gw,gh, w, h, w2,h2, glyphHorzMargin, glyphVertMargin: integer;
   horizAlign, relHorizAlign: TAlignment;
@@ -461,8 +471,8 @@ function ComputeGlyphPosition(var rAvail: TRect;
 begin
   if Assigned(AGlyph) and not AGlyph.Empty then
   begin
-    gw := AGlyph.Width;
-    gh := AGlyph.Height;
+    gw := round(AGlyph.Width * AGlyphScale);
+    gh := round(AGlyph.Height * AGlyphScale);
   end
   else exit(EmptyRect);
 

diff --git a/bctrackbarupdown.pas b/bctrackbarupdown.pas
@@ -85,6 +85,7 @@   TCustomBCTrackbarUpdown = class(TBCCustomControl)
     procedure MouseDown(Button: TMouseButton; {%H-}Shift: TShiftState; X, Y: Integer); override;
     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
     procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
+    function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override;
     procedure UTF8KeyPress(var UTF8Key: {$IFDEF FPC}TUTF8Char{$ELSE}String{$ENDIF}); override;
     procedure DoEnter; override;
     procedure DoExit; override;
@@ -623,6 +624,21 @@ procedure TCustomBCTrackbarUpdown.MouseUp(Button: TMouseButton;
   end;
 end;
 
+function TCustomBCTrackbarUpdown.DoMouseWheel(Shift: TShiftState;
+  WheelDelta: Integer; MousePos: TPoint): Boolean;
+begin
+  if Assigned(OnMouseWheel) or Assigned(OnMouseWheelDown) or Assigned(OnMouseWheelUp) then
+  begin
+    result := inherited DoMouseWheel(Shift, WheelDelta, MousePos);
+    exit;
+  end;
+  FHandlingUserInput:= true;
+  Value := Value + Increment*WheelDelta div 120;
+  FHandlingUserInput := false;
+  Invalidate;
+  result := true;
+end;
+
 procedure TCustomBCTrackbarUpdown.UTF8KeyPress(var UTF8Key: {$IFDEF FPC}TUTF8Char{$ELSE}String{$ENDIF});
 var tempText: string;
 begin