Merged revision(s) 43576-43579 #3ffbdeb81a-#3ffbdeb81a from trunk:

LCL: BiDiMode and FlipChildren fixes for TRadioGroup, TCheckGroup and TCheckListbox, patch by wp, bug #25408 ........ Tests: added BiDiMode and FlipChildren test by wp, bug #25408 ........ Docs: added Werner Pamler aka wp to contributors list ........ git-svn-id: branches/fixes_1_2@43584 -
2025-09-01 21:20:28 +02:00 · 2013-12-22 22:06:29 +00:00 · 2013-12-22 22:06:29 +00:00 · c1865360ec
commit c1865360ec
parent 868da26bb5
11 changed files with 366 additions and 15 deletions
--- a/.gitattributes
+++ b/.gitattributes
@ -7123,6 +7123,10 @@ test/lcltests/testpen.pas svneol=native#text/plain
 test/lcltests/testpreferredsize.pas svneol=native#text/plain
 test/lcltests/testtextstrings.pas svneol=native#text/plain
 test/lcltests/testunicode.pas svneol=native#text/plain
+test/manual/bidimode_flipchildren/project1.lpi svneol=native#text/plain
+test/manual/bidimode_flipchildren/project1.lpr svneol=native#text/pascal
+test/manual/bidimode_flipchildren/unit1.lfm svneol=native#text/plain
+test/manual/bidimode_flipchildren/unit1.pas svneol=native#text/pascal
 test/manual/lcl/textextent/mainform.lfm svneol=native#text/plain
 test/manual/lcl/textextent/mainform.pas svneol=native#text/plain
 test/manual/lcl/textextent/textextent.ico -text
--- a/docs/Contributors.txt
+++ b/docs/Contributors.txt
@ -189,6 +189,7 @@ Vladimir Serotyukov
 Vladimir Zhirov
 Vojtech Cihak
 Wanderlan Santos dos Anjos
+Werner Pamler
 Wojciech Malinowski
 Yauheni Nazimau
 Yuichiro Takahashi
--- a/lcl/checklst.pas
+++ b/lcl/checklst.pas
@ -1,5 +1,4 @@
-{ $Id$
- /***************************************************************************
+{ /***************************************************************************
                               checklst.pas
                               ------------

@ -185,8 +184,12 @@ end;

 procedure TCustomCheckListBox.DrawItem(AIndex: Integer; ARect: TRect; State: TOwnerDrawState);
 begin
-  if not Header[AIndex] then
-    Inc(ARect.Left, GetCheckWidth);
+  if not Header[AIndex] then begin
+    if UseRightToLeftAlignment then
+      Dec(ARect.Right, GetCheckWidth)
+    else
+      Inc(ARect.Left, GetCheckWidth);
+  end;
  inherited;
 end;

--- a/lcl/extctrls.pp
+++ b/lcl/extctrls.pp
@ -1,4 +1,3 @@
-{  $Id$  }
 {
 /***************************************************************************
                               extctrls.pp
@ -639,6 +638,7 @@ type
    constructor Create(TheOwner: TComponent); override;
    destructor Destroy; override;
    function CanModify: boolean; virtual;
+    procedure FlipChildren(AllLevels: Boolean); override;
    function Rows: integer;
  public
    property AutoFill: Boolean read FAutoFill write SetAutoFill;
@ -750,6 +750,7 @@ type
  public
    constructor Create(TheOwner: TComponent); override;
    destructor Destroy; override;
+    procedure FlipChildren(AllLevels: Boolean); override;
    function Rows: integer;
  public
    property AutoFill: boolean read FAutoFill write SetAutoFill;
--- a/lcl/include/customcheckgroup.inc
+++ b/lcl/include/customcheckgroup.inc
@ -341,5 +341,10 @@ begin
    Result:=0;
 end;

+procedure TCustomCheckGroup.FlipChildren(AllLevels: Boolean);
+begin
+  // no flipping
+end;
+
 // included by extctrls.pp

--- a/lcl/include/radiogroup.inc
+++ b/lcl/include/radiogroup.inc
@ -13,7 +13,6 @@
  Delphi compatibility:

   - the interface is almost like in delphi 5
-   - FlipChildren procedure is missing
 }


@ -562,6 +561,11 @@ begin
  UpdateControlsPerLine;
 end;

+procedure TCustomRadioGroup.FlipChildren(AllLevels: Boolean);
+begin
+  // no flipping
+end;
+
 {------------------------------------------------------------------------------
  procedure TCustomRadioGroup.UpdateRadioButtonStates;
  
--- a/lcl/interfaces/win32/win32wschecklst.pp
+++ b/lcl/interfaces/win32/win32wschecklst.pp
@ -1,4 +1,3 @@
-{ $Id$}
 {
 *****************************************************************************
 *                            Win32WSCheckLst.pp                             * 
@ -74,7 +73,10 @@ var
    for I := 0 to Windows.SendMessage(Window, LB_GETCOUNT, 0, 0) - 1 do
    begin
      Windows.SendMessage(Window, LB_GETITEMRECT, I, PtrInt(@ItemRect));
-      ItemRect.Right := ItemRect.Left + ItemRect.Bottom - ItemRect.Top;
+      if TCheckListbox(WindowInfo^.WinControl).UseRightToLeftAlignment then
+        ItemRect.Left := ItemRect.Right - ItemRect.Bottom + ItemRect.Top
+      else
+        ItemRect.Right := ItemRect.Left + ItemRect.Bottom - ItemRect.Top;
      if Windows.PtInRect(ItemRect, MousePos) then
      begin
        // item clicked: toggle
@ -178,6 +180,7 @@ class procedure TWin32WSCustomCheckListBox.DefaultWndHandler(
    Enabled, Selected: Boolean;
    ARect, TextRect: Windows.Rect;
    Details: TThemedElementDetails;
+    TextFlags: DWord;
    OldColor: COLORREF;
    OldBkMode: Integer;
  {$ifdef WindowsUnicodeSupport}
@ -190,7 +193,10 @@ class procedure TWin32WSCustomCheckListBox.DefaultWndHandler(

    ARect := Data^.rcItem;
    TextRect := ARect;
-    TextRect.Left := TextRect.Left + TextRect.Bottom - TextRect.Top + 4;
+    if CheckListBox.UseRightToLeftAlignment then
+      TextRect.Right := TextRect.Right - TextRect.Bottom + TextRect.Top - 4
+    else
+      TextRect.Left := TextRect.Left + TextRect.Bottom - TextRect.Top + 4;

    // fill the background
    if Selected then
@ -202,13 +208,23 @@ class procedure TWin32WSCustomCheckListBox.DefaultWndHandler(
      Windows.FillRect(Data^._HDC, ARect, CheckListBox.Brush.Reference.Handle);

    // draw checkbox
-    ARect.Right := ARect.Left + ARect.Bottom - ARect.Top;
+    if CheckListBox.UseRightToLeftAlignment then
+      ARect.Left := ARect.Right - ARect.Bottom + ARect.Top
+    else
+      ARect.Right := ARect.Left + ARect.Bottom - ARect.Top;

    Details := ThemeServices.GetElementDetails(ThemeStateMap[CheckListBox.State[Data^.ItemID], Enabled]);
    ThemeServices.DrawElement(Data^._HDC, Details, ARect);

    // draw text
-    TextRect.Left := TextRect.Left + 2;
+    if CheckListBox.UseRightToLeftAlignment then begin
+      TextRect.Right := TextRect.Right - 2;
+      TextFlags := DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX or DT_RIGHT;
+    end
+    else begin
+      TextRect.Left := TextRect.Left + 2;
+      TextFlags := DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX;
+    end;
    OldBkMode := Windows.SetBkMode(Data^._HDC, TRANSPARENT);
    if not Enabled then
      OldColor := Windows.SetTextColor(Data^._HDC, Windows.GetSysColor(COLOR_GRAYTEXT))
@ -227,24 +243,27 @@ class procedure TWin32WSCustomCheckListBox.DefaultWndHandler(
    begin
      WideBuffer := UTF8ToUTF16(CheckListBox.Items[Data^.ItemID]);
      Windows.DrawTextW(Data^._HDC, PWideChar(WideBuffer), -1,
-       TextRect, DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);
+       TextRect, TextFlags);
    end
    else
    begin
      AnsiBuffer := Utf8ToAnsi(CheckListBox.Items[Data^.ItemID]);
      Windows.DrawText(Data^._HDC, PChar(AnsiBuffer), -1,
-       TextRect, DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);
+       TextRect, TextFlags);
    end;
  {$else}
    Windows.DrawText(Data^._HDC, PChar(CheckListBox.Items[Data^.ItemID]), -1,
-      TextRect, DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);
+      TextRect, TextFlags);
  {$endif}
    // restore old colors
    Windows.SetTextColor(Data^._HDC, OldColor);
    Windows.SetBkMode(Data^._HDC, OldBkMode);
    if Enabled and ((Data^.itemState and ODS_FOCUS) > 0) and CheckListBox.Focused then
    begin
-      TextRect.Left := TextRect.Left - 2;
+      if CheckListBox.UseRightToLeftAlignment then
+        TextRect.Right := TextRect.Right + 2
+      else
+        TextRect.Left := TextRect.Left - 2;
      Windows.DrawFocusRect(Data^._HDC, TextRect);
    end;
  end;
--- a/test/manual/bidimode_flipchildren/project1.lpi
+++ b/test/manual/bidimode_flipchildren/project1.lpi
@ -0,0 +1,120 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="9"/>
+    <PathDelim Value="\"/>
+    <General>
+      <SessionStorage Value="InProjectDir"/>
+      <MainUnit Value="0"/>
+      <Title Value="project1"/>
+      <ResourceType Value="res"/>
+      <UseXPManifest Value="True"/>
+      <Icon Value="0"/>
+    </General>
+    <i18n>
+      <EnableI18N LFM="False"/>
+    </i18n>
+    <VersionInfo>
+      <StringTable ProductVersion=""/>
+    </VersionInfo>
+    <BuildModes Count="2">
+      <Item1 Name="Debug" Default="True"/>
+      <Item2 Name="Release">
+        <CompilerOptions>
+          <Version Value="11"/>
+          <PathDelim Value="\"/>
+          <SearchPaths>
+            <IncludeFiles Value="$(ProjOutDir)"/>
+          </SearchPaths>
+          <CodeGeneration>
+            <SmartLinkUnit Value="True"/>
+          </CodeGeneration>
+          <Linking>
+            <Debugging>
+              <StripSymbols Value="True"/>
+            </Debugging>
+            <LinkSmart Value="True"/>
+            <Options>
+              <Win32>
+                <GraphicApplication Value="True"/>
+              </Win32>
+            </Options>
+          </Linking>
+          <Other>
+            <CompilerMessages>
+              <UseMsgFile Value="True"/>
+            </CompilerMessages>
+            <CompilerPath Value="$(CompPath)"/>
+          </Other>
+        </CompilerOptions>
+      </Item2>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+    </PublishOptions>
+    <RunParams>
+      <local>
+        <FormatVersion Value="1"/>
+      </local>
+    </RunParams>
+    <RequiredPackages Count="1">
+      <Item1>
+        <PackageName Value="LCL"/>
+      </Item1>
+    </RequiredPackages>
+    <Units Count="2">
+      <Unit0>
+        <Filename Value="project1.lpr"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="project1"/>
+      </Unit0>
+      <Unit1>
+        <Filename Value="unit1.pas"/>
+        <IsPartOfProject Value="True"/>
+        <ComponentName Value="Form1"/>
+        <HasResources Value="True"/>
+        <ResourceBaseClass Value="Form"/>
+        <UnitName Value="Unit1"/>
+      </Unit1>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <PathDelim Value="\"/>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+    </SearchPaths>
+    <CodeGeneration>
+      <SmartLinkUnit Value="True"/>
+    </CodeGeneration>
+    <Linking>
+      <Debugging>
+        <DebugInfoType Value="dsDwarf2Set"/>
+      </Debugging>
+      <Options>
+        <Win32>
+          <GraphicApplication Value="True"/>
+        </Win32>
+      </Options>
+    </Linking>
+    <Other>
+      <CompilerMessages>
+        <UseMsgFile Value="True"/>
+      </CompilerMessages>
+      <CompilerPath Value="$(CompPath)"/>
+    </Other>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions Count="3">
+      <Item1>
+        <Name Value="EAbort"/>
+      </Item1>
+      <Item2>
+        <Name Value="ECodetoolError"/>
+      </Item2>
+      <Item3>
+        <Name Value="EFOpenError"/>
+      </Item3>
+    </Exceptions>
+  </Debugging>
+</CONFIG>
--- a/test/manual/bidimode_flipchildren/project1.lpr
+++ b/test/manual/bidimode_flipchildren/project1.lpr
@ -0,0 +1,21 @@
+program project1;
+
+{$mode objfpc}{$H+}
+
+uses
+  {$IFDEF UNIX}{$IFDEF UseCThreads}
+  cthreads,
+  {$ENDIF}{$ENDIF}
+  Interfaces, // this includes the LCL widgetset
+  Forms, Unit1
+  { you can add units after this };
+
+{$R *.res}
+
+begin
+  RequireDerivedFormResource := True;
+  Application.Initialize;
+  Application.CreateForm(TForm1, Form1);
+  Application.Run;
+end.
+
--- a/test/manual/bidimode_flipchildren/unit1.lfm
+++ b/test/manual/bidimode_flipchildren/unit1.lfm
@ -0,0 +1,119 @@
+object Form1: TForm1
+  Left = 338
+  Height = 207
+  Top = 153
+  Width = 373
+  Caption = 'Form1'
+  ClientHeight = 207
+  ClientWidth = 373
+  LCLVersion = '1.3'
+  object Button1: TButton
+    Left = 20
+    Height = 25
+    Top = 16
+    Width = 75
+    Caption = 'BiDiMode'
+    OnClick = Button1Click
+    TabOrder = 0
+  end
+  object RadioGroup1: TRadioGroup
+    Left = 24
+    Height = 105
+    Top = 57
+    Width = 113
+    AutoFill = True
+    Caption = 'RadioGroup1'
+    ChildSizing.LeftRightSpacing = 6
+    ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
+    ChildSizing.EnlargeVertical = crsHomogenousChildResize
+    ChildSizing.ShrinkHorizontal = crsScaleChilds
+    ChildSizing.ShrinkVertical = crsScaleChilds
+    ChildSizing.Layout = cclLeftToRightThenTopToBottom
+    ChildSizing.ControlsPerLine = 1
+    ClientHeight = 87
+    ClientWidth = 109
+    Items.Strings = (
+      'one'
+      'two'
+      'three'
+      'four'
+    )
+    TabOrder = 1
+  end
+  object Button2: TButton
+    Left = 120
+    Height = 25
+    Top = 16
+    Width = 115
+    Caption = 'Flip children'
+    OnClick = Button2Click
+    TabOrder = 2
+  end
+  object CheckGroup1: TCheckGroup
+    Left = 144
+    Height = 105
+    Top = 57
+    Width = 99
+    AutoFill = True
+    Caption = 'CheckGroup1'
+    ChildSizing.LeftRightSpacing = 6
+    ChildSizing.TopBottomSpacing = 6
+    ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
+    ChildSizing.EnlargeVertical = crsHomogenousChildResize
+    ChildSizing.ShrinkHorizontal = crsScaleChilds
+    ChildSizing.ShrinkVertical = crsScaleChilds
+    ChildSizing.Layout = cclLeftToRightThenTopToBottom
+    ChildSizing.ControlsPerLine = 1
+    ClientHeight = 87
+    ClientWidth = 95
+    Items.Strings = (
+      'one'
+      'two'
+      'three'
+      'four'
+    )
+    TabOrder = 3
+    Data = {
+      0400000002020202
+    }
+  end
+  object CheckListBox1: TCheckListBox
+    Left = 264
+    Height = 78
+    Top = 120
+    Width = 100
+    Items.Strings = (
+      'one'
+      'two'
+      'three'
+      'four'
+    )
+    ItemHeight = 17
+    TabOrder = 4
+    Data = {
+      0400000000000000
+    }
+  end
+  object Label1: TLabel
+    Left = 29
+    Height = 15
+    Top = 180
+    Width = 39
+    Caption = 'Lazarus'
+    ParentColor = False
+  end
+  object ListBox1: TListBox
+    Left = 264
+    Height = 80
+    Top = 18
+    Width = 100
+    Items.Strings = (
+      'one'
+      'two'
+      'three'
+      'four'
+    )
+    ItemHeight = 15
+    TabOrder = 5
+  end
+end
--- a/test/manual/bidimode_flipchildren/unit1.pas
+++ b/test/manual/bidimode_flipchildren/unit1.pas
@ -0,0 +1,54 @@
+unit Unit1;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
+  ExtCtrls, CheckLst;
+
+type
+
+  { TForm1 }
+
+  TForm1 = class(TForm)
+    Button1: TButton;
+    Button2: TButton;
+    CheckGroup1: TCheckGroup;
+    CheckListBox1: TCheckListBox;
+    Label1: TLabel;
+    ListBox1: TListBox;
+    RadioGroup1: TRadioGroup;
+    procedure Button1Click(Sender: TObject);
+    procedure Button2Click(Sender: TObject);
+  private
+    { private declarations }
+  public
+    { public declarations }
+  end;
+
+var
+  Form1: TForm1;
+
+implementation
+
+{$R *.lfm}
+
+{ TForm1 }
+
+procedure TForm1.Button1Click(Sender: TObject);
+begin
+  if Application.BiDiMode = bdLeftToRight then
+    Application.BiDiMode := bdRightToLeft
+  else
+    Application.BiDiMode := bdLeftToRight;
+end;
+
+procedure TForm1.Button2Click(Sender: TObject);
+begin
+  FlipChildren(true);
+end;
+
+end.
+