Changeset 131


Ignore:
Timestamp:
Mar 18, 2022, 1:37:03 PM (2 years ago)
Author:
chronos
Message:
  • Modified: Update Common package.
Location:
trunk/Packages/Common
Files:
20 added
20 edited

Legend:

Unmodified
Added
Removed

  • trunk/Packages/Common/Common.lpk

    r122 r131  
    11<?xml version="1.0" encoding="UTF-8"?>
    22<CONFIG>
    3   <Package Version="4">
     3  <Package Version="5">
    44    <PathDelim Value="\"/>
    55    <Name Value="Common"/>
    … …  
    3333      <Other>
    3434        <CompilerMessages>
    35           <IgnoredMessages idx5024="True"/>
     35          <IgnoredMessages idx6058="True" idx5024="True" idx3124="True" idx3123="True"/>
    3636        </CompilerMessages>
    3737      </Other>
    3838    </CompilerOptions>
    39     <Description Value="Various libraries"/>
    40     <License Value="GNU/GPL"/>
    41     <Version Minor="7"/>
    42     <Files Count="22">
     39    <Description Value="Common package with various useful units.
     40
     41Source: https://svn.zdechov.net/PascalClassLibrary/Common/"/>
     42    <License Value="Copy left."/>
     43    <Version Minor="9"/>
     44    <Files Count="29">
    4345      <Item1>
    4446        <Filename Value="StopWatch.pas"/>
    … …  
    6062      <Item5>
    6163        <Filename Value="UPrefixMultiplier.pas"/>
     64        <HasRegisterProc Value="True"/>
    6265        <UnitName Value="UPrefixMultiplier"/>
    6366      </Item5>
    … …  
    138141        <UnitName Value="UStringTable"/>
    139142      </Item22>
     143      <Item23>
     144        <Filename Value="UMetaCanvas.pas"/>
     145        <UnitName Value="UMetaCanvas"/>
     146      </Item23>
     147      <Item24>
     148        <Filename Value="UGeometric.pas"/>
     149        <UnitName Value="UGeometric"/>
     150      </Item24>
     151      <Item25>
     152        <Filename Value="UTranslator.pas"/>
     153        <HasRegisterProc Value="True"/>
     154        <UnitName Value="UTranslator"/>
     155      </Item25>
     156      <Item26>
     157        <Filename Value="ULanguages.pas"/>
     158        <UnitName Value="ULanguages"/>
     159      </Item26>
     160      <Item27>
     161        <Filename Value="UFormAbout.pas"/>
     162        <UnitName Value="UFormAbout"/>
     163      </Item27>
     164      <Item28>
     165        <Filename Value="UAboutDialog.pas"/>
     166        <HasRegisterProc Value="True"/>
     167        <UnitName Value="UAboutDialog"/>
     168      </Item28>
     169      <Item29>
     170        <Filename Value="UPixelPointer.pas"/>
     171        <UnitName Value="UPixelPointer"/>
     172      </Item29>
    140173    </Files>
     174    <CompatibilityMode Value="True"/>
    141175    <i18n>
    142176      <EnableI18N Value="True"/>
    … …  
    144178      <EnableI18NForLFM Value="True"/>
    145179    </i18n>
    146     <RequiredPkgs Count="3">
     180    <RequiredPkgs Count="2">
    147181      <Item1>
    148182        <PackageName Value="LCL"/>
    149183      </Item1>
    150184      <Item2>
    151         <PackageName Value="TemplateGenerics"/>
    152       </Item2>
    153       <Item3>
    154185        <PackageName Value="FCL"/>
    155186        <MinVersion Major="1" Valid="True"/>
    156       </Item3>
     187      </Item2>
    157188    </RequiredPkgs>
    158189    <UsageOptions>

  • trunk/Packages/Common/Common.pas

    r122 r131  
    1212  UMemory, UResetableThread, UPool, ULastOpenedList, URegistry,
    1313  UJobProgressView, UXMLUtils, UApplicationInfo, USyncCounter, UListViewSort,
    14   UPersistentForm, UFindFile, UScaleDPI, UTheme, UStringTable,
    15   LazarusPackageIntf;
     14  UPersistentForm, UFindFile, UScaleDPI, UTheme, UStringTable, UMetaCanvas,
     15  UGeometric, UTranslator, ULanguages, UFormAbout, UAboutDialog,
     16  UPixelPointer, LazarusPackageIntf;
    1617
    1718implementation
    … …  
    2021begin
    2122  RegisterUnit('UDebugLog', @UDebugLog.Register);
     23  RegisterUnit('UPrefixMultiplier', @UPrefixMultiplier.Register);
    2224  RegisterUnit('ULastOpenedList', @ULastOpenedList.Register);
    2325  RegisterUnit('UJobProgressView', @UJobProgressView.Register);
    … …  
    2830  RegisterUnit('UScaleDPI', @UScaleDPI.Register);
    2931  RegisterUnit('UTheme', @UTheme.Register);
     32  RegisterUnit('UTranslator', @UTranslator.Register);
     33  RegisterUnit('UAboutDialog', @UAboutDialog.Register);
    3034end;
    3135

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

    r130 r131  
    1515msgstr ""
    1616
    17 #: ujobprogressview.soperations
    18 msgid "Operations:"
    19 msgstr ""
    20 
    2117#: ujobprogressview.spleasewait
    2218msgid "Please wait..."

  • trunk/Packages/Common/UApplicationInfo.pas

    r122 r131  
    66
    77uses
    8   SysUtils, Classes, Forms, URegistry, Controls;
     8  SysUtils, Classes, Forms, URegistry, Controls, Graphics, LCLType;
    99
    1010type
    … …  
    1414  TApplicationInfo = class(TComponent)
    1515  private
    16     FDescription: TCaption;
     16    FDescription: TTranslateString;
     17    FIcon: TBitmap;
    1718    FIdentification: Byte;
    1819    FLicense: string;
    … …  
    3334  public
    3435    constructor Create(AOwner: TComponent); override;
     36    destructor Destroy; override;
    3537    property Version: string read GetVersion;
    3638    function GetRegistryContext: TRegistryContext;
    … …  
    4749    property EmailContact: string read FEmailContact write FEmailContact;
    4850    property AppName: string read FAppName write FAppName;
    49     property Description: string read FDescription write FDescription;
     51    property Description: TTranslateString read FDescription write FDescription;
    5052    property ReleaseDate: TDateTime read FReleaseDate write FReleaseDate;
    5153    property RegistryKey: string read FRegistryKey write FRegistryKey;
    5254    property RegistryRoot: TRegistryRoot read FRegistryRoot write FRegistryRoot;
    5355    property License: string read FLicense write FLicense;
     56    property Icon: TBitmap read FIcon write FIcon;
    5457  end;
    5558
    … …  
    7477constructor TApplicationInfo.Create(AOwner: TComponent);
    7578begin
    76   inherited Create(AOwner);
     79  inherited;
    7780  FVersionMajor := 1;
    7881  FIdentification := 1;
    … …  
    8083  FRegistryKey := '\Software\' + FAppName;
    8184  FRegistryRoot := rrKeyCurrentUser;
     85  FIcon := TBitmap.Create;
     86end;
     87
     88destructor TApplicationInfo.Destroy;
     89begin
     90  FreeAndNil(FIcon);
     91  inherited;
    8292end;
    8393

  • trunk/Packages/Common/UCommon.pas

    r122 r131  
    66
    77uses
    8   {$ifdef Windows}Windows,{$endif}
    9   {$ifdef Linux}baseunix,{$endif}
    10   Classes, SysUtils, StrUtils, Dialogs, Process, LCLIntf,
     8  {$IFDEF WINDOWS}Windows,{$ENDIF}
     9  {$IFDEF UNIX}baseunix,{$ENDIF}
     10  Classes, SysUtils, StrUtils, Dialogs, Process, LCLIntf, Graphics,
    1111  FileUtil; //, ShFolder, ShellAPI;
    1212
    1313type
    1414  TArrayOfByte = array of Byte;
    15   TArrayOfString = array of string;
    1615  TExceptionEvent = procedure(Sender: TObject; E: Exception) of object;
    1716
    … …  
    2827    unfDNSDomainName = 11);
    2928
    30   TFilterMethodMethod = function (FileName: string): Boolean of object;
     29  TFilterMethod = function (FileName: string): Boolean of object;
     30  TFileNameMethod = procedure (FileName: string) of object;
     31
    3132var
    3233  ExceptionHandler: TExceptionEvent;
    3334  DLLHandle1: HModule;
    3435
    35 {$IFDEF Windows}
     36const
     37  clLightBlue = TColor($FF8080);
     38  clLightGreen = TColor($80FF80);
     39  clLightRed = TColor($8080FF);
     40
     41{$IFDEF WINDOWS}
    3642  GetUserNameEx: procedure (NameFormat: DWORD;
    3743    lpNameBuffer: LPSTR; nSize: PULONG); stdcall;
    3844{$ENDIF}
    3945
    40 function IntToBin(Data: Int64; Count: Byte): string;
     46function AddLeadingZeroes(const aNumber, Length : integer) : string;
    4147function BinToInt(BinStr: string): Int64;
    42 function TryHexToInt(Data: string; var Value: Integer): Boolean;
    43 function TryBinToInt(Data: string; var Value: Integer): Boolean;
    4448function BinToHexString(Source: AnsiString): string;
    4549//function DelTree(DirName : string): Boolean;
    … …  
    4751function BCDToInt(Value: Byte): Byte;
    4852function CompareByteArray(Data1, Data2: TArrayOfByte): Boolean;
     53procedure CopyStringArray(Dest: TStringArray; Source: array of string);
     54function CombinePaths(Path1, Path2: string): string;
     55function ComputerName: string;
     56procedure DeleteFiles(APath, AFileSpec: string);
     57function Explode(Separator: Char; Data: string): TStringArray;
     58procedure ExecuteProgram(Executable: string; Parameters: array of string);
     59procedure FileDialogUpdateFilterFileType(FileDialog: TOpenDialog);
     60procedure FreeThenNil(var Obj);
     61function GetDirCount(Dir: string): Integer;
    4962function GetUserName: string;
    50 function LoggedOnUserNameEx(Format: TUserNameFormat): string;
    51 function SplitString(var Text: string; Count: Word): string;
    5263function GetBitCount(Variable: QWord; MaxIndex: Integer): Integer;
    5364function GetBit(Variable: QWord; Index: Byte): Boolean;
     65function GetStringPart(var Text: string; Separator: string): string;
     66function GenerateNewName(OldName: string): string;
     67function GetFileFilterItemExt(Filter: string; Index: Integer): string;
     68function IntToBin(Data: Int64; Count: Byte): string;
     69function LastPos(const SubStr: String; const S: String): Integer;
     70function LoadFileToStr(const FileName: TFileName): AnsiString;
     71function LoggedOnUserNameEx(Format: TUserNameFormat): string;
     72function MergeArray(A, B: array of string): TStringArray;
     73function OccurenceOfChar(What: Char; Where: string): Integer;
     74procedure OpenWebPage(URL: string);
     75procedure OpenEmail(Email: string);
     76procedure OpenFileInShell(FileName: string);
     77function PosFromIndex(SubStr: string; Text: string;
     78  StartIndex: Integer): Integer;
     79function PosFromIndexReverse(SubStr: string; Text: string;
     80  StartIndex: Integer): Integer;
     81function RemoveQuotes(Text: string): string;
     82procedure SaveStringToFile(S, FileName: string);
    5483procedure SetBit(var Variable: Int64; Index: Byte; State: Boolean); overload;
    5584procedure SetBit(var Variable: QWord; Index: Byte; State: Boolean); overload;
    5685procedure SetBit(var Variable: Cardinal; Index: Byte; State: Boolean); overload;
    5786procedure SetBit(var Variable: Word; Index: Byte; State: Boolean); overload;
    58 function AddLeadingZeroes(const aNumber, Length : integer) : string;
    59 function LastPos(const SubStr: String; const S: String): Integer;
    60 function GenerateNewName(OldName: string): string;
    61 function GetFileFilterItemExt(Filter: string; Index: Integer): string;
    62 procedure FileDialogUpdateFilterFileType(FileDialog: TOpenDialog);
    63 procedure DeleteFiles(APath, AFileSpec: string);
    64 procedure OpenWebPage(URL: string);
    65 procedure OpenFileInShell(FileName: string);
    66 procedure ExecuteProgram(Executable: string; Parameters: array of string);
    67 procedure FreeThenNil(var Obj);
    68 function RemoveQuotes(Text: string): string;
    69 function ComputerName: string;
    70 function OccurenceOfChar(What: Char; Where: string): Integer;
    71 function GetDirCount(Dir: string): Integer;
    72 function MergeArray(A, B: array of string): TArrayOfString;
    73 function LoadFileToStr(const FileName: TFileName): AnsiString;
    7487procedure SearchFiles(AList: TStrings; Dir: string;
    75   FilterMethod: TFilterMethodMethod = nil);
    76 function GetStringPart(var Text: string; Separator: string): string;
     88  FilterMethod: TFilterMethod = nil; FileNameMethod: TFileNameMethod = nil);
     89function SplitString(var Text: string; Count: Word): string;
     90function StripTags(const S: string): string;
     91function TryHexToInt(Data: string; out Value: Integer): Boolean;
     92function TryBinToInt(Data: string; out Value: Integer): Boolean;
     93procedure SortStrings(Strings: TStrings);
    7794
    7895
    … …  
    102119  I: Integer;
    103120begin
     121  Result := '';
    104122  for I := 1 to Length(Source) do begin
    105123    Result := Result + LowerCase(IntToHex(Ord(Source[I]), 2));
    … …  
    234252end;
    235253
    236 function TryHexToInt(Data: string; var Value: Integer): Boolean;
     254function TryHexToInt(Data: string; out Value: Integer): Boolean;
    237255var
    238256  I: Integer;
    … …  
    250268end;
    251269
    252 function TryBinToInt(Data: string; var Value: Integer): Boolean;
     270function TryBinToInt(Data: string; out Value: Integer): Boolean;
    253271var
    254272  I: Integer;
    … …  
    278296end;
    279297
    280 function Explode(Separator: char; Data: string): TArrayOfString;
    281 begin
    282   SetLength(Result, 0);
    283   while Pos(Separator, Data) > 0 do begin
     298function Explode(Separator: Char; Data: string): TStringArray;
     299var
     300  Index: Integer;
     301begin
     302  Result := Default(TStringArray);
     303  repeat
     304    Index := Pos(Separator, Data);
     305    if Index > 0 then begin
     306      SetLength(Result, Length(Result) + 1);
     307      Result[High(Result)] := Copy(Data, 1, Index - 1);
     308      Delete(Data, 1, Index);
     309    end else Break;
     310  until False;
     311  if Data <> '' then begin
    284312    SetLength(Result, Length(Result) + 1);
    285     Result[High(Result)] := Copy(Data, 1, Pos(Separator, Data) - 1);
    286     Delete(Data, 1, Pos(Separator, Data));
    287   end;
    288   SetLength(Result, Length(Result) + 1);
    289   Result[High(Result)] := Data;
    290 end;
    291 
    292 {$IFDEF Windows}
     313    Result[High(Result)] := Data;
     314  end;
     315end;
     316
     317{$IFDEF WINDOWS}
    293318function GetUserName: string;
    294319const
    … …  
    298323begin
    299324  L := MAX_USERNAME_LENGTH + 2;
     325  Result := Default(string);
    300326  SetLength(Result, L);
    301327  if Windows.GetUserName(PChar(Result), L) and (L > 0) then begin
    … …  
    311337  end;
    312338end;
    313 {$endif}
     339{$ENDIF}
    314340
    315341function ComputerName: string;
    316 {$ifdef mswindows}
     342{$IFDEF WINDOWS}
    317343const
    318344 INFO_BUFFER_SIZE = 32767;
    … …  
    329355  end;
    330356end;
    331 {$endif}
    332 {$ifdef unix}
     357{$ENDIF}
     358{$IFDEF UNIX}
    333359var
    334360  Name: UtsName;
    335361begin
     362  Name := Default(UtsName);
    336363  fpuname(Name);
    337364  Result := Name.Nodename;
    338365end;
    339 {$endif}
    340 
    341 {$ifdef windows}
     366{$ENDIF}
     367
     368{$IFDEF WINDOWS}
    342369function LoggedOnUserNameEx(Format: TUserNameFormat): string;
    343370const
    … …  
    417444procedure LoadLibraries;
    418445begin
    419   {$IFDEF Windows}
     446  {$IFDEF WINDOWS}
    420447  DLLHandle1 := LoadLibrary('secur32.dll');
    421448  if DLLHandle1 <> 0 then
    … …  
    428455procedure FreeLibraries;
    429456begin
    430   {$IFDEF Windows}
     457  {$IFDEF WINDOWS}
    431458  if DLLHandle1 <> 0 then FreeLibrary(DLLHandle1);
    432459  {$ENDIF}
    … …  
    461488end;
    462489
     490procedure OpenEmail(Email: string);
     491begin
     492  OpenURL('mailto:' + Email);
     493end;
     494
    463495procedure OpenFileInShell(FileName: string);
    464496begin
    … …  
    489521end;
    490522
    491 function MergeArray(A, B: array of string): TArrayOfString;
    492 var
    493   I: Integer;
    494 begin
     523function MergeArray(A, B: array of string): TStringArray;
     524var
     525  I: Integer;
     526begin
     527  Result := Default(TStringArray);
    495528  SetLength(Result, Length(A) + Length(B));
    496529  for I := 0 to Length(A) - 1 do
    … …  
    523556end;
    524557
     558procedure SaveStringToFile(S, FileName: string);
     559var
     560  F: TextFile;
     561begin
     562  AssignFile(F, FileName);
     563  try
     564    ReWrite(F);
     565    Write(F, S);
     566  finally
     567    CloseFile(F);
     568  end;
     569end;
     570
    525571procedure SearchFiles(AList: TStrings; Dir: string;
    526   FilterMethod: TFilterMethodMethod = nil);
     572  FilterMethod: TFilterMethod = nil; FileNameMethod: TFileNameMethod = nil);
    527573var
    528574  SR: TSearchRec;
    … …  
    534580        if (SR.Name = '.') or (SR.Name = '..') or (Assigned(FilterMethod) and (not FilterMethod(SR.Name) or
    535581          not FilterMethod(Copy(Dir, 3, Length(Dir)) + SR.Name))) then Continue;
     582        if Assigned(FileNameMethod) then
     583          FileNameMethod(Dir + SR.Name);
    536584        AList.Add(Dir + SR.Name);
    537585        if (SR.Attr and faDirectory) <> 0 then
    … …  
    559607end;
    560608
     609function StripTags(const S: string): string;
     610var
     611  Len: Integer;
     612
     613  function ReadUntil(const ReadFrom: Integer; const C: Char): Integer;
     614  var
     615    J: Integer;
     616  begin
     617    for J := ReadFrom to Len do
     618      if (S[j] = C) then
     619      begin
     620        Result := J;
     621        Exit;
     622      end;
     623    Result := Len + 1;
     624  end;
     625
     626var
     627  I, APos: Integer;
     628begin
     629  Len := Length(S);
     630  I := 0;
     631  Result := '';
     632  while (I <= Len) do begin
     633    Inc(I);
     634    APos := ReadUntil(I, '<');
     635    Result := Result + Copy(S, I, APos - i);
     636    I := ReadUntil(APos + 1, '>');
     637  end;
     638end;
     639
     640function PosFromIndex(SubStr: string; Text: string;
     641  StartIndex: Integer): Integer;
     642var
     643  I, MaxLen: SizeInt;
     644  Ptr: PAnsiChar;
     645begin
     646  Result := 0;
     647  if (StartIndex < 1) or (StartIndex > Length(Text) - Length(SubStr)) then Exit;
     648  if Length(SubStr) > 0 then begin
     649    MaxLen := Length(Text) - Length(SubStr) + 1;
     650    I := StartIndex;
     651    Ptr := @Text[StartIndex];
     652    while (I <= MaxLen) do begin
     653      if (SubStr[1] = Ptr^) and (CompareByte(Substr[1], Ptr^, Length(SubStr)) = 0) then begin
     654        Result := I;
     655        Exit;
     656      end;
     657      Inc(I);
     658      Inc(Ptr);
     659    end;
     660  end;
     661end;
     662
     663function PosFromIndexReverse(SubStr: string; Text: string;
     664  StartIndex: Integer): Integer;
     665var
     666  I: SizeInt;
     667  Ptr: PAnsiChar;
     668begin
     669  Result := 0;
     670  if (StartIndex < 1) or (StartIndex > Length(Text)) then Exit;
     671  if Length(SubStr) > 0 then begin
     672    I := StartIndex;
     673    Ptr := @Text[StartIndex];
     674    while (I > 0) do begin
     675      if (SubStr[1] = Ptr^) and (CompareByte(Substr[1], Ptr^, Length(SubStr)) = 0) then begin
     676        Result := I;
     677        Exit;
     678      end;
     679      Dec(I);
     680      Dec(Ptr);
     681    end;
     682  end;
     683end;
     684
     685procedure CopyStringArray(Dest: TStringArray; Source: array of string);
     686var
     687  I: Integer;
     688begin
     689  SetLength(Dest, Length(Source));
     690  for I := 0 to Length(Dest) - 1 do
     691    Dest[I] := Source[I];
     692end;
     693
     694function CombinePaths(Path1, Path2: string): string;
     695begin
     696  Result := Path1;
     697  if Result <> '' then Result := Result + DirectorySeparator + Path2
     698    else Result := Path2;
     699end;
     700
     701procedure SortStrings(Strings: TStrings);
     702var
     703  Tmp: TStringList;
     704begin
     705  Strings.BeginUpdate;
     706  try
     707    if Strings is TStringList then begin
     708      TStringList(Strings).Sort;
     709    end else begin
     710      Tmp := TStringList.Create;
     711      try
     712        Tmp.Assign(Strings);
     713        Tmp.Sort;
     714        Strings.Assign(Tmp);
     715      finally
     716        Tmp.Free;
     717      end;
     718    end;
     719  finally
     720    Strings.EndUpdate;
     721  end;
     722end;
    561723
    562724

  • trunk/Packages/Common/UDebugLog.pas

    r122 r131  
    66
    77uses
    8   Classes, SysUtils, FileUtil, SpecializedList, SyncObjs;
     8  Classes, SysUtils, FileUtil, fgl, SyncObjs;
    99
    1010type
    … …  
    2929    procedure SetMaxCount(const AValue: Integer);
    3030  public
    31     Items: TListObject;
     31    Items: TFPGObjectList<TDebugLogItem>;
    3232    Lock: TCriticalSection;
    3333    procedure Add(Text: string; Group: string = '');
    … …  
    117117begin
    118118  inherited;
    119   Items := TListObject.Create;
     119  Items := TFPGObjectList<TDebugLogItem>.Create;
    120120  Lock := TCriticalSection.Create;
    121121  MaxCount := 100;

  • trunk/Packages/Common/UFindFile.pas

    r122 r131  
    5959  FilterAll = '*.*';
    6060{$ENDIF}
    61 {$IFDEF LINUX}
     61{$IFDEF UNIX}
    6262  FilterAll = '*';
    6363{$ENDIF}

  • trunk/Packages/Common/UJobProgressView.lfm

    r122 r131  
    11object FormJobProgressView: TFormJobProgressView
    22  Left = 467
    3   Height = 345
     3  Height = 414
    44  Top = 252
    5   Width = 539
     5  Width = 647
    66  BorderIcons = [biSystemMenu]
    7   ClientHeight = 345
    8   ClientWidth = 539
    9   DesignTimePPI = 120
     7  ClientHeight = 414
     8  ClientWidth = 647
     9  DesignTimePPI = 144
    1010  OnClose = FormClose
    1111  OnCloseQuery = FormCloseQuery
    1212  OnCreate = FormCreate
    13   OnDestroy = FormDestroy
    1413  OnHide = FormHide
    1514  OnShow = FormShow
    1615  Position = poScreenCenter
    17   LCLVersion = '1.8.2.0'
     16  LCLVersion = '2.2.0.4'
    1817  object PanelOperationsTitle: TPanel
    1918    Left = 0
    20     Height = 32
     19    Height = 38
    2120    Top = 0
    22     Width = 539
     21    Width = 647
    2322    Align = alTop
    2423    BevelOuter = bvNone
    25     ClientHeight = 32
    26     ClientWidth = 539
     24    ClientHeight = 38
     25    ClientWidth = 647
    2726    FullRepaint = False
    2827    TabOrder = 0
    2928    object LabelOperation: TLabel
    30       Left = 8
    31       Height = 20
    32       Top = 8
    33       Width = 76
     29      Left = 10
     30      Height = 26
     31      Top = 10
     32      Width = 99
    3433      Caption = 'Operations:'
    35       ParentColor = False
    3634      ParentFont = False
    3735    end
    … …  
    3937  object PanelLog: TPanel
    4038    Left = 0
    41     Height = 133
    42     Top = 212
    43     Width = 539
     39    Height = 161
     40    Top = 253
     41    Width = 647
    4442    Align = alClient
    4543    BevelOuter = bvSpace
    46     ClientHeight = 133
    47     ClientWidth = 539
     44    ClientHeight = 161
     45    ClientWidth = 647
    4846    TabOrder = 1
    4947    object MemoLog: TMemo
    50       Left = 8
    51       Height = 117
    52       Top = 8
    53       Width = 523
     48      Left = 10
     49      Height = 141
     50      Top = 10
     51      Width = 627
    5452      Anchors = [akTop, akLeft, akRight, akBottom]
    5553      ReadOnly = True
    … …  
    6058  object PanelProgress: TPanel
    6159    Left = 0
    62     Height = 54
    63     Top = 106
    64     Width = 539
     60    Height = 65
     61    Top = 126
     62    Width = 647
    6563    Align = alTop
    6664    BevelOuter = bvNone
    67     ClientHeight = 54
    68     ClientWidth = 539
     65    ClientHeight = 65
     66    ClientWidth = 647
    6967    TabOrder = 2
    7068    object ProgressBarPart: TProgressBar
    71       Left = 10
    72       Height = 24
    73       Top = 24
    74       Width = 523
     69      Left = 12
     70      Height = 29
     71      Top = 29
     72      Width = 628
    7573      Anchors = [akTop, akLeft, akRight]
    7674      TabOrder = 0
    7775    end
    7876    object LabelEstimatedTimePart: TLabel
    79       Left = 8
    80       Height = 20
     77      Left = 10
     78      Height = 26
    8179      Top = -2
    82       Width = 103
     80      Width = 132
    8381      Caption = 'Estimated time:'
    84       ParentColor = False
    8582    end
    8683  end
    8784  object PanelOperations: TPanel
    8885    Left = 0
    89     Height = 42
    90     Top = 64
    91     Width = 539
     86    Height = 50
     87    Top = 76
     88    Width = 647
    9289    Align = alTop
    9390    BevelOuter = bvNone
    94     ClientHeight = 42
    95     ClientWidth = 539
     91    ClientHeight = 50
     92    ClientWidth = 647
    9693    FullRepaint = False
    9794    TabOrder = 3
    9895    object ListViewJobs: TListView
    99       Left = 8
    100       Height = 32
    101       Top = 5
    102       Width = 523
     96      Left = 10
     97      Height = 38
     98      Top = 6
     99      Width = 627
    103100      Anchors = [akTop, akLeft, akRight, akBottom]
    104101      AutoWidthLastColumn = True
    … …  
    107104      Columns = <     
    108105        item
    109           Width = 523
     106          Width = 614
    110107        end>
    111108      OwnerData = True
    … …  
    120117  object PanelProgressTotal: TPanel
    121118    Left = 0
    122     Height = 52
    123     Top = 160
    124     Width = 539
     119    Height = 62
     120    Top = 191
     121    Width = 647
    125122    Align = alTop
    126123    BevelOuter = bvNone
    127     ClientHeight = 52
    128     ClientWidth = 539
     124    ClientHeight = 62
     125    ClientWidth = 647
    129126    TabOrder = 4
    130127    object LabelEstimatedTimeTotal: TLabel
    131       Left = 8
    132       Height = 20
     128      Left = 10
     129      Height = 26
    133130      Top = 0
    134       Width = 141
     131      Width = 178
    135132      Caption = 'Total estimated time:'
    136       ParentColor = False
    137133    end
    138134    object ProgressBarTotal: TProgressBar
    139       Left = 8
    140       Height = 24
    141       Top = 24
    142       Width = 523
     135      Left = 10
     136      Height = 29
     137      Top = 29
     138      Width = 627
    143139      Anchors = [akTop, akLeft, akRight]
    144140      TabOrder = 0
    … …  
    147143  object PanelText: TPanel
    148144    Left = 0
    149     Height = 32
    150     Top = 32
    151     Width = 539
     145    Height = 38
     146    Top = 38
     147    Width = 647
    152148    Align = alTop
    153149    BevelOuter = bvNone
    154     ClientHeight = 32
    155     ClientWidth = 539
     150    ClientHeight = 38
     151    ClientWidth = 647
    156152    TabOrder = 5
    157153    object LabelText: TLabel
    158       Left = 8
    159       Height = 24
    160       Top = 8
    161       Width = 525
     154      Left = 10
     155      Height = 29
     156      Top = 10
     157      Width = 630
    162158      Anchors = [akTop, akLeft, akRight]
    163159      AutoSize = False
    164       ParentColor = False
    165160    end
    166161  end
    167162  object ImageList1: TImageList
    168     BkColor = clForeground
    169     left = 200
    170     top = 8
     163    Left = 240
     164    Top = 10
    171165    Bitmap = {
    172       4C69020000001000000010000000FF00FF00FF00FF00FF00FF00FF00FF00FF00
    173       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    174       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    175       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    176       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    177       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    178       FF00000000FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    179       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF000000
    180       00FF000000FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    181       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF0000
    182       00FF000000FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    183       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF0000
    184       00FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    185       FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FF0000
    186       00FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FFFF00FF00FF00
    187       FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FF000000FFFF00
    188       FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FFFF00
    189       FF00FF00FF00FF00FF00000000FF000000FF000000FF000000FFFF00FF00FF00
    190       FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FF0000
    191       00FFFF00FF00000000FF000000FF000000FF000000FFFF00FF00FF00FF00FF00
    192       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF0000
    193       00FF000000FF000000FF000000FF000000FFFF00FF00FF00FF00FF00FF00FF00
    194       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF0000
    195       00FF000000FF000000FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00
    196       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF000000
    197       00FF000000FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    198       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    199       FF00000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    200       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    201       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    202       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    203       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    204       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    205       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    206       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    207       FF00FF00FF00FF00FF00FF00FF00000000FFFF00FF00FF00FF00FF00FF00FF00
    208       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    209       FF00FF00FF00FF00FF00FF00FF00000000FF000000FFFF00FF00FF00FF00FF00
    210       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    211       FF00FF00FF00FF00FF00FF00FF00000000FF000084FF000000FFFF00FF00FF00
    212       FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FF0000
    213       00FF000000FF000000FF000000FF000000FF0000FFFF000084FF000000FFFF00
    214       FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF0000FFFF0000FFFF0000
    215       FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF000084FF0000
    216       00FFFF00FF00FF00FF00FF00FF00FF00FF00000000FF0000FFFF0000FFFF0000
    217       FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000
    218       84FF000000FFFF00FF00FF00FF00FF00FF00000000FF0000FFFF0000FFFF0000
    219       FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000
    220       FFFF000084FF000000FFFF00FF00FF00FF00000000FF0000FFFF0000FFFF0000
    221       FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000
    222       84FF000000FFFF00FF00FF00FF00FF00FF00000000FF0000FFFF0000FFFF0000
    223       FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF000084FF0000
    224       00FFFF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FF0000
    225       00FF000000FF000000FF000000FF000000FF0000FFFF000084FF000000FFFF00
    226       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    227       FF00FF00FF00FF00FF00FF00FF00000000FF000084FF000000FFFF00FF00FF00
    228       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    229       FF00FF00FF00FF00FF00FF00FF00000000FF000000FFFF00FF00FF00FF00FF00
    230       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    231       FF00FF00FF00FF00FF00FF00FF00000000FFFF00FF00FF00FF00FF00FF00FF00
    232       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    233       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    234       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    235       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    236       FF00FF00FF00FF00FF00FF00FF00
     166      4C7A0200000010000000100000006A0000000000000078DAE593490E00100C45
     167      7B78F72E5684A63A1142C382BE4F0708F89C955117F4B016BE67B5FC6E96DB97
     168      B0D4B9F4CD949F36DED1DF922B0F1BD11FAB5AFC68DE5C44D40220A9FA779EC8
     169      6A349FD5A435E43CADA1E3678D73F773F1DBF3EFADFFEEFEBBF97F6696BE9D36
    237170    }
    238171  end
    … …  
    241174    Interval = 100
    242175    OnTimer = TimerUpdateTimer
    243     left = 264
    244     top = 8
     176    Left = 384
     177    Top = 10
    245178  end
    246179end

  • trunk/Packages/Common/UJobProgressView.pas

    r122 r131  
    77uses
    88  SysUtils, Variants, Classes, Graphics, Controls, Forms, Syncobjs,
    9   Dialogs, ComCtrls, StdCtrls, ExtCtrls, Contnrs, UThreading, Math,
     9  Dialogs, ComCtrls, StdCtrls, ExtCtrls, fgl, UThreading, Math,
    1010  DateUtils;
    1111
    … …  
    7171  end;
    7272
    73   TJobs = class(TObjectList)
     73  TJobs = class(TFPGObjectList<TJob>)
    7474  end;
    7575
    … …  
    105105    procedure ReloadJobList;
    106106    procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
    107     procedure FormDestroy(Sender: TObject);
    108107    procedure ListViewJobsData(Sender: TObject; Item: TListItem);
    109108    procedure TimerUpdateTimer(Sender: TObject);
    … …  
    175174  STotalEstimatedTime = 'Total estimated time: %s';
    176175  SFinished = 'Finished';
    177   SOperations = 'Operations:';
    178176
    179177procedure Register;
    … …  
    287285end;
    288286
    289 procedure TFormJobProgressView.FormDestroy(Sender:TObject);
    290 begin
    291 end;
    292 
    293287procedure TFormJobProgressView.ListViewJobsData(Sender: TObject; Item: TListItem);
    294288begin
    295289  if (Item.Index >= 0) and (Item.Index < JobProgressView.Jobs.Count) then
    296   with TJob(JobProgressView.Jobs[Item.Index]) do begin
     290  with JobProgressView.Jobs[Item.Index] do begin
    297291    Item.Caption := Title;
    298292    if Item.Index = JobProgressView.CurrentJobIndex then Item.ImageIndex := 1
    … …  
    406400    I := 0;
    407401    while I < Jobs.Count do
    408     with TJob(Jobs[I]) do begin
     402    with Jobs[I] do begin
    409403      CurrentJobIndex := I;
    410       CurrentJob := TJob(Jobs[I]);
     404      CurrentJob := Jobs[I];
    411405      JobProgressChange(Self);
    412406      StartTime := Now;
    … …  
    421415        Method(CurrentJob);
    422416      end else begin
     417        Thread := TJobThread.Create(True);
    423418        try
    424           Thread := TJobThread.Create(True);
    425419          with Thread do begin
    426420            FreeOnTerminate := False;
    … …  
    495489  if AValue = FTerminate then Exit;
    496490  for I := 0 to Jobs.Count - 1 do
    497     TJob(Jobs[I]).Terminate := AValue;
     491    Jobs[I].Terminate := AValue;
    498492  FTerminate := AValue;
    499493end;
    … …  
    621615procedure TProgress.Increment;
    622616begin
    623   try
    624     FLock.Acquire;
     617  FLock.Acquire;
     618  try
    625619    Value := Value + 1;
    626620  finally
    … …  
    631625procedure TProgress.Reset;
    632626begin
    633   try
    634     FLock.Acquire;
     627  FLock.Acquire;
     628  try
    635629    FValue := 0;
    636630  finally
    … …  
    679673destructor TJob.Destroy;
    680674begin
    681   Progress.Free;
     675  FreeAndNil(Progress);
    682676  inherited;
    683677end;

  • trunk/Packages/Common/ULastOpenedList.pas

    r122 r131  
    3030    procedure SaveToXMLConfig(XMLConfig: TXMLConfig; Path: string);
    3131    procedure AddItem(FileName: string);
     32    function GetFirstFileName: string;
    3233  published
    3334    property MaxCount: Integer read FMaxCount write SetMaxCount;
    … …  
    8384destructor TLastOpenedList.Destroy;
    8485begin
    85   Items.Free;
     86  FreeAndNil(Items);
    8687  inherited;
    8788end;
    … …  
    9394begin
    9495  if Assigned(MenuItem) then begin
    95     MenuItem.Clear;
     96    while MenuItem.Count > Items.Count do
     97      MenuItem.Delete(MenuItem.Count - 1);
     98    while MenuItem.Count < Items.Count do begin
     99      NewMenuItem := TMenuItem.Create(MenuItem);
     100      MenuItem.Add(NewMenuItem);
     101    end;
    96102    for I := 0 to Items.Count - 1 do begin
    97       NewMenuItem := TMenuItem.Create(MenuItem);
    98       NewMenuItem.Caption := Items[I];
    99       NewMenuItem.OnClick := ClickAction;
    100       MenuItem.Add(NewMenuItem);
     103      MenuItem.Items[I].Caption := Items[I];
     104      MenuItem.Items[I].OnClick := ClickAction;
    101105    end;
    102106  end;
    … …  
    185189end;
    186190
     191function TLastOpenedList.GetFirstFileName: string;
     192begin
     193  if Items.Count > 0 then Result := Items[0]
     194    else Result := '';
     195end;
     196
    187197end.
    188198

  • trunk/Packages/Common/UListViewSort.pas

    r122 r131  
    11unit UListViewSort;
    22
    3 // Date: 2010-11-03
     3// Date: 2019-05-17
    44
    55{$mode delphi}
    … …  
    88
    99uses
    10   {$IFDEF Windows}Windows, CommCtrl, {$ENDIF}Classes, Graphics, ComCtrls, SysUtils,
    11   Controls, DateUtils, Dialogs, SpecializedList, Forms, Grids, StdCtrls, ExtCtrls,
    12   LclIntf, LMessages, LclType, LResources;
     10  {$IFDEF Windows}Windows, CommCtrl, LMessages, {$ENDIF}Classes, Graphics, ComCtrls, SysUtils,
     11  Controls, DateUtils, Dialogs, fgl, Forms, Grids, StdCtrls, ExtCtrls,
     12  LclIntf, LclType, LResources;
    1313
    1414type
    … …  
    5252    {$ENDIF}
    5353  public
    54     List: TListObject;
    55     Source: TListObject;
     54    List: TFPGObjectList<TObject>;
     55    Source: TFPGObjectList<TObject>;
    5656    constructor Create(AOwner: TComponent); override;
    5757    destructor Destroy; override;
    … …  
    8181    FOnChange: TNotifyEvent;
    8282    FStringGrid1: TStringGrid;
     83    procedure DoOnChange;
    8384    procedure GridDoOnKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
    8485    procedure GridDoOnResize(Sender: TObject);
    … …  
    9091    function TextEnteredColumn(Index: Integer): Boolean;
    9192    function GetColValue(Index: Integer): string;
     93    procedure Reset;
    9294    property StringGrid: TStringGrid read FStringGrid1 write FStringGrid1;
    9395  published
    … …  
    98100  end;
    99101
     102  { TListViewEx }
     103
     104  TListViewEx = class(TWinControl)
     105  private
     106    FFilter: TListViewFilter;
     107    FListView: TListView;
     108    FListViewSort: TListViewSort;
     109    procedure ResizeHanlder;
     110  public
     111    constructor Create(TheOwner: TComponent); override;
     112    destructor Destroy; override;
     113  published
     114    property ListView: TListView read FListView write FListView;
     115    property ListViewSort: TListViewSort read FListViewSort write FListViewSort;
     116    property Filter: TListViewFilter read FFilter write FFilter;
     117    property Visible;
     118  end;
     119
    100120procedure Register;
    101121
    … …  
    105125procedure Register;
    106126begin
    107   RegisterComponents('Common', [TListViewSort, TListViewFilter]);
     127  RegisterComponents('Common', [TListViewSort, TListViewFilter, TListViewEx]);
     128end;
     129
     130{ TListViewEx }
     131
     132procedure TListViewEx.ResizeHanlder;
     133begin
     134end;
     135
     136constructor TListViewEx.Create(TheOwner: TComponent);
     137begin
     138  inherited Create(TheOwner);
     139  Filter := TListViewFilter.Create(Self);
     140  Filter.Parent := Self;
     141  Filter.Align := alBottom;
     142  ListView := TListView.Create(Self);
     143  ListView.Parent := Self;
     144  ListView.Align := alClient;
     145  ListViewSort := TListViewSort.Create(Self);
     146  ListViewSort.ListView := ListView;
     147end;
     148
     149destructor TListViewEx.Destroy;
     150begin
     151  inherited Destroy;
    108152end;
    109153
    110154{ TListViewFilter }
     155
     156procedure TListViewFilter.DoOnChange;
     157begin
     158  if Assigned(FOnChange) then FOnChange(Self);
     159end;
    111160
    112161procedure TListViewFilter.GridDoOnKeyUp(Sender: TObject; var Key: Word;
    113162  Shift: TShiftState);
    114163begin
    115   if Assigned(FOnChange) then
    116     FOnChange(Self);
     164  DoOnChange;
    117165end;
    118166
    … …  
    187235end;
    188236
     237procedure TListViewFilter.Reset;
     238var
     239  I: Integer;
     240begin
     241  with StringGrid do
     242  for I := 0 to ColCount - 1 do
     243    Cells[I, 0] := '';
     244  DoOnChange;
     245end;
     246
    189247{ TListViewSort }
    190248
    … …  
    277335end;
    278336
     337var
     338  ListViewSortCompare: TCompareEvent;
     339
     340function ListViewCompare(const Item1, Item2: TObject): Integer;
     341begin
     342  Result := ListViewSortCompare(Item1, Item2);
     343end;
     344
    279345procedure TListViewSort.Sort(Compare: TCompareEvent);
    280346begin
     347  // TODO: Because TFLGObjectList compare handler is not class method,
     348  // it is necessary to use simple function compare handler with local variable
     349  ListViewSortCompare := Compare;
    281350  if (List.Count > 0) then
    282     List.Sort(Compare);
     351    List.Sort(ListViewCompare);
    283352end;
    284353
    … …  
    343412begin
    344413  inherited;
    345   List := TListObject.Create;
    346   List.OwnsObjects := False;
     414  List := TFPGObjectList<TObject>.Create;
     415  List.FreeObjects := False;
    347416end;
    348417

  • trunk/Packages/Common/UMemory.pas

    r89 r131  
    112112procedure TMemory.WriteMemory(Position: Integer; Memory: TMemory);
    113113begin
    114   Move(Memory.FData, PByte(@FData + Position)^, Memory.Size);
     114  Move(Memory.FData, PByte(PByte(@FData) + Position)^, Memory.Size);
    115115end;
    116116
    117117procedure TMemory.ReadMemory(Position: Integer; Memory: TMemory);
    118118begin
    119   Move(PByte(@FData + Position)^, Memory.FData, Memory.Size);
     119  Move(PByte(PByte(@FData) + Position)^, Memory.FData, Memory.Size);
    120120end;
    121121

  • trunk/Packages/Common/UPersistentForm.pas

    r122 r131  
    33{$mode delphi}
    44
    5 // Date: 2015-04-18
     5// Date: 2020-11-26
    66
    77interface
    … …  
    99uses
    1010  Classes, SysUtils, Forms, URegistry, LCLIntf, Registry, Controls, ComCtrls,
    11   ExtCtrls;
     11  ExtCtrls, LCLType;
    1212
    1313type
    … …  
    2626    FormRestoredSize: TRect;
    2727    FormWindowState: TWindowState;
     28    FormFullScreen: Boolean;
    2829    Form: TForm;
    2930    procedure LoadFromRegistry(RegistryContext: TRegistryContext);
    … …  
    3132    function CheckEntireVisible(Rect: TRect): TRect;
    3233    function CheckPartVisible(Rect: TRect; Part: Integer): TRect;
    33     procedure Load(Form: TForm; DefaultMaximized: Boolean = False);
     34    procedure Load(Form: TForm; DefaultMaximized: Boolean = False;
     35      DefaultFullScreen: Boolean = False);
    3436    procedure Save(Form: TForm);
    3537    constructor Create(AOwner: TComponent); override;
     38    procedure SetFullScreen(State: Boolean);
    3639    property RegistryContext: TRegistryContext read FRegistryContext
    3740      write FRegistryContext;
    … …  
    4346procedure Register;
    4447
     48
    4549implementation
    46 
    4750
    4851procedure Register;
    … …  
    169172      + FormRestoredSize.Top;
    170173    // Other state
    171     FormWindowState := TWindowState(ReadIntegerWithDefault('WindowState', Integer(wsNormal)));
     174    FormWindowState := TWindowState(ReadIntegerWithDefault('WindowState', Integer(FormWindowState)));
     175    FormFullScreen := ReadBoolWithDefault('FullScreen', FormFullScreen);
    172176  finally
    173177    Free;
    … …  
    193197    // Other state
    194198    WriteInteger('WindowState', Integer(FormWindowState));
     199    WriteBool('FullScreen', FormFullScreen);
    195200  finally
    196201    Free;
    … …  
    250255end;
    251256
    252 procedure TPersistentForm.Load(Form: TForm; DefaultMaximized: Boolean = False);
     257procedure TPersistentForm.Load(Form: TForm; DefaultMaximized: Boolean = False;
     258  DefaultFullScreen: Boolean = False);
    253259begin
    254260  Self.Form := Form;
    … …  
    258264  FormRestoredSize := Bounds((Screen.Width - Form.Width) div 2,
    259265    (Screen.Height - Form.Height) div 2, Form.Width, Form.Height);
     266  FormWindowState := Form.WindowState;
     267  FormFullScreen := DefaultFullScreen;
    260268
    261269  LoadFromRegistry(RegistryContext);
    … …  
    277285      Form.BoundsRect := FormNormalSize;
    278286  end;
     287  if FormFullScreen then SetFullScreen(True);
    279288  LoadControl(Form);
    280289end;
    … …  
    284293  Self.Form := Form;
    285294  FormNormalSize := Bounds(Form.Left, Form.Top, Form.Width, Form.Height);
    286   FormRestoredSize := Bounds(Form.RestoredLeft, Form.RestoredTop, Form.RestoredWidth,
    287     Form.RestoredHeight);
     295  if not FormFullScreen then
     296    FormRestoredSize := Bounds(Form.RestoredLeft, Form.RestoredTop, Form.RestoredWidth,
     297      Form.RestoredHeight);
    288298  FormWindowState := Form.WindowState;
    289299  SaveToRegistry(RegistryContext);
    … …  
    300310end;
    301311
     312procedure TPersistentForm.SetFullScreen(State: Boolean);
     313begin
     314  if State then begin
     315    FormFullScreen := True;
     316    FormNormalSize := Form.BoundsRect;
     317    FormRestoredSize := Bounds(Form.RestoredLeft, Form.RestoredTop, Form.RestoredWidth,
     318      Form.RestoredHeight);
     319    FormWindowState := Form.WindowState;
     320    ShowWindow(Form.Handle, SW_SHOWFULLSCREEN);
     321    {$IFDEF WINDOWS}
     322    Form.BorderStyle := bsNone;
     323    {$ENDIF}
     324  end else begin
     325    FormFullScreen := False;
     326    {$IFDEF WINDOWS}
     327    Form.BorderStyle := bsSizeable;
     328    {$ENDIF}
     329    ShowWindow(Form.Handle, SW_SHOWNORMAL);
     330    if FormWindowState = wsNormal then begin
     331      Form.BoundsRect := FormNormalSize;
     332    end else
     333    if FormWindowState = wsMaximized then begin
     334      Form.BoundsRect := FormRestoredSize;
     335      Form.WindowState := wsMaximized;
     336    end;
     337  end;
     338end;
     339
    302340end.
    303341

  • trunk/Packages/Common/UPool.pas

    r84 r131  
    66
    77uses
    8   Classes, SysUtils, syncobjs, SpecializedList, UThreading;
     8  Classes, SysUtils, syncobjs, fgl, UThreading;
    99
    1010type
    … …  
    2222    function NewItemObject: TObject; virtual;
    2323  public
    24     Items: TListObject;
    25     FreeItems: TListObject;
     24    Items: TFPGObjectList<TObject>;
     25    FreeItems: TFPGObjectList<TObject>;
    2626    function Acquire: TObject; virtual;
    2727    procedure Release(Item: TObject); virtual;
    … …  
    185185begin
    186186  inherited;
    187   Items := TListObject.Create;
    188   FreeItems := TListObject.Create;
    189   FreeItems.OwnsObjects := False;
     187  Items := TFPGObjectList<TObject>.Create;
     188  FreeItems := TFPGObjectList<TObject>.Create;
     189  FreeItems.FreeObjects := False;
    190190  FReleaseEvent := TEvent.Create(nil, False, False, '');
    191191end;

  • trunk/Packages/Common/UPrefixMultiplier.pas

    r84 r131  
    2121  { TPrefixMultiplier }
    2222
    23   TPrefixMultiplier = class
     23  TPrefixMultiplier = class(TComponent)
    2424  private
    25     function TruncateDigits(Value:Double;Digits:Integer=3):Double;
     25    function TruncateDigits(Value: Double; Digits: Integer = 3): Double;
    2626  public
    2727    function Add(Value: Double; PrefixMultipliers: TPrefixMultiplierDef;
    … …  
    7272  );
    7373
     74procedure Register;
     75
     76
    7477implementation
     78
     79procedure Register;
     80begin
     81  RegisterComponents('Common', [TPrefixMultiplier]);
     82end;
    7583
    7684{ TPrefixMultiplier }
    … …  
    92100end;
    93101
    94 function TPrefixMultiplier.Add(Value:Double;PrefixMultipliers:TPrefixMultiplierDef
    95   ;UnitText:string;Digits:Integer):string;
     102function TPrefixMultiplier.Add(Value: Double; PrefixMultipliers: TPrefixMultiplierDef
     103  ; UnitText:string; Digits: Integer): string;
    96104var
    97105  I: Integer;

  • trunk/Packages/Common/URegistry.pas

    r123 r131  
    11unit URegistry;
    22
    3 {$MODE Delphi}
     3{$MODE delphi}
    44
    55interface
    … …  
    1717    RootKey: HKEY;
    1818    Key: string;
    19     class operator Equal(A, B: TRegistryContext): Boolean;
    2019    class function Create(RootKey: TRegistryRoot; Key: string): TRegistryContext; static; overload;
    2120    class function Create(RootKey: HKEY; Key: string): TRegistryContext; static; overload;
     21    class operator Equal(A, B: TRegistryContext): Boolean;
    2222  end;
    2323
    … …  
    2929    procedure SetCurrentContext(AValue: TRegistryContext);
    3030  public
     31    function ReadChar(const Name: string): Char;
     32    procedure WriteChar(const Name: string; Value: Char);
    3133    function ReadBoolWithDefault(const Name: string;
    3234      DefaultValue: Boolean): Boolean;
    3335    function ReadIntegerWithDefault(const Name: string; DefaultValue: Integer): Integer;
    3436    function ReadStringWithDefault(const Name: string; DefaultValue: string): string;
     37    function ReadCharWithDefault(const Name: string; DefaultValue: Char): Char;
    3538    function ReadFloatWithDefault(const Name: string;
    3639      DefaultValue: Double): Double;
    … …  
    8992end;
    9093
     94function TRegistryEx.ReadCharWithDefault(const Name: string; DefaultValue: Char
     95  ): Char;
     96begin
     97  if ValueExists(Name) then Result := ReadChar(Name)
     98    else begin
     99      WriteChar(Name, DefaultValue);
     100      Result := DefaultValue;
     101    end;
     102end;
     103
    91104function TRegistryEx.ReadFloatWithDefault(const Name: string;
    92105  DefaultValue: Double): Double;
    … …  
    119132function TRegistryEx.OpenKey(const Key: string; CanCreate: Boolean): Boolean;
    120133begin
    121   {$IFDEF Linux}
    122   CloseKey;
     134  {$IFDEF UNIX}
     135  //CloseKey;
    123136  {$ENDIF}
    124137  Result := inherited OpenKey(Key, CanCreate);
    … …  
    127140function TRegistryEx.GetCurrentContext: TRegistryContext;
    128141begin
    129   Result.Key := CurrentPath;
     142  Result.Key := String(CurrentPath);
    130143  Result.RootKey := RootKey;
    131144end;
    … …  
    135148  RootKey := AValue.RootKey;
    136149  OpenKey(AValue.Key, True);
     150end;
     151
     152function TRegistryEx.ReadChar(const Name: string): Char;
     153var
     154  S: string;
     155begin
     156  S := ReadString(Name);
     157  if Length(S) > 0 then Result := S[1]
     158    else Result := #0;
     159end;
     160
     161procedure TRegistryEx.WriteChar(const Name: string; Value: Char);
     162begin
     163  WriteString(Name, Value);
    137164end;
    138165

  • trunk/Packages/Common/UScaleDPI.pas

    r122 r131  
    88
    99uses
    10   Classes, Forms, Graphics, Controls, ComCtrls, LCLType, SysUtils, StdCtrls,
    11   Contnrs;
     10  Classes, Forms, Graphics, Controls, ComCtrls, LCLType, SysUtils, fgl;
    1211
    1312type
     13  TControlDimensions = class;
    1414
    1515  { TControlDimension }
    … …  
    1818    BoundsRect: TRect;
    1919    FontHeight: Integer;
    20     Controls: TObjectList; // TList<TControlDimension>
     20    Controls: TControlDimensions;
    2121    // Class specifics
    2222    ButtonSize: TPoint; // TToolBar
    … …  
    2626    constructor Create;
    2727    destructor Destroy; override;
     28  end;
     29
     30  TControlDimensions = class(TFPGObjectList<TControlDimension>)
    2831  end;
    2932
    … …  
    7376constructor TControlDimension.Create;
    7477begin
    75   Controls := TObjectList.Create;
     78  Controls := TControlDimensions.Create;
    7679end;
    7780
    … …  
    7982begin
    8083  FreeAndNil(Controls);
    81   inherited Destroy;
     84  inherited;
    8285end;
    8386
    … …  
    212215  TempBmp: TBitmap;
    213216  Temp: array of TBitmap;
    214   NewWidth, NewHeight: integer;
     217  NewWidth: Integer;
     218  NewHeight: Integer;
    215219  I: Integer;
    216220begin
    217221  ImgList.BeginUpdate;
    218   NewWidth := ScaleX(ImgList.Width, FromDPI.X);
    219   NewHeight := ScaleY(ImgList.Height, FromDPI.Y);
    220 
    221   SetLength(Temp, ImgList.Count);
    222   for I := 0 to ImgList.Count - 1 do
    223   begin
    224     TempBmp := TBitmap.Create;
    225     TempBmp.PixelFormat := pf32bit;
    226     ImgList.GetBitmap(I, TempBmp);
    227     Temp[I] := TBitmap.Create;
    228     Temp[I].SetSize(NewWidth, NewHeight);
    229     Temp[I].PixelFormat := pf32bit;
    230     Temp[I].TransparentColor := TempBmp.TransparentColor;
    231     //Temp[I].TransparentMode := TempBmp.TransparentMode;
    232     Temp[I].Transparent := True;
    233     Temp[I].Canvas.Brush.Style := bsSolid;
    234     Temp[I].Canvas.Brush.Color := Temp[I].TransparentColor;
    235     Temp[I].Canvas.FillRect(0, 0, Temp[I].Width, Temp[I].Height);
    236 
    237     if (Temp[I].Width = 0) or (Temp[I].Height = 0) then Continue;
    238     Temp[I].Canvas.StretchDraw(Rect(0, 0, Temp[I].Width, Temp[I].Height), TempBmp);
    239     TempBmp.Free;
    240   end;
    241 
    242   ImgList.Clear;
    243   ImgList.Width := NewWidth;
    244   ImgList.Height := NewHeight;
    245 
    246   for I := 0 to High(Temp) do
    247   begin
    248     ImgList.Add(Temp[I], nil);
    249     Temp[i].Free;
    250   end;
    251   ImgList.EndUpdate;
     222  try
     223    NewWidth := ScaleX(ImgList.Width, FromDPI.X);
     224    NewHeight := ScaleY(ImgList.Height, FromDPI.Y);
     225
     226    Temp := nil;
     227    SetLength(Temp, ImgList.Count);
     228    for I := 0 to ImgList.Count - 1 do
     229    begin
     230      TempBmp := TBitmap.Create;
     231      try
     232        TempBmp.PixelFormat := pf32bit;
     233        ImgList.GetBitmap(I, TempBmp);
     234        Temp[I] := TBitmap.Create;
     235        Temp[I].SetSize(NewWidth, NewHeight);
     236        {$IFDEF UNIX}
     237        Temp[I].PixelFormat := pf24bit;
     238        {$ELSE}
     239        Temp[I].PixelFormat := pf32bit;
     240        {$ENDIF}
     241        Temp[I].TransparentColor := TempBmp.TransparentColor;
     242        //Temp[I].TransparentMode := TempBmp.TransparentMode;
     243        Temp[I].Transparent := True;
     244        Temp[I].Canvas.Brush.Style := bsSolid;
     245        Temp[I].Canvas.Brush.Color := Temp[I].TransparentColor;
     246        Temp[I].Canvas.FillRect(0, 0, Temp[I].Width, Temp[I].Height);
     247
     248        if (Temp[I].Width = 0) or (Temp[I].Height = 0) then Continue;
     249        Temp[I].Canvas.StretchDraw(Rect(0, 0, Temp[I].Width, Temp[I].Height), TempBmp);
     250      finally
     251        TempBmp.Free;
     252      end;
     253    end;
     254
     255    ImgList.Clear;
     256    ImgList.Width := NewWidth;
     257    ImgList.Height := NewHeight;
     258
     259    for I := 0 to High(Temp) do
     260    begin
     261      ImgList.Add(Temp[I], nil);
     262      Temp[i].Free;
     263    end;
     264  finally
     265    ImgList.EndUpdate;
     266  end;
    252267end;
    253268
    … …  
    289304  //OldAutoSize: Boolean;
    290305begin
     306  //if not (Control is TCustomPage) then
     307  // Resize childs first
     308  if Control is TWinControl then begin
     309    WinControl := TWinControl(Control);
     310    if WinControl.ControlCount > 0 then begin
     311      for I := 0 to WinControl.ControlCount - 1 do begin
     312        if WinControl.Controls[I] is TControl then begin
     313          ScaleControl(WinControl.Controls[I], FromDPI);
     314        end;
     315      end;
     316    end;
     317  end;
     318
    291319  //if Control is TMemo then Exit;
    292320  //if Control is TForm then
    … …  
    314342  with TCoolBar(Control) do begin
    315343    BeginUpdate;
    316     for I := 0 to Bands.Count - 1 do
    317       with Bands[I] do begin
    318         MinWidth := ScaleX(MinWidth, FromDPI.X);
    319         MinHeight := ScaleY(MinHeight, FromDPI.Y);
    320         // Workaround to bad band width auto sizing
    321         //Width := ScaleX(Width, FromDPI.X);
    322         Width := ScaleX(Control.Width + 28, FromDPI.X);
    323         //Control.Invalidate;
     344    try
     345      for I := 0 to Bands.Count - 1 do
     346        with Bands[I] do begin
     347          MinWidth := ScaleX(MinWidth, FromDPI.X);
     348          MinHeight := ScaleY(MinHeight, FromDPI.Y);
     349          // Workaround to bad band width auto sizing
     350          //Width := ScaleX(Width, FromDPI.X);
     351          Width := ScaleX(Control.Width + 28, FromDPI.X);
     352          //Control.Invalidate;
     353        end;
     354      // Workaround for bad autosizing of coolbar
     355      if AutoSize then begin
     356        AutoSize := False;
     357        Height := ScaleY(Height, FromDPI.Y);
     358        AutoSize := True;
    324359      end;
    325     // Workaround for bad autosizing of coolbar
    326     if AutoSize then begin
    327       AutoSize := False;
    328       Height := ScaleY(Height, FromDPI.Y);
    329       AutoSize := True;
    330     end;
    331     EndUpdate;
     360    finally
     361      EndUpdate;
     362    end;
    332363  end;
    333364
    … …  
    340371  end;
    341372
    342   //if not (Control is TCustomPage) then
    343   if Control is TWinControl then begin
    344     WinControl := TWinControl(Control);
    345     if WinControl.ControlCount > 0 then begin
    346       for I := 0 to WinControl.ControlCount - 1 do begin
    347         if WinControl.Controls[I] is TControl then begin
    348           ScaleControl(WinControl.Controls[I], FromDPI);
    349         end;
    350       end;
    351     end;
    352   end;
    353373  //if Control is TForm then
    354374  //  Control.EnableAutoSizing;

  • trunk/Packages/Common/UTheme.pas

    r122 r131  
    55uses
    66  Classes, SysUtils, Graphics, ComCtrls, Controls, ExtCtrls, Menus, StdCtrls,
    7   Spin, Forms, Contnrs, Grids;
     7  Spin, Forms, fgl, Grids;
    88
    99type
    … …  
    1919  { TThemes }
    2020
    21   TThemes = class(TObjectList)
     21  TThemes = class(TFPGObjectList<TTheme>)
    2222    function AddNew(Name: string): TTheme;
    2323    function FindByName(Name: string): TTheme;
    … …  
    4141    property Theme: TTheme read FTheme write SetTheme;
    4242  end;
     43
     44const
     45  ThemeNameSystem = 'System';
     46  ThemeNameLight = 'Light';
     47  ThemeNameDark = 'Dark';
    4348
    4449procedure Register;
    … …  
    7479procedure TThemes.LoadToStrings(Strings: TStrings);
    7580var
    76   Theme: TTheme;
     81  I: Integer;
    7782begin
    78   Strings.Clear;
    79   for Theme in Self do
    80     Strings.AddObject(Theme.Name, Theme);
     83  Strings.BeginUpdate;
     84  try
     85    while Strings.Count < Count do Strings.Add('');
     86    while Strings.Count > Count do Strings.Delete(Strings.Count - 1);
     87    for I := 0 to Count - 1 do begin
     88      Strings[I] := Items[I].Name;
     89      Strings.Objects[I] := Items[I];
     90    end;
     91  finally
     92    Strings.EndUpdate;
     93  end;
    8194end;
    8295
    … …  
    97110  inherited;
    98111  Themes := TThemes.Create;
    99   with Themes.AddNew('System') do begin
     112  with Themes.AddNew(ThemeNameSystem) do begin
    100113    ColorWindow := clWindow;
    101114    ColorWindowText := clWindowText;
    … …  
    105118  end;
    106119  Theme := TTheme(Themes.First);
    107   with Themes.AddNew('Dark') do begin
     120  with Themes.AddNew(ThemeNameDark) do begin
    108121    ColorWindow := RGBToColor($20, $20, $20);
    109122    ColorWindowText := clWhite;
    … …  
    112125    ColorControlSelected := RGBToColor(96, 125, 155);
    113126  end;
    114   with Themes.AddNew('Light') do begin
     127  with Themes.AddNew(ThemeNameLight) do begin
    115128    ColorWindow := clWhite;
    116129    ColorWindowText := clBlack;
    … …  
    123136destructor TThemeManager.Destroy;
    124137begin
    125   Themes.Free;
    126   inherited Destroy;
     138  FreeAndNil(Themes);
     139  inherited;
    127140end;
    128141
    … …  
    167180procedure TThemeManager.UseTheme(Form: TForm);
    168181begin
    169   if not Used and (FTheme.Name = 'System') then Exit;
     182  if not Used and (FTheme.Name = ThemeNameSystem) then Exit;
    170183  ApplyTheme(Form);
    171184  Used := True;

  • trunk/Packages/Common/UThreading.pas

    r122 r131  
    66
    77uses
    8   Classes, SysUtils, Forms, Contnrs, SyncObjs;
     8  Classes, SysUtils, Forms, fgl, SyncObjs;
    99
    1010type
    … …  
    2222    function GetSuspended: Boolean; virtual; abstract;
    2323    function GetTerminated: Boolean; virtual; abstract;
    24     function GetThreadId: Integer; virtual; abstract;
     24    function GetThreadId: TThreadID; virtual; abstract;
    2525    procedure SetFreeOnTerminate(const AValue: Boolean); virtual; abstract;
    2626    procedure SetPriority(const AValue: TThreadPriority); virtual; abstract;
    … …  
    4242    property Terminated: Boolean read GetTerminated write SetTerminated;
    4343    property Finished: Boolean read GetFinished;
    44     property ThreadId: Integer read GetThreadId;
     44    property ThreadId: TThreadID read GetThreadId;
    4545  end;
    4646
    … …  
    6868    function GetSuspended: Boolean; override;
    6969    function GetTerminated: Boolean; override;
    70     function GetThreadId: Integer; override;
     70    function GetThreadId: TThreadID; override;
    7171    procedure SetFreeOnTerminate(const AValue: Boolean); override;
    7272    procedure SetPriority(const AValue: TThreadPriority); override;
    … …  
    102102  { TThreadList }
    103103
    104   TThreadList = class(TObjectList)
    105     function FindById(Id: Integer): TVirtualThread;
     104  TThreadList = class(TFPGObjectList<TVirtualThread>)
     105    function FindById(Id: TThreadID): TVirtualThread;
    106106    constructor Create; virtual;
    107107  end;
    … …  
    164164  if MainThreadID = ThreadID then Method
    165165  else begin
    166     Thread := ThreadList.FindById(ThreadID);
     166    try
     167      ThreadListLock.Acquire;
     168      Thread := ThreadList.FindById(ThreadID);
     169    finally
     170      ThreadListLock.Release;
     171    end;
    167172    if Assigned(Thread) then begin
    168173      Thread.Synchronize(Method);
    … …  
    173178{ TThreadList }
    174179
    175 function TThreadList.FindById(Id: Integer): TVirtualThread;
     180function TThreadList.FindById(Id: TThreadID): TVirtualThread;
    176181var
    177182  I: Integer;
    178183begin
    179184  I := 0;
    180   while (I < ThreadList.Count) and (TVirtualThread(ThreadList[I]).ThreadID <> Id) do
     185  while (I < ThreadList.Count) and (ThreadList[I].ThreadID <> Id) do
    181186    Inc(I);
    182   if I < ThreadList.Count then Result := TVirtualThread(ThreadList[I])
     187  if I < ThreadList.Count then Result := ThreadList[I]
    183188    else Result := nil;
    184189end;
    … …  
    233238end;
    234239
    235 function TListedThread.GetThreadId: Integer;
     240function TListedThread.GetThreadId: TThreadID;
    236241begin
    237242  Result := FThread.ThreadID;
    … …  
    356361ThreadListLock := TCriticalSection.Create;
    357362ThreadList := TThreadList.Create;
    358 ThreadList.OwnsObjects := False;
     363ThreadList.FreeObjects := False;
    359364
    360365finalization

  • trunk/Packages/Common/UXMLUtils.pas

    r122 r131  
    77uses
    88  {$IFDEF WINDOWS}Windows,{$ENDIF}
    9   Classes, SysUtils, DateUtils, DOM;
     9  Classes, SysUtils, DateUtils, DOM, xmlread;
    1010
    1111function XMLTimeToDateTime(XMLDateTime: string): TDateTime;
    … …  
    2121function ReadString(Node: TDOMNode; Name: string; DefaultValue: string): string;
    2222function ReadDateTime(Node: TDOMNode; Name: string; DefaultValue: TDateTime): TDateTime;
     23procedure ReadXMLFileParser(out Doc: TXMLDocument; FileName: string);
    2324
    2425
    2526implementation
     27
     28procedure ReadXMLFileParser(out Doc: TXMLDocument; FileName: string);
     29var
     30  Parser: TDOMParser;
     31  Src: TXMLInputSource;
     32  InFile: TFileStream;
     33begin
     34  try
     35    InFile := TFileStream.Create(FileName, fmOpenRead);
     36    Src := TXMLInputSource.Create(InFile);
     37    Parser := TDOMParser.Create;
     38    Parser.Options.PreserveWhitespace := True;
     39    Parser.Parse(Src, Doc);
     40  finally
     41    Src.Free;
     42    Parser.Free;
     43    InFile.Free;
     44  end;
     45end;
    2646
    2747function GetTimeZoneBias: Integer;
Note: See TracChangeset for help on using the changeset viewer.