Changeset 201


Ignore:
Timestamp:
Jan 28, 2026, 9:57:27 PM (3 hours ago)
Author:
chronos
Message:
  • Modified: Updated Common package.
Location:
trunk
Files:
11 added
29 edited

Legend:

Unmodified
Added
Removed

  • trunk/Core.lfm

    r181 r201  
    312312      Caption = 'New'
    313313      ImageIndex = 4
     314      ShortCut = 16462
    314315      OnExecute = AFileNewExecute
    315       ShortCut = 16462
    316316    end
    317317    object AFileOpen: TAction
    … …  
    319319      Caption = 'Open...'
    320320      ImageIndex = 5
     321      ShortCut = 16463
    321322      OnExecute = AFileOpenExecute
    322       ShortCut = 16463
    323323    end
    324324    object AFileOpenRecent: TAction
    … …  
    331331      Caption = 'Save'
    332332      ImageIndex = 7
     333      ShortCut = 16467
    333334      OnExecute = AFileSaveExecute
    334       ShortCut = 16467
    335335    end
    336336    object AFileSaveAs: TAction
    … …  
    338338      Caption = 'Save as...'
    339339      ImageIndex = 7
     340      ShortCut = 24659
    340341      OnExecute = AFileSaveAsExecute
    341       ShortCut = 24659
    342342    end
    343343    object AFileClose: TAction
    … …  
    361361      Caption = 'Settings'
    362362      ImageIndex = 8
     363      ShortCut = 121
    363364      OnExecute = ASettingsExecute
    364       ShortCut = 121
    365365    end
    366366    object AFileCombine: TAction
    … …  
    377377      Caption = 'Generate contacts'
    378378      ImageIndex = 20
     379      ShortCut = 116
    379380      OnExecute = AGenerateExecute
    380       ShortCut = 116
    381381    end
    382382    object AFileSplit: TAction
    … …  
    388388      Caption = 'Find...'
    389389      ImageIndex = 14
     390      ShortCut = 16454
    390391      OnExecute = AFindExecute
    391       ShortCut = 16454
    392392    end
    393393    object ATest: TAction
    394394      Caption = 'Test'
     395      ShortCut = 115
    395396      OnExecute = ATestExecute
    396       ShortCut = 115
    397397    end
    398398    object AViewSource: TAction
    399399      Caption = 'View source'
    400400      ImageIndex = 21
     401      ShortCut = 114
    401402      OnExecute = AViewSourceExecute
    402       ShortCut = 114
    403403    end
    404404    object AFileCompare: TAction
    … …  
    433433      Caption = 'Full screen'
    434434      ImageIndex = 24
     435      ShortCut = 122
    435436      OnExecute = AFullScreenExecute
    436       ShortCut = 122
    437437    end
    438438    object AKeyShortcuts: TAction

  • trunk/Core.pas

    r194 r201  
    339339  if not Assigned(FormKeyShortcuts) then
    340340    FormKeyShortcuts := TFormKeyShortcuts.Create(nil);
    341   FormKeyShortcuts.ImageList := ImageList1;
     341  FormKeyShortcuts.Images := ImageList1;
    342342  FormKeyShortcuts.MainForm := FormMain;
    343343  FormKeyShortcuts.SourceComponents.Clear;

  • trunk/Languages/vCardStudio.cs.po

    r177 r201  
    751751#: tformcontact.labelorganization10.caption
    752752msgid "Reddit:"
    753 msgstr "Raddit:"
     753msgstr "Reddit:"
    754754
    755755#: tformcontact.labelorganization11.caption

  • trunk/Packages/Common/Common.lpk

    r177 r201  
    4343    <License Value="Copy left."/>
    4444    <Version Minor="12"/>
    45     <Files Count="37">
     45    <Files Count="40">
    4646      <Item1>
    4747        <Filename Value="StopWatch.pas"/>
    … …  
    205205        <UnitName Value="FormKeyShortcuts"/>
    206206      </Item37>
     207      <Item38>
     208        <Filename Value="ItemList.pas"/>
     209        <UnitName Value="ItemList"/>
     210      </Item38>
     211      <Item39>
     212        <Filename Value="Forms\FormItem.pas"/>
     213        <UnitName Value="FormItem"/>
     214      </Item39>
     215      <Item40>
     216        <Filename Value="Forms\FormList.pas"/>
     217        <UnitName Value="FormList"/>
     218      </Item40>
    207219    </Files>
    208220    <CompatibilityMode Value="True"/>

  • trunk/Packages/Common/CommonPackage.pas

    r177 r201  
    1414  ScaleDPI, Theme, StringTable, MetaCanvas, Geometric, Translator, Languages,
    1515  PixelPointer, DataFile, TestCase, Generics, Table, FormEx, FormTests,
    16   FormTest, FormAbout, FormKeyShortcuts, LazarusPackageIntf;
     16  FormTest, FormAbout, FormKeyShortcuts, ItemList, FormItem, FormList,
     17  LazarusPackageIntf;
    1718
    1819implementation

  • trunk/Packages/Common/FormEx.pas

    r177 r201  
    5050    PersistentForm.Load(Self);
    5151    FullScreen := PersistentForm.FormFullScreen;
     52    ThemeManager.UseTheme(Self);
    5253  end;
    5354end;
    … …  
    7576
    7677  Translator.TranslateComponentRecursive(Self);
    77   ThemeManager.UseTheme(Self);
    7878  Inc(FCounter);
    7979  inherited;

  • trunk/Packages/Common/Forms/FormAbout.lfm

    r162 r201  
    11object FormAbout: TFormAbout
    22  Left = 624
    3   Height = 402
     3  Height = 397
    44  Top = 622
    5   Width = 702
     5  Width = 714
    66  Caption = 'About'
    7   ClientHeight = 402
    8   ClientWidth = 702
     7  ClientHeight = 397
     8  ClientWidth = 714
    99  DesignTimePPI = 144
    1010  OnShow = FormShow
    1111  Position = poScreenCenter
    12   LCLVersion = '2.2.6.0'
     12  LCLVersion = '3.6.0.0'
    1313  object LabelDescription: TLabel
    1414    Left = 30
    1515    Height = 26
    1616    Top = 135
    17     Width = 642
     17    Width = 654
    1818    Align = alTop
    1919    BorderSpacing.Left = 30
    … …  
    2929    Height = 26
    3030    Top = 191
    31     Width = 642
     31    Width = 654
    3232    Align = alTop
    3333    BorderSpacing.Around = 30
    … …  
    4040    Height = 135
    4141    Top = 0
    42     Width = 702
     42    Width = 714
    4343    Align = alTop
    4444    BevelOuter = bvNone
    4545    ClientHeight = 135
    46     ClientWidth = 702
     46    ClientWidth = 714
    4747    FullRepaint = False
    4848    ParentFont = False
    … …  
    5252      Height = 84
    5353      Top = 20
    54       Width = 564
     54      Width = 576
    5555      Anchors = [akTop, akLeft, akRight]
    5656      AutoSize = False
    … …  
    7474    Left = 0
    7575    Height = 75
    76     Top = 327
    77     Width = 702
     76    Top = 322
     77    Width = 714
    7878    Align = alBottom
    7979    BevelOuter = bvNone
    8080    ClientHeight = 75
    81     ClientWidth = 702
     81    ClientWidth = 714
    8282    TabOrder = 1
    8383    object ButtonHomePage: TButton
    … …  
    8888      Anchors = [akLeft, akBottom]
    8989      Caption = 'Home page'
    90       OnClick = ButtonHomePageClick
    9190      ParentFont = False
    9291      TabOrder = 0
     92      OnClick = ButtonHomePageClick
    9393    end
    9494    object ButtonClose: TButton
    95       Left = 531
     95      Left = 543
    9696      Height = 38
    9797      Top = 24

  • trunk/Packages/Common/Forms/FormAbout.pas

    r162 r201  
    3838  SReleaseDate = 'Release date';
    3939  SLicense = 'License';
     40  // TODO: https://gitlab.com/freepascal.org/lazarus/lazarus/-/issues/41095
     41  {$hints off}
     42  SHomePage = 'Home page';
     43  SClose = 'Close';
    4044
    4145{ TFormAbout }

  • trunk/Packages/Common/Forms/FormKeyShortcuts.lfm

    r178 r201  
    1111  OnDestroy = FormDestroy
    1212  OnShow = FormShow
    13   LCLVersion = '3.4.0.0'
     13  LCLVersion = '3.6.0.0'
    1414  object ListView1: TListView
    15     Left = 5
    16     Height = 319
    17     Top = 5
    18     Width = 694
    19     Align = alClient
    20     BorderSpacing.Around = 5
     15    Left = 10
     16    Height = 262
     17    Top = 10
     18    Width = 684
     19    Align = alTop
     20    Anchors = [akTop, akLeft, akRight, akBottom]
     21    BorderSpacing.Around = 10
    2122    Columns = <   
    2223      item
    … …  
    4243    OnKeyPress = ListView1KeyPress
    4344  end
     45  object ButtonClose: TButton
     46    Left = 581
     47    Height = 37
     48    Top = 284
     49    Width = 113
     50    Anchors = [akRight, akBottom]
     51    Caption = 'Close'
     52    ModalResult = 11
     53    TabOrder = 1
     54    OnClick = ButtonCloseClick
     55  end
    4456  object PopupMenu1: TPopupMenu
    4557    Left = 408
    … …  
    5567    Column = 0
    5668    Order = soNone
    57     Left = 200
    58     Top = 160
     69    Left = 221
     70    Top = 144
    5971  end
    6072end

  • trunk/Packages/Common/Forms/FormKeyShortcuts.lrj

    r177 r201  
    44{"hash":98585447,"name":"tformkeyshortcuts.listview1.columns[1].caption","sourcebytes":[87,105,110,100,111,119],"value":"Window"},
    55{"hash":258584404,"name":"tformkeyshortcuts.listview1.columns[2].caption","sourcebytes":[83,104,111,114,116,99,117,116],"value":"Shortcut"},
     6{"hash":4863637,"name":"tformkeyshortcuts.buttonclose.caption","sourcebytes":[67,108,111,115,101],"value":"Close"},
    67{"hash":216771813,"name":"tformkeyshortcuts.menuitem1.caption","sourcebytes":[69,120,101,99,117,116,101],"value":"Execute"}
    78]}

  • trunk/Packages/Common/Forms/FormKeyShortcuts.pas

    r178 r201  
    1313
    1414  TFormKeyShortcuts = class(TFormEx)
     15    ButtonClose: TButton;
    1516    ListView1: TListView;
    1617    ListViewSort1: TListViewSort;
    1718    MenuItem1: TMenuItem;
    1819    PopupMenu1: TPopupMenu;
     20    procedure ButtonCloseClick(Sender: TObject);
    1921    procedure FormCreate(Sender: TObject);
    2022    procedure FormDestroy(Sender: TObject);
    … …  
    2527    procedure MenuItem1Click(Sender: TObject);
    2628  private
    27     function GetImageList: TCustomImageList;
    28     procedure SetImageList(AValue: TCustomImageList);
     29    function GetImages: TCustomImageList;
     30    procedure SetImages(AValue: TCustomImageList);
    2931  public
    3032    SourceComponents: TObjectList<TComponent>;
    3133    MainForm: TForm;
    3234    procedure LoadFromComponent(C: TComponent);
    33     property ImageList: TCustomImageList read GetImageList write SetImageList;
     35    property Images: TCustomImageList read GetImages write SetImages;
    3436  end;
    3537
    … …  
    4951  SShortcut = 'Shortcut';
    5052  SKeyShortcuts = 'Key shortcuts';
     53  SClose = 'Close';
    5154
    5255{ TFormKeyShortcuts }
    … …  
    105108end;
    106109
     110procedure TFormKeyShortcuts.ButtonCloseClick(Sender: TObject);
     111begin
     112  Close;
     113end;
     114
    107115procedure TFormKeyShortcuts.FormDestroy(Sender: TObject);
    108116begin
    … …  
    116124end;
    117125
    118 function TFormKeyShortcuts.GetImageList: TCustomImageList;
     126function TFormKeyShortcuts.GetImages: TCustomImageList;
    119127begin
    120128  Result := ListView1.SmallImages;
    121129end;
    122130
    123 procedure TFormKeyShortcuts.SetImageList(AValue: TCustomImageList);
     131procedure TFormKeyShortcuts.SetImages(AValue: TCustomImageList);
    124132begin
    125133  ListView1.SmallImages := AValue;

  • trunk/Packages/Common/Forms/FormTest.lfm

    r162 r201  
    88  ClientWidth = 865
    99  DesignTimePPI = 144
    10   LCLVersion = '2.2.6.0'
     10  OnShow = FormShow
     11  LCLVersion = '3.6.0.0'
    1112  object MemoLog: TMemo
    1213    Left = 8
    13     Height = 505
     14    Height = 464
    1415    Top = 8
    1516    Width = 849
    16     Align = alClient
     17    Align = alTop
     18    Anchors = [akTop, akLeft, akRight, akBottom]
    1719    BorderSpacing.Around = 8
    1820    ReadOnly = True
    … …  
    2022    TabOrder = 0
    2123  end
     24  object ButtonRun: TButton
     25    Left = 616
     26    Height = 37
     27    Top = 480
     28    Width = 112
     29    Anchors = [akRight, akBottom]
     30    Caption = 'Run'
     31    TabOrder = 1
     32    OnClick = ButtonRunClick
     33  end
     34  object ButtonClose: TButton
     35    Left = 745
     36    Height = 37
     37    Top = 480
     38    Width = 112
     39    Anchors = [akRight, akBottom]
     40    Caption = 'Close'
     41    ModalResult = 11
     42    TabOrder = 2
     43    OnClick = ButtonRunClick
     44  end
    2245end

  • trunk/Packages/Common/Forms/FormTest.lrj

    r162 r201  
    11{"version":1,"strings":[
    2 {"hash":371876,"name":"tformtest.caption","sourcebytes":[84,101,115,116],"value":"Test"}
     2{"hash":371876,"name":"tformtest.caption","sourcebytes":[84,101,115,116],"value":"Test"},
     3{"hash":22974,"name":"tformtest.buttonrun.caption","sourcebytes":[82,117,110],"value":"Run"},
     4{"hash":4863637,"name":"tformtest.buttonclose.caption","sourcebytes":[67,108,111,115,101],"value":"Close"}
    35]}

  • trunk/Packages/Common/Forms/FormTest.pas

    r162 r201  
    44
    55uses
    6   Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, FormEx;
     6  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, FormEx,
     7  TestCase;
    78
    89type
    … …  
    1112
    1213  TFormTest = class(TFormEx)
     14    ButtonRun: TButton;
     15    ButtonClose: TButton;
    1316    MemoLog: TMemo;
     17    procedure FormShow(Sender: TObject);
     18    procedure ButtonRunClick(Sender: TObject);
     19  private
     20    FTestCase: TTestCase;
     21    procedure SetTestCase(AValue: TTestCase);
     22  public
     23    property TestCase: TTestCase read FTestCase write SetTestCase;
    1424  end;
    1525
    … …  
    1929{$R *.lfm}
    2030
     31{ TFormTest }
     32
     33procedure TFormTest.FormShow(Sender: TObject);
     34begin
     35  if Assigned(FTestCase) then MemoLog.Text := FTestCase.Log;
     36end;
     37
     38procedure TFormTest.SetTestCase(AValue: TTestCase);
     39begin
     40  if FTestCase = AValue then Exit;
     41  FTestCase := AValue;
     42end;
     43
     44procedure TFormTest.ButtonRunClick(Sender: TObject);
     45begin
     46  if Assigned(FTestCase) then begin
     47    FTestCase.Run;
     48    MemoLog.Text := FTestCase.Log;
     49  end;
     50end;
     51
    2152end.
    2253

  • trunk/Packages/Common/Forms/FormTests.lfm

    r162 r201  
    99  DesignTimePPI = 144
    1010  OnShow = FormShow
    11   LCLVersion = '2.2.6.0'
     11  LCLVersion = '3.6.0.0'
    1212  object ListViewTestCases: TListView
    1313    Left = 19
    … …  
    3636  end
    3737  object ButtonRun: TButton
    38     Left = 945
     38    Left = 816
    3939    Height = 37
    4040    Top = 585
    … …  
    4242    Anchors = [akRight, akBottom]
    4343    Caption = 'Run'
     44    TabOrder = 1
    4445    OnClick = ButtonRunClick
    45     TabOrder = 1
    4646  end
    4747  object LabelResult: TLabel
    … …  
    5353    Caption = '   '
    5454    ParentColor = False
     55  end
     56  object ButtonClose: TButton
     57    Left = 945
     58    Height = 37
     59    Top = 585
     60    Width = 112
     61    Anchors = [akRight, akBottom]
     62    Caption = 'Close'
     63    ModalResult = 11
     64    TabOrder = 2
     65    OnClick = ButtonRunClick
    5566  end
    5667  object ActionList1: TActionList

  • trunk/Packages/Common/Forms/FormTests.lrj

    r162 r201  
    55{"hash":22974,"name":"tformtests.buttonrun.caption","sourcebytes":[82,117,110],"value":"Run"},
    66{"hash":8736,"name":"tformtests.labelresult.caption","sourcebytes":[32,32,32],"value":"   "},
     7{"hash":4863637,"name":"tformtests.buttonclose.caption","sourcebytes":[67,108,111,115,101],"value":"Close"},
    78{"hash":368487,"name":"tformtests.ashow.caption","sourcebytes":[83,104,111,119],"value":"Show"},
    89{"hash":22974,"name":"tformtests.arun.caption","sourcebytes":[82,117,110],"value":"Run"}

  • trunk/Packages/Common/Forms/FormTests.pas

    r162 r201  
    1616    ActionList1: TActionList;
    1717    ButtonRun: TButton;
     18    ButtonClose: TButton;
    1819    LabelResult: TLabel;
    1920    ListViewTestCases: TListView;
    … …  
    119120  with TFormTest.Create(nil) do
    120121  try
    121     MemoLog.Text := TTestCase(ListViewTestCases.Selected.Data).Log;
     122    TestCase := TTestCase(ListViewTestCases.Selected.Data);
    122123    ShowModal;
     124    ReloadList;
    123125  finally
    124126    Free;

  • trunk/Packages/Common/Languages/Common.cs.po

    r177 r201  
    1616msgid "Excution error: %s (exit code: %d)"
    1717msgstr "Chyba vykonání: %s (návratový kód: %d)"
     18

  • trunk/Packages/Common/Languages/FormAbout.cs.po

    r173 r201  
    1010"Content-Type: text/plain; charset=UTF-8\n"
    1111"Content-Transfer-Encoding: 8bit\n"
    12 "X-Generator: Poedit 3.0.1\n"
     12"X-Generator: Poedit 3.4.2\n"
     13
     14#: formabout.sclose
     15msgid "Close"
     16msgstr "Zavřít"
     17
     18#: formabout.shomepage
     19msgid "Home page"
     20msgstr "Domovská stránka"
    1321
    1422#: formabout.slicense

  • trunk/Packages/Common/Languages/FormAbout.pot

    r173 r201  
    11msgid ""
    22msgstr "Content-Type: text/plain; charset=UTF-8"
     3
     4#: formabout.sclose
     5msgid "Close"
     6msgstr ""
     7
     8#: formabout.shomepage
     9msgid "Home page"
     10msgstr ""
    311
    412#: formabout.slicense

  • trunk/Packages/Common/Languages/FormKeyShortcuts.cs.po

    r178 r201  
    1010"Content-Type: text/plain; charset=UTF-8\n"
    1111"Content-Transfer-Encoding: 8bit\n"
    12 "X-Generator: Poedit 3.4.2\n"
     12"X-Generator: Poedit 3.5\n"
    1313
    1414#: formkeyshortcuts.saction
    1515msgid "Action"
    1616msgstr "Akce"
     17
     18#: formkeyshortcuts.sclose
     19msgid "Close"
     20msgstr "Zavřít"
    1721
    1822#: formkeyshortcuts.sexecute

  • trunk/Packages/Common/Languages/FormKeyShortcuts.pot

    r178 r201  
    44#: formkeyshortcuts.saction
    55msgid "Action"
     6msgstr ""
     7
     8#: formkeyshortcuts.sclose
     9msgid "Close"
    610msgstr ""
    711

  • trunk/Packages/Common/Languages/PixelPointer.cs.po

    r172 r201  
    2121msgid "Wrong bitmap size [width: %d, height: %d]"
    2222msgstr "Špatná velikost bitové mapy [šířka: %d, výška: %d]"
     23

  • trunk/Packages/Common/Languages/Table.cs.po

    r172 r201  
    1515msgid "Unsupported format"
    1616msgstr "Nepodporovaný formát"
     17

  • trunk/Packages/Common/MetaCanvas.pas

    r148 r201  
    150150    procedure SetWidth(AValue: Integer); override;
    151151    function GetWidth: Integer; override;
    152     procedure DoLine (x1,y1,x2,y2:integer); override;
     152    procedure DoLine(X1, Y1, X2, Y2: Integer); override;
    153153    procedure DoTextOut(X, Y: Integer; Text: string); override;
    154154    procedure DoRectangle(const Bounds: TRect); override;
    … …  
    563563end;
    564564
    565 procedure TMetaCanvas.DoLine(x1, y1, x2, y2: integer);
     565procedure TMetaCanvas.DoLine(X1, Y1, X2, Y2: integer);
    566566var
    567567  NewObj: TCanvasLine;

  • trunk/Packages/Common/RegistryEx.pas

    r172 r201  
    3636    function ReadFloatWithDefault(const Name: string;
    3737      DefaultValue: Double): Double;
     38    function ReadDateTimeWithDefault(const Name: string; DefaultValue: TDateTime): TDateTime;
    3839    function DeleteKeyRecursive(const Key: string): Boolean;
    3940    function OpenKey(const Key: string; CanCreate: Boolean): Boolean;
    … …  
    110111end;
    111112
     113function TRegistryEx.ReadDateTimeWithDefault(const Name: string;
     114  DefaultValue: TDateTime): TDateTime;
     115begin
     116  if ValueExists(Name) then Result := ReadDateTime(Name)
     117    else begin
     118      WriteDateTime(Name, DefaultValue);
     119      Result := DefaultValue;
     120    end;
     121end;
     122
    112123function TRegistryEx.DeleteKeyRecursive(const Key: string): Boolean;
    113124var

  • trunk/Packages/Common/Theme.pas

    r148 r201  
    55uses
    66  Classes, SysUtils, Graphics, ComCtrls, Controls, ExtCtrls, Menus, StdCtrls,
    7   Spin, Forms, Generics.Collections, Grids;
     7  Spin, Forms, Generics.Collections, Grids, Registry, LCLType;
    88
    99type
    … …  
    2525  end;
    2626
     27  TDwmSetWindowAttribute = function(hwnd: HWND; dwAttribute: DWORD; pvAttribute: Pointer; cbAttribute: DWORD): HRESULT; stdcall;
     28
    2729  { TThemeManager }
    2830
    … …  
    3032  private
    3133    FTheme: TTheme;
     34    FActualTheme: TTheme;
     35    DwmapiLib: TLibHandle;
     36    DwmSetWindowAttribute: TDwmSetWindowAttribute;
     37    function Gray(C: TColor): Byte;
    3238    procedure SetTheme(AValue: TTheme);
    33     procedure SetThemeName(AValue: TTheme);
     39    procedure SetThemeName(Name: string);
     40    procedure SetThemedTitleBar(AForm: TForm; Active: Bool);
     41    function IsWindows10OrGreater(BuildNumber: Integer): Boolean;
    3442  public
    3543    Used: Boolean;
    3644    Themes: TThemes;
     45    function IsDarkTheme: Boolean;
    3746    procedure ApplyTheme(Component: TComponent);
    3847    constructor Create(AOwner: TComponent); override;
    … …  
    4049    procedure UseTheme(Form: TForm);
    4150    property Theme: TTheme read FTheme write SetTheme;
     51    property ActualTheme: TTheme read FActualTheme;
    4252  end;
    4353
    … …  
    4656  ThemeNameLight = 'Light';
    4757  ThemeNameDark = 'Dark';
     58  DwmapiLibName = 'dwmapi.dll';
     59  DWMWA_USE_IMMERSIVE_DARK_MODE_BEFORE_20H1 = 19;
     60  DWMWA_USE_IMMERSIVE_DARK_MODE = 20;
    4861
    4962procedure Register;
    … …  
    95108end;
    96109
    97 procedure TThemeManager.SetThemeName(AValue: TTheme);
     110{ TThemeManager }
     111
     112function TThemeManager.Gray(C: TColor): Byte;
     113begin
     114  Result := Trunc(Red(C) * 0.3 + Green(C) * 0.59 + Blue(C) * 0.11);
     115end;
     116
     117function TThemeManager.IsDarkTheme: Boolean;
     118{$IFDEF WINDOWS}
     119var
     120  LightKey: Boolean;
     121  Registry: TRegistry;
     122const
     123  KeyPath = '\Software\Microsoft\Windows\CurrentVersion\Themes\Personalize';
     124  KeyName = 'AppsUseLightTheme';
     125{$ELSE}
     126var
     127  ColorWindow: TColor;
     128  ColorWindowText: TColor;
     129{$ENDIF}
     130begin
     131  Result := False;
     132  {$IFDEF WINDOWS}
     133  Registry := TRegistry.Create;
     134  try
     135    Registry.RootKey := HKEY_CURRENT_USER;
     136    if Registry.OpenKeyReadOnly(KeyPath) then begin
     137      if Registry.ValueExists(KeyName) then
     138        LightKey := Registry.ReadBool(KeyName)
     139      else LightKey := True;
     140    end else LightKey := True;
     141    Result := not LightKey;
     142  finally
     143    Registry.Free;
     144  end;
     145  {$ELSE}
     146  ColorWindow := ColorToRGB(clWindow);
     147  ColorWindowText := ColorToRGB(clWindowText);
     148  Result := Gray(ColorWindow) < Gray(ColorWindowText);
     149  {$ENDIF}
     150end;
     151
     152procedure TThemeManager.SetThemeName(Name: string);
     153begin
     154  Theme := Themes.FindByName(Name);
     155end;
     156
     157function TThemeManager.IsWindows10OrGreater(BuildNumber: Integer): Boolean;
     158begin
     159  {$IFDEF WINDOWS}
     160  Result := (Win32MajorVersion >= 10) and (Win32BuildNumber >= BuildNumber);
     161  {$ELSE}
     162  Result := False;
     163  {$ENDIF}
     164end;
     165
     166procedure TThemeManager.SetThemedTitleBar(AForm: TForm; Active: Bool);
     167var
     168  Attr: DWord;
     169begin
     170  if Assigned(DwmSetWindowAttribute) and IsWindows10OrGreater(17763) then begin
     171    Attr := DWMWA_USE_IMMERSIVE_DARK_MODE_BEFORE_20H1;
     172    if IsWindows10OrGreater(18985) then Attr := DWMWA_USE_IMMERSIVE_DARK_MODE;
     173
     174    DwmSetWindowAttribute(AForm.Handle, Attr, @Active, SizeOf(Active));
     175  end;
     176end;
     177
     178procedure TThemeManager.SetTheme(AValue: TTheme);
    98179begin
    99180  if FTheme = AValue then Exit;
    100181  FTheme := AValue;
    101 end;
    102 
    103 procedure TThemeManager.SetTheme(AValue: TTheme);
    104 begin
    105   if FTheme = AValue then Exit;
    106   FTheme := AValue;
     182  FActualTheme := FTheme;
     183  {$IFDEF WINDOWS}
     184  if Assigned(FTheme) and (FTheme = Themes.FindByName(ThemeNameSystem)) and IsDarkTheme then
     185    FActualTheme := Themes.FindByName(ThemeNameDark);
     186  {$ENDIF}
    107187end;
    108188
    … …  
    110190begin
    111191  inherited;
     192  {$IFDEF WINDOWS}
     193  DwmapiLib := LoadLibrary(DwmapiLibName);
     194  if DwmapiLib <> 0 then DwmSetWindowAttribute := GetProcAddress(DwmapiLib, 'DwmSetWindowAttribute')
     195    else DwmSetWindowAttribute := nil;
     196  {$ENDIF}
     197
    112198  Themes := TThemes.Create;
    113199  with Themes.AddNew(ThemeNameSystem) do begin
    … …  
    118204    ColorControlSelected := clWindow;
    119205  end;
    120   Theme := TTheme(Themes.First);
    121206  with Themes.AddNew(ThemeNameDark) do begin
    122207    ColorWindow := RGBToColor($20, $20, $20);
    … …  
    133218    ColorControlSelected := RGBToColor(196, 225, 255);
    134219  end;
     220  Theme := TTheme(Themes.First);
    135221end;
    136222
    … …  
    138224begin
    139225  FreeAndNil(Themes);
     226  {$IFDEF WINDOWS}
     227  if DwmapiLib <> 0 then FreeLibrary(DwmapiLib);
     228  {$ENDIF}
    140229  inherited;
    141230end;
    … …  
    156245    (Control is TMemo) or (Control is TListView) or (Control is TCustomDrawGrid) or
    157246    (Control is TCheckBox) or (Control is TPageControl) or (Control is TRadioButton) then begin
    158       Control.Color := FTheme.ColorWindow;
    159       Control.Font.Color := FTheme.ColorWindowText;
     247      Control.Color := FActualTheme.ColorWindow;
     248      Control.Font.Color := FActualTheme.ColorWindowText;
    160249    end else begin
    161       Control.Color := FTheme.ColorControl;
    162       Control.Font.Color := FTheme.ColorControlText;
     250      Control.Color := FActualTheme.ColorControl;
     251      Control.Font.Color := FActualTheme.ColorControlText;
    163252    end;
    164253
    165254    if Control is TCustomDrawGrid then begin
    166       (Control as TCustomDrawGrid).Editor.Color := FTheme.ColorWindow;
    167       (Control as TCustomDrawGrid).Editor.Font.Color := FTheme.ColorWindowText;
     255      (Control as TCustomDrawGrid).Editor.Color := FActualTheme.ColorWindow;
     256      (Control as TCustomDrawGrid).Editor.Font.Color := FActualTheme.ColorWindowText;
    168257    end;
    169258
    … …  
    181270procedure TThemeManager.UseTheme(Form: TForm);
    182271begin
    183   if not Used and (FTheme.Name = ThemeNameSystem) then Exit;
     272  if not Used and (FActualTheme.Name = ThemeNameSystem) then Exit;
    184273  ApplyTheme(Form);
     274  SetThemedTitleBar(Form, FActualTheme.Name = ThemeNameDark);
    185275  Used := True;
    186276end;

  • trunk/Packages/Common/Threading.pas

    r172 r201  
    291291    ThreadListLock.Release;
    292292  end;
    293   FThread.Free;
     293  FreeAndNil(FThread);
    294294  inherited;
    295295end;
    … …  
    362362finalization
    363363
    364 ThreadList.Free;
    365 ThreadListLock.Free;
     364FreeAndNil(ThreadList);
     365FreeAndNil(ThreadListLock);
    366366
    367367end.

  • trunk/Packages/Common/Translator.pas

    r162 r201  
    322322    Result[I] := StringReplace(Result[I], '/', DirectorySeparator, [rfReplaceAll]);
    323323    Result[I] := StringReplace(Result[I], '\', DirectorySeparator, [rfReplaceAll]);
    324     if Copy(Result[I], 1, 1) <> DirectorySeparator then
     324    if (Copy(Result[I], 1, 1) <> DirectorySeparator) and (Copy(Result[I], 2, 2) <> ':\') then
    325325      Result[I] := ExtractFileDir(Application.ExeName) +
    326326        DirectorySeparator + Result[I];
Note: See TracChangeset for help on using the changeset viewer.