Changeset 568 for trunk/Packages

Timestamp:

May 13, 2024, 6:00:06 PM (6 months ago)

Author:

chronos

Message:

• Fixed: Custom draw ListBox items to keep consistent style on Linux.
• Fixed: Last game name index error if no saved games.

Location:

trunk/Packages

Files:

• CevoComponents/ButtonA.pas (modified) (1 diff)
• CevoComponents/CevoComponents.lpk (modified) (2 diffs)
• CevoComponents/CevoComponents.pas (modified) (2 diffs)
• DpiControls/Dpi.Common.pas (modified) (1 diff)
• DpiControls/Dpi.Graphics.pas (modified) (9 diffs)
• DpiControls/Dpi.StdCtrls.pas (modified) (12 diffs)

trunk/Packages/CevoComponents/ButtonA.pas

@@ -14 +14 @@
     procedure SetFont(const Font: TFont);
   protected
-    procedure SetCaption(Text: string); override;
+    procedure SetCaption(Text: string);
     procedure Paint; override;
   public

trunk/Packages/CevoComponents/CevoComponents.lpk

@@ -37 +37 @@
     <Description Value="C-evo components"/>
     <Version Major="1" Minor="2"/>
-    <Files Count="17">
+    <Files Count="18">
       <Item1>
         <Filename Value="Area.pas"/>
@@ -116 +116 @@
         <UnitName Value="ButtonG"/>
       </Item17>
+      <Item18>
+        <Filename Value="ListBoxEx.pas"/>
+        <HasRegisterProc Value="True"/>
+        <UnitName Value="ListBoxEx"/>
+      </Item18>
     </Files>
     <CompatibilityMode Value="True"/>

trunk/Packages/CevoComponents/CevoComponents.pas

@@ -10 +10 @@
 uses
   Area, ButtonA, ButtonB, ButtonC, ButtonN, EOTButton, ButtonBase, DrawDlg, 
-  Sound, BaseWin, AsyncProcess2, GraphicSet, Texture, ButtonG, 
+  Sound, BaseWin, AsyncProcess2, GraphicSet, Texture, ButtonG, ListBoxEx, 
   LazarusPackageIntf;
 
@@ -27 +27 @@
   RegisterUnit('GraphicSet', @GraphicSet.Register);
   RegisterUnit('ButtonG', @ButtonG.Register);
+  RegisterUnit('ListBoxEx', @ListBoxEx.Register);
 end;
 

trunk/Packages/DpiControls/Dpi.Common.pas

@@ -227 +227 @@
 begin
   Result := ScreenInfo.Lookup[Value];
-  // Round and Trunc are fast. Ceil and Floor slow.
+  // Round and Trunc are fast. Ceil and Floor are slow.
   // Without lookup table we would use:
   // Result := Ceil(Value * ScreenInfo.ToNative);

trunk/Packages/DpiControls/Dpi.Graphics.pas

@@ -8 +8 @@
 const
   clBlack = TColor($000000);
+  clWhite = TColor($ffffff);
 
 type
@@ -92 +93 @@
 
   TBrushStyle = Graphics.TBrushStyle;
+  TPenStyle = Graphics.TPenStyle;
 
   { TBrush }
@@ -131 +133 @@
     function GetHandle: HDC;
     function GetPixel(X, Y: Integer): TColor;
+    function GetTextStyle: TTextStyle;
     procedure SetBrush(AValue: TBrush);
     procedure SetFont(AValue: TFont);
@@ -137 +140 @@
     procedure SetPixel(X, Y: Integer; AValue: TColor);
     procedure SetNativeCanvas(AValue: Graphics.TCanvas);
+    procedure SetTextStyle(AValue: TTextStyle);
   protected
     procedure DoLine(X1, Y1, X2, Y2: Integer); virtual;
@@ -182 +186 @@
     function TextExtent(const Text: string): TSize; virtual;
     procedure TextOut(X, Y: Integer; const Text: string); virtual;
-    procedure TextRect(ARect: TRect; X, Y: Integer; Text: string);
+    procedure TextRect(ARect: TRect; X, Y: Integer; Text: string); overload;
+    procedure TextRect(ARect: TRect; X, Y: integer; const Text: string;
+      const Style: TTextStyle); overload;
     procedure MoveTo(X, Y: Integer);
     procedure LineTo(X, Y: Integer);
@@ -196 +202 @@
     property Width: Integer read GetWidth;
     property Height: Integer read GetHeight;
+    property TextStyle: TTextStyle read GetTextStyle write SetTextStyle;
   published
     property Brush: TBrush read FBrush write SetBrush;
@@ -966 +973 @@
 end;
 
+function TCanvas.GetTextStyle: TTextStyle;
+begin
+  Result := GetNativeCanvas.TextStyle;
+end;
+
 function TCanvas.GetWidth: Integer;
 begin
@@ -1039 +1051 @@
 end;
 
+procedure TCanvas.SetTextStyle(AValue: TTextStyle);
+begin
+  GetNativeCanvas.TextStyle := AValue;
+end;
+
 procedure TCanvas.DoLine(X1, Y1, X2, Y2: Integer);
 begin
@@ -1213 +1230 @@
 procedure TCanvas.TextRect(ARect: TRect; X, Y: Integer; Text: string);
 begin
-  GetNativeCanvas.TextRect(ScaleRectToNative(ARect), ScaleToNative(X), ScaleToNative(Y), Text);
+  GetNativeCanvas.TextRect(ScaleRectToNative(ARect), ScaleToNative(X),
+    ScaleToNative(Y), Text);
+end;
+
+procedure TCanvas.TextRect(ARect: TRect; X, Y: integer; const Text: string;
+  const Style: TTextStyle);
+begin
+  GetNativeCanvas.TextRect(ScaleRectToNative(ARect), ScaleToNative(X),
+    ScaleToNative(Y), Text, TextStyle);
 end;
 

trunk/Packages/DpiControls/Dpi.StdCtrls.pas

@@ -4 +4 @@
 
 uses
-  Classes, SysUtils, Controls, StdCtrls, Forms, Dpi.Controls;
+  Classes, SysUtils, Controls, StdCtrls, Forms, Dpi.Controls, Dpi.Graphics;
 
 type
@@ -104 +104 @@
   end;
 
+  TDrawItemEvent = procedure(Control: TWinControl; Index: Integer;
+    ARect: TRect; State: TOwnerDrawState) of object;
+  TListBoxStyle = StdCtrls.TListBoxStyle;
+
   { TListBox }
 
   TListBox = class(TWinControl)
   private
+    FCanvas: TCanvas;
+    FOnDrawItem: TDrawItemEvent;
     function GetBorderStyle: TBorderStyle;
     function GetCount: Integer;
@@ -118 +124 @@
     function GetParentFont: Boolean;
     function GetScrollWidth: Integer;
+    function GetStyle: TListBoxStyle;
     function GetTopIndex: Integer;
     procedure SetBorderStyle(AValue: TBorderStyle);
@@ -125 +132 @@
     procedure SetItemIndex(AValue: Integer);
     procedure SetItems(AValue: TStrings);
+    procedure SetOnDrawItem(AValue: TDrawItemEvent);
     procedure SetOnSelectionChange(AValue: TSelectionChangeEvent);
     procedure SetParentFont(AValue: Boolean);
     procedure SetScrollWidth(AValue: Integer);
+    procedure SetStyle(AValue: TListBoxStyle);
     procedure SetTopIndex(AValue: Integer);
+    procedure DoDrawItemNative(Control: Controls.TWinControl; Index: Integer;
+      ARect: TRect; State: TOwnerDrawState);
   protected
     function GetNativeWinControl: Controls.TWinControl; override;
@@ -134 +145 @@
   public
     NativeListBox: StdCtrls.TListBox;
+    constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
     property ItemIndex: Integer read GetItemIndex write SetItemIndex;
     property Items: TStrings read GetItems write SetItems;
     property Count: Integer read GetCount;
+    property Canvas: TCanvas read FCanvas;
   published
     property ParentColor;
@@ -151 +164 @@
     property OnSelectionChange: TSelectionChangeEvent read GetOnSelectionChange
                                                       write SetOnSelectionChange;
+    property Style: TListBoxStyle read GetStyle write SetStyle default lbStandard;
+    property OnDrawItem: TDrawItemEvent read FOnDrawItem write SetOnDrawItem;
   end;
 
@@ -497 +512 @@
 function TListBox.GetItemHeight: Integer;
 begin
-  Result := GetNativeListBox.ItemHeight;
+  Result := ScaleFromNative(GetNativeListBox.ItemHeight);
 end;
 
@@ -525 +540 @@
 end;
 
+function TListBox.GetStyle: TListBoxStyle;
+begin
+  Result := GetNativeListBox.Style;
+end;
+
 function TListBox.GetTopIndex: Integer;
 begin
@@ -547 +567 @@
 procedure TListBox.SetItemHeight(AValue: Integer);
 begin
-  GetNativeListBox.ItemHeight := AValue;
+  GetNativeListBox.ItemHeight := ScaleToNative(AValue);
 end;
 
@@ -560 +580 @@
 end;
 
+procedure TListBox.SetOnDrawItem(AValue: TDrawItemEvent);
+begin
+  FOnDrawItem := AValue;
+  if Assigned(AValue) then
+    GetNativeListBox.OnDrawItem := DoDrawItemNative
+    else GetNativeListBox.OnDrawItem := nil;
+end;
+
 procedure TListBox.SetOnSelectionChange(AValue: TSelectionChangeEvent);
 begin
@@ -575 +603 @@
 end;
 
+procedure TListBox.SetStyle(AValue: TListBoxStyle);
+begin
+  GetNativeListBox.Style := AValue;
+end;
+
 procedure TListBox.SetTopIndex(AValue: Integer);
 begin
   GetNativeListBox.TopIndex := AValue;
+end;
+
+procedure TListBox.DoDrawItemNative(Control: Controls.TWinControl;
+  Index: Integer; ARect: TRect; State: TOwnerDrawState);
+begin
+  if Assigned(FOnDrawItem) then
+    FOnDrawItem(Self, Index, ScaleRectFromNative(ARect), State);
 end;
 
@@ -591 +631 @@
 end;
 
+constructor TListBox.Create(AOwner: TComponent);
+begin
+  inherited;
+  FCanvas := TCanvas.Create;
+  FCanvas.NativeCanvas := GetNativeListBox.Canvas;
+end;
+
 destructor TListBox.Destroy;
 begin
+  FreeAndNil(FCanvas);
   FreeAndNil(NativeListBox);
   inherited;