Changeset 25 for trunk/Packages/Common


Ignore:
Timestamp:
Sep 10, 2022, 6:54:43 PM (2 years ago)
Author:
chronos
Message:
  • Modified: CoolTranslator replaced by Common package.
  • Modified: Update common package.
Location:
trunk/Packages/Common
Files:
32 added
8 deleted
25 edited

Legend:

Unmodified
Added
Removed

  • trunk/Packages/Common/Common.lpk

    r15 r25  
    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" idx5071="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="21">
     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="10"/>
     44    <Files Count="32">
    4345      <Item1>
    4446        <Filename Value="StopWatch.pas"/>
    … …  
    6062      <Item5>
    6163        <Filename Value="UPrefixMultiplier.pas"/>
     64        <HasRegisterProc Value="True"/>
    6265        <UnitName Value="UPrefixMultiplier"/>
    6366      </Item5>
    … …  
    134137        <UnitName Value="UTheme"/>
    135138      </Item21>
     139      <Item22>
     140        <Filename Value="UStringTable.pas"/>
     141        <UnitName Value="UStringTable"/>
     142      </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>
     173      <Item30>
     174        <Filename Value="UDataFile.pas"/>
     175        <UnitName Value="UDataFile"/>
     176      </Item30>
     177      <Item31>
     178        <Filename Value="UTestCase.pas"/>
     179        <UnitName Value="UTestCase"/>
     180      </Item31>
     181      <Item32>
     182        <Filename Value="UGenerics.pas"/>
     183        <UnitName Value="UGenerics"/>
     184      </Item32>
    136185    </Files>
     186    <CompatibilityMode Value="True"/>
    137187    <i18n>
    138188      <EnableI18N Value="True"/>
    … …  
    140190      <EnableI18NForLFM Value="True"/>
    141191    </i18n>
    142     <RequiredPkgs Count="3">
     192    <RequiredPkgs Count="2">
    143193      <Item1>
    144194        <PackageName Value="LCL"/>
    145195      </Item1>
    146196      <Item2>
    147         <PackageName Value="TemplateGenerics"/>
    148       </Item2>
    149       <Item3>
    150197        <PackageName Value="FCL"/>
    151198        <MinVersion Major="1" Valid="True"/>
    152       </Item3>
     199      </Item2>
    153200    </RequiredPkgs>
    154201    <UsageOptions>

  • trunk/Packages/Common/Common.pas

    r15 r25  
    55unit Common;
    66
     7{$warn 5023 off : no warning about unused units}
    78interface
    89
    910uses
    10   StopWatch, UCommon, UDebugLog, UDelay, UPrefixMultiplier, UURI, UThreading,
    11   UMemory, UResetableThread, UPool, ULastOpenedList, URegistry,
    12   UJobProgressView, UXMLUtils, UApplicationInfo, USyncCounter, UListViewSort,
    13   UPersistentForm, UFindFile, UScaleDPI, UTheme, LazarusPackageIntf;
     11  StopWatch, UCommon, UDebugLog, UDelay, UPrefixMultiplier, UURI, UThreading,
     12  UMemory, UResetableThread, UPool, ULastOpenedList, URegistry,
     13  UJobProgressView, UXMLUtils, UApplicationInfo, USyncCounter, UListViewSort,
     14  UPersistentForm, UFindFile, UScaleDPI, UTheme, UStringTable, UMetaCanvas,
     15  UGeometric, UTranslator, ULanguages, UFormAbout, UAboutDialog,
     16  UPixelPointer, UDataFile, UTestCase, UGenerics, LazarusPackageIntf;
    1417
    1518implementation
    … …  
    1821begin
    1922  RegisterUnit('UDebugLog', @UDebugLog.Register);
     23  RegisterUnit('UPrefixMultiplier', @UPrefixMultiplier.Register);
    2024  RegisterUnit('ULastOpenedList', @ULastOpenedList.Register);
    2125  RegisterUnit('UJobProgressView', @UJobProgressView.Register);
    … …  
    2630  RegisterUnit('UScaleDPI', @UScaleDPI.Register);
    2731  RegisterUnit('UTheme', @UTheme.Register);
     32  RegisterUnit('UTranslator', @UTranslator.Register);
     33  RegisterUnit('UAboutDialog', @UAboutDialog.Register);
    2834end;
    2935

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

    r11 r25  
    1111
    1212#: uthreading.scurrentthreadnotfound
     13#, object-pascal-format
    1314msgid "Current thread ID %d not found in virtual thread list."
    1415msgstr "Aktuální vlákno ID %d nenalezeno v seznamu virtuálních vláken."

  • trunk/Packages/Common/StopWatch.pas

    r10 r25  
    55
    66uses
    7   {$IFDEF Windows}Windows,{$ENDIF}
     7  {$IFDEF WINDOWS}Windows,{$ENDIF}
    88  SysUtils, DateUtils;
    99
    … …  
    3232  end;
    3333
     34
    3435implementation
    3536
    … …  
    4041  fIsRunning := False;
    4142
    42   {$IFDEF Windows}
     43  {$IFDEF WINDOWS}
    4344  fIsHighResolution := QueryPerformanceFrequency(fFrequency) ;
    4445  {$ELSE}

  • trunk/Packages/Common/UApplicationInfo.pas

    r20 r25  
    11unit UApplicationInfo;
    2 
    3 {$mode delphi}
    42
    53interface
    64
    75uses
    8   SysUtils, Classes, Forms, URegistry, LCLType;
     6  SysUtils, Classes, Forms, URegistry, Controls, Graphics, LCLType;
    97
    108type
    … …  
    1513  private
    1614    FDescription: TTranslateString;
     15    FIcon: TBitmap;
    1716    FIdentification: Byte;
    1817    FLicense: string;
    … …  
    3332  public
    3433    constructor Create(AOwner: TComponent); override;
     34    destructor Destroy; override;
    3535    property Version: string read GetVersion;
    3636    function GetRegistryContext: TRegistryContext;
    … …  
    4747    property EmailContact: string read FEmailContact write FEmailContact;
    4848    property AppName: string read FAppName write FAppName;
    49     property Description: string read FDescription write FDescription;
     49    property Description: TTranslateString read FDescription write FDescription;
    5050    property ReleaseDate: TDateTime read FReleaseDate write FReleaseDate;
    5151    property RegistryKey: string read FRegistryKey write FRegistryKey;
    5252    property RegistryRoot: TRegistryRoot read FRegistryRoot write FRegistryRoot;
    5353    property License: string read FLicense write FLicense;
     54    property Icon: TBitmap read FIcon write FIcon;
    5455  end;
    5556
    5657procedure Register;
    5758
     59
    5860implementation
    59                        
     61
    6062procedure Register;
    6163begin
    … …  
    7476constructor TApplicationInfo.Create(AOwner: TComponent);
    7577begin
    76   inherited Create(AOwner);
     78  inherited;
    7779  FVersionMajor := 1;
    7880  FIdentification := 1;
    … …  
    8082  FRegistryKey := '\Software\' + FAppName;
    8183  FRegistryRoot := rrKeyCurrentUser;
     84  FIcon := TBitmap.Create;
     85end;
     86
     87destructor TApplicationInfo.Destroy;
     88begin
     89  FreeAndNil(FIcon);
     90  inherited;
    8291end;
    8392

  • trunk/Packages/Common/UCommon.pas

    r15 r25  
    11unit UCommon;
    22
    3 {$mode delphi}
    4 
    53interface
    64
    75uses
    8   {$ifdef Windows}Windows,{$endif}
    9   {$ifdef Linux}baseunix,{$endif}
    10   Classes, SysUtils, StrUtils, Dialogs, Process, LCLIntf,
    11   FileUtil; //, ShFolder, ShellAPI;
     6  {$IFDEF WINDOWS}Windows,{$ENDIF}
     7  {$IFDEF UNIX}baseunix,{$ENDIF}
     8  Classes, SysUtils, StrUtils, Dialogs, Process, LCLIntf, Graphics,
     9  FileUtil, Generics.Collections; //, ShFolder, ShellAPI;
    1210
    1311type
    1412  TArrayOfByte = array of Byte;
    15   TArrayOfString = array of string;
    1613  TExceptionEvent = procedure(Sender: TObject; E: Exception) of object;
    1714
    … …  
    2825    unfDNSDomainName = 11);
    2926
     27  TFilterMethod = function (FileName: string): Boolean of object;
     28  TFileNameMethod = procedure (FileName: string) of object;
     29
    3030var
    3131  ExceptionHandler: TExceptionEvent;
    3232  DLLHandle1: HModule;
    3333
    34 {$IFDEF Windows}
    35   GetUserNameEx: procedure (NameFormat: DWORD;
    36     lpNameBuffer: LPSTR; nSize: PULONG); stdcall;
    37 {$ENDIF}
    38 
    39 function IntToBin(Data: Int64; Count: Byte): string;
     34  {$IFDEF WINDOWS}
     35    GetUserNameEx: procedure (NameFormat: DWORD;
     36      lpNameBuffer: LPSTR; nSize: PULONG); stdcall;
     37  {$ENDIF}
     38
     39const
     40  clLightBlue = TColor($FF8080);
     41  clLightGreen = TColor($80FF80);
     42  clLightRed = TColor($8080FF);
     43
     44function AddLeadingZeroes(const aNumber, Length : integer) : string;
    4045function BinToInt(BinStr: string): Int64;
    41 function TryHexToInt(Data: string; var Value: Integer): Boolean;
    42 function TryBinToInt(Data: string; var Value: Integer): Boolean;
    4346function BinToHexString(Source: AnsiString): string;
    4447//function DelTree(DirName : string): Boolean;
    … …  
    4649function BCDToInt(Value: Byte): Byte;
    4750function CompareByteArray(Data1, Data2: TArrayOfByte): Boolean;
     51procedure CopyStringArray(Dest: TStringArray; Source: array of string);
     52function CombinePaths(Path1, Path2: string): string;
     53function ComputerName: string;
     54procedure DeleteFiles(APath, AFileSpec: string);
     55function Explode(Separator: Char; Data: string): TStringArray;
     56procedure ExecuteProgram(Executable: string; Parameters: array of string);
     57procedure FileDialogUpdateFilterFileType(FileDialog: TOpenDialog);
     58procedure FreeThenNil(var Obj);
     59function GetDirCount(Dir: string): Integer;
    4860function GetUserName: string;
    49 function LoggedOnUserNameEx(Format: TUserNameFormat): string;
    50 function SplitString(var Text: string; Count: Word): string;
    5161function GetBitCount(Variable: QWord; MaxIndex: Integer): Integer;
    5262function GetBit(Variable: QWord; Index: Byte): Boolean;
     63function GetStringPart(var Text: string; Separator: string): string;
     64function GenerateNewName(OldName: string): string;
     65function GetFileFilterItemExt(Filter: string; Index: Integer): string;
     66function IntToBin(Data: Int64; Count: Byte): string;
     67function Implode(Separator: Char; List: TList<string>): string;
     68function LastPos(const SubStr: String; const S: String): Integer;
     69function LoadFileToStr(const FileName: TFileName): AnsiString;
     70function LoggedOnUserNameEx(Format: TUserNameFormat): string;
     71function MergeArray(A, B: array of string): TStringArray;
     72function OccurenceOfChar(What: Char; Where: string): Integer;
     73procedure OpenWebPage(URL: string);
     74procedure OpenEmail(Email: string);
     75procedure OpenFileInShell(FileName: string);
     76function PosFromIndex(SubStr: string; Text: string;
     77  StartIndex: Integer): Integer;
     78function PosFromIndexReverse(SubStr: string; Text: string;
     79  StartIndex: Integer): Integer;
     80function RemoveQuotes(Text: string): string;
     81procedure SaveStringToFile(S, FileName: string);
    5382procedure SetBit(var Variable: Int64; Index: Byte; State: Boolean); overload;
    5483procedure SetBit(var Variable: QWord; Index: Byte; State: Boolean); overload;
    5584procedure SetBit(var Variable: Cardinal; Index: Byte; State: Boolean); overload;
    5685procedure SetBit(var Variable: Word; Index: Byte; State: Boolean); overload;
    57 function AddLeadingZeroes(const aNumber, Length : integer) : string;
    58 function LastPos(const SubStr: String; const S: String): Integer;
    59 function GenerateNewName(OldName: string): string;
    60 function GetFileFilterItemExt(Filter: string; Index: Integer): string;
    61 procedure FileDialogUpdateFilterFileType(FileDialog: TOpenDialog);
    62 procedure DeleteFiles(APath, AFileSpec: string);
    63 procedure OpenWebPage(URL: string);
    64 procedure OpenFileInShell(FileName: string);
    65 procedure ExecuteProgram(Executable: string; Parameters: array of string);
    66 procedure FreeThenNil(var Obj);
    67 function RemoveQuotes(Text: string): string;
    68 function ComputerName: string;
    69 function OccurenceOfChar(What: Char; Where: string): Integer;
    70 function GetDirCount(Dir: string): Integer;
    71 function MergeArray(A, B: array of string): TArrayOfString;
    72 function LoadFileToStr(const FileName: TFileName): AnsiString;
     86procedure SearchFiles(AList: TStrings; Dir: string;
     87  FilterMethod: TFilterMethod = nil; FileNameMethod: TFileNameMethod = nil);
     88function SplitString(var Text: string; Count: Word): string;
     89function StripTags(const S: string): string;
     90function TryHexToInt(Data: string; out Value: Integer): Boolean;
     91function TryBinToInt(Data: string; out Value: Integer): Boolean;
     92procedure SortStrings(Strings: TStrings);
    7393
    7494
    … …  
    98118  I: Integer;
    99119begin
     120  Result := '';
    100121  for I := 1 to Length(Source) do begin
    101122    Result := Result + LowerCase(IntToHex(Ord(Source[I]), 2));
    … …  
    230251end;
    231252
    232 function TryHexToInt(Data: string; var Value: Integer): Boolean;
     253function TryHexToInt(Data: string; out Value: Integer): Boolean;
    233254var
    234255  I: Integer;
    … …  
    246267end;
    247268
    248 function TryBinToInt(Data: string; var Value: Integer): Boolean;
     269function TryBinToInt(Data: string; out Value: Integer): Boolean;
    249270var
    250271  I: Integer;
    … …  
    274295end;
    275296
    276 function Explode(Separator: char; Data: string): TArrayOfString;
    277 begin
    278   SetLength(Result, 0);
    279   while Pos(Separator, Data) > 0 do begin
     297function Explode(Separator: Char; Data: string): TStringArray;
     298var
     299  Index: Integer;
     300begin
     301  Result := Default(TStringArray);
     302  repeat
     303    Index := Pos(Separator, Data);
     304    if Index > 0 then begin
     305      SetLength(Result, Length(Result) + 1);
     306      Result[High(Result)] := Copy(Data, 1, Index - 1);
     307      Delete(Data, 1, Index);
     308    end else Break;
     309  until False;
     310  if Data <> '' then begin
    280311    SetLength(Result, Length(Result) + 1);
    281     Result[High(Result)] := Copy(Data, 1, Pos(Separator, Data) - 1);
    282     Delete(Data, 1, Pos(Separator, Data));
    283   end;
    284   SetLength(Result, Length(Result) + 1);
    285   Result[High(Result)] := Data;
    286 end;
    287 
    288 {$IFDEF Windows}
     312    Result[High(Result)] := Data;
     313  end;
     314end;
     315
     316function Implode(Separator: Char; List: TList<string>): string;
     317var
     318  I: Integer;
     319begin
     320  Result := '';
     321  for I := 0 to List.Count - 1 do begin
     322    Result := Result + List[I];
     323    if I < List.Count - 1 then Result := Result + Separator;
     324  end;
     325end;
     326
     327{$IFDEF WINDOWS}
    289328function GetUserName: string;
    290329const
    … …  
    294333begin
    295334  L := MAX_USERNAME_LENGTH + 2;
     335  Result := Default(string);
    296336  SetLength(Result, L);
    297337  if Windows.GetUserName(PChar(Result), L) and (L > 0) then begin
    … …  
    307347  end;
    308348end;
    309 {$endif}
     349{$ENDIF}
    310350
    311351function ComputerName: string;
    312 {$ifdef mswindows}
     352{$IFDEF WINDOWS}
    313353const
    314354 INFO_BUFFER_SIZE = 32767;
    … …  
    325365  end;
    326366end;
    327 {$endif}
    328 {$ifdef unix}
     367{$ENDIF}
     368{$IFDEF UNIX}
    329369var
    330370  Name: UtsName;
    331371begin
     372  Name := Default(UtsName);
    332373  fpuname(Name);
    333374  Result := Name.Nodename;
    334375end;
    335 {$endif}
    336 
    337 {$ifdef windows}
     376{$ENDIF}
     377
     378{$IFDEF WINDOWS}
    338379function LoggedOnUserNameEx(Format: TUserNameFormat): string;
    339380const
    … …  
    413454procedure LoadLibraries;
    414455begin
    415   {$IFDEF Windows}
     456  {$IFDEF WINDOWS}
    416457  DLLHandle1 := LoadLibrary('secur32.dll');
    417458  if DLLHandle1 <> 0 then
    … …  
    424465procedure FreeLibraries;
    425466begin
    426   {$IFDEF Windows}
     467  {$IFDEF WINDOWS}
    427468  if DLLHandle1 <> 0 then FreeLibrary(DLLHandle1);
    428469  {$ENDIF}
    … …  
    457498end;
    458499
     500procedure OpenEmail(Email: string);
     501begin
     502  OpenURL('mailto:' + Email);
     503end;
     504
    459505procedure OpenFileInShell(FileName: string);
    460506begin
    … …  
    485531end;
    486532
    487 function MergeArray(A, B: array of string): TArrayOfString;
    488 var
    489   I: Integer;
    490 begin
     533function MergeArray(A, B: array of string): TStringArray;
     534var
     535  I: Integer;
     536begin
     537  Result := Default(TStringArray);
    491538  SetLength(Result, Length(A) + Length(B));
    492539  for I := 0 to Length(A) - 1 do
    … …  
    514561end;
    515562
     563function DefaultSearchFilter(const FileName: string): Boolean;
     564begin
     565  Result := True;
     566end;
     567
     568procedure SaveStringToFile(S, FileName: string);
     569var
     570  F: TextFile;
     571begin
     572  AssignFile(F, FileName);
     573  try
     574    ReWrite(F);
     575    Write(F, S);
     576  finally
     577    CloseFile(F);
     578  end;
     579end;
     580
     581procedure SearchFiles(AList: TStrings; Dir: string;
     582  FilterMethod: TFilterMethod = nil; FileNameMethod: TFileNameMethod = nil);
     583var
     584  SR: TSearchRec;
     585begin
     586  Dir := IncludeTrailingPathDelimiter(Dir);
     587  if FindFirst(Dir + '*', faAnyFile, SR) = 0 then
     588    try
     589      repeat
     590        if (SR.Name = '.') or (SR.Name = '..') or (Assigned(FilterMethod) and (not FilterMethod(SR.Name) or
     591          not FilterMethod(Copy(Dir, 3, Length(Dir)) + SR.Name))) then Continue;
     592        if Assigned(FileNameMethod) then
     593          FileNameMethod(Dir + SR.Name);
     594        AList.Add(Dir + SR.Name);
     595        if (SR.Attr and faDirectory) <> 0 then
     596          SearchFiles(AList, Dir + SR.Name, FilterMethod);
     597      until FindNext(SR) <> 0;
     598    finally
     599      FindClose(SR);
     600    end;
     601end;
     602
     603function GetStringPart(var Text: string; Separator: string): string;
     604var
     605  P: Integer;
     606begin
     607  P := Pos(Separator, Text);
     608  if P > 0 then begin
     609    Result := Copy(Text, 1, P - 1);
     610    Delete(Text, 1, P - 1 + Length(Separator));
     611  end else begin
     612    Result := Text;
     613    Text := '';
     614  end;
     615  Result := Trim(Result);
     616  Text := Trim(Text);
     617end;
     618
     619function StripTags(const S: string): string;
     620var
     621  Len: Integer;
     622
     623  function ReadUntil(const ReadFrom: Integer; const C: Char): Integer;
     624  var
     625    J: Integer;
     626  begin
     627    for J := ReadFrom to Len do
     628      if (S[j] = C) then
     629      begin
     630        Result := J;
     631        Exit;
     632      end;
     633    Result := Len + 1;
     634  end;
     635
     636var
     637  I, APos: Integer;
     638begin
     639  Len := Length(S);
     640  I := 0;
     641  Result := '';
     642  while (I <= Len) do begin
     643    Inc(I);
     644    APos := ReadUntil(I, '<');
     645    Result := Result + Copy(S, I, APos - i);
     646    I := ReadUntil(APos + 1, '>');
     647  end;
     648end;
     649
     650function PosFromIndex(SubStr: string; Text: string;
     651  StartIndex: Integer): Integer;
     652var
     653  I, MaxLen: SizeInt;
     654  Ptr: PAnsiChar;
     655begin
     656  Result := 0;
     657  if (StartIndex < 1) or (StartIndex > Length(Text) - Length(SubStr)) then Exit;
     658  if Length(SubStr) > 0 then begin
     659    MaxLen := Length(Text) - Length(SubStr) + 1;
     660    I := StartIndex;
     661    Ptr := @Text[StartIndex];
     662    while (I <= MaxLen) do begin
     663      if (SubStr[1] = Ptr^) and (CompareByte(Substr[1], Ptr^, Length(SubStr)) = 0) then begin
     664        Result := I;
     665        Exit;
     666      end;
     667      Inc(I);
     668      Inc(Ptr);
     669    end;
     670  end;
     671end;
     672
     673function PosFromIndexReverse(SubStr: string; Text: string;
     674  StartIndex: Integer): Integer;
     675var
     676  I: SizeInt;
     677  Ptr: PAnsiChar;
     678begin
     679  Result := 0;
     680  if (StartIndex < 1) or (StartIndex > Length(Text)) then Exit;
     681  if Length(SubStr) > 0 then begin
     682    I := StartIndex;
     683    Ptr := @Text[StartIndex];
     684    while (I > 0) do begin
     685      if (SubStr[1] = Ptr^) and (CompareByte(Substr[1], Ptr^, Length(SubStr)) = 0) then begin
     686        Result := I;
     687        Exit;
     688      end;
     689      Dec(I);
     690      Dec(Ptr);
     691    end;
     692  end;
     693end;
     694
     695procedure CopyStringArray(Dest: TStringArray; Source: array of string);
     696var
     697  I: Integer;
     698begin
     699  SetLength(Dest, Length(Source));
     700  for I := 0 to Length(Dest) - 1 do
     701    Dest[I] := Source[I];
     702end;
     703
     704function CombinePaths(Path1, Path2: string): string;
     705begin
     706  Result := Path1;
     707  if Result <> '' then Result := Result + DirectorySeparator + Path2
     708    else Result := Path2;
     709end;
     710
     711procedure SortStrings(Strings: TStrings);
     712var
     713  Tmp: TStringList;
     714begin
     715  Strings.BeginUpdate;
     716  try
     717    if Strings is TStringList then begin
     718      TStringList(Strings).Sort;
     719    end else begin
     720      Tmp := TStringList.Create;
     721      try
     722        Tmp.Assign(Strings);
     723        Tmp.Sort;
     724        Strings.Assign(Tmp);
     725      finally
     726        Tmp.Free;
     727      end;
     728    end;
     729  finally
     730    Strings.EndUpdate;
     731  end;
     732end;
    516733
    517734

  • trunk/Packages/Common/UDebugLog.pas

    r15 r25  
    11unit UDebugLog;
    2 
    3 {$mode delphi}
    42
    53interface
    64
    75uses
    8   Classes, SysUtils, FileUtil, SpecializedList, SyncObjs;
     6  Classes, SysUtils, FileUtil, Generics.Collections, SyncObjs;
    97
    108type
    … …  
    1513    Group: string;
    1614    Text: string;
     15  end;
     16
     17  TDebugLogItems = class(TObjectList<TDebugLogItem>)
    1718  end;
    1819
    … …  
    2930    procedure SetMaxCount(const AValue: Integer);
    3031  public
    31     Items: TListObject;
     32    Items: TDebugLogItems;
    3233    Lock: TCriticalSection;
    3334    procedure Add(Text: string; Group: string = '');
    … …  
    4445
    4546procedure Register;
     47
    4648
    4749implementation
    … …  
    104106    if ExtractFileDir(FileName) <> '' then
    105107      ForceDirectories(ExtractFileDir(FileName));
    106     if FileExists(FileName) then LogFile := TFileStream.Create(UTF8Decode(FileName), fmOpenWrite)
    107       else LogFile := TFileStream.Create(UTF8Decode(FileName), fmCreate);
     108    if FileExists(FileName) then LogFile := TFileStream.Create(FileName, fmOpenWrite)
     109      else LogFile := TFileStream.Create(FileName, fmCreate);
    108110    LogFile.Seek(0, soFromEnd);
    109111    Text := FormatDateTime('hh:nn:ss.zzz', Now) + ': ' + Text + LineEnding;
    … …  
    117119begin
    118120  inherited;
    119   Items := TListObject.Create;
     121  Items := TDebugLogItems.Create;
    120122  Lock := TCriticalSection.Create;
    121123  MaxCount := 100;
    … …  
    126128destructor TDebugLog.Destroy;
    127129begin
    128   Items.Free;
    129   Lock.Free;
     130  FreeAndNil(Items);
     131  FreeAndNil(Lock);
    130132  inherited;
    131133end;

  • trunk/Packages/Common/UDelay.pas

    r10 r25  
    11unit UDelay;
    2 
    3 {$mode delphi}
    42
    53interface

  • trunk/Packages/Common/UFindFile.pas

    r15 r25  
    2424
    2525uses
    26   SysUtils, Classes, Graphics, Controls, Forms, Dialogs, FileCtrl;
     26  SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
    2727
    2828type
    … …  
    3535  private
    3636    s : TStringList;
    37 
    3837    fSubFolder : boolean;
    3938    fAttr: TFileAttrib;
    4039    fPath : string;
    4140    fFileMask : string;
    42 
    4341    procedure SetPath(Value: string);
    4442    procedure FileSearch(const inPath : string);
    … …  
    4644    constructor Create(AOwner: TComponent); override;
    4745    destructor Destroy; override;
    48 
    4946    function SearchForFiles: TStringList;
    5047  published
    … …  
    5956  FilterAll = '*.*';
    6057{$ENDIF}
    61 {$IFDEF LINUX}
     58{$IFDEF UNIX}
    6259  FilterAll = '*';
    6360{$ENDIF}
    6461
    6562procedure Register;
     63
    6664
    6765implementation
    … …  
    8785begin
    8886  s.Free;
    89   inherited Destroy;
     87  inherited;
    9088end;
    9189
    … …  
    117115  Attr := 0;
    118116  if ffaReadOnly in FileAttr then Attr := Attr + faReadOnly;
    119   if ffaHidden in FileAttr then Attr := Attr + faHidden;
    120   if ffaSysFile in FileAttr then Attr := Attr + faSysFile;
    121   if ffaVolumeID in FileAttr then Attr := Attr + faVolumeID;
     117  if ffaHidden in FileAttr then Attr := Attr + 2; //faHidden; use constant to avoid platform warning
     118  if ffaSysFile in FileAttr then Attr := Attr + 4; //faSysFile; use constant to avoid platform warning
     119  // Deprecated: if ffaVolumeID in FileAttr then Attr := Attr + faVolumeID;
    122120  if ffaDirectory in FileAttr then Attr := Attr + faDirectory;
    123121  if ffaArchive in FileAttr then Attr := Attr + faArchive;
    124122  if ffaAnyFile in FileAttr then Attr := Attr + faAnyFile;
    125123
    126   if SysUtils.FindFirst(UTF8Decode(inPath + FileMask), Attr, Rec) = 0 then
     124  if SysUtils.FindFirst(inPath + FileMask, Attr, Rec) = 0 then
    127125  try
    128126    repeat
    129       s.Add(inPath + UTF8Encode(Rec.Name));
     127      s.Add(inPath + Rec.Name);
    130128    until SysUtils.FindNext(Rec) <> 0;
    131129  finally
    … …  
    135133  If not InSubFolders then Exit;
    136134
    137   if SysUtils.FindFirst(UTF8Decode(inPath + FilterAll), faDirectory, Rec) = 0 then
     135  if SysUtils.FindFirst(inPath + FilterAll, faDirectory, Rec) = 0 then
    138136  try
    139137    repeat
    140138      if ((Rec.Attr and faDirectory) > 0) and (Rec.Name <> '.')
    141139      and (Rec.Name <> '..') then
    142         FileSearch(IncludeTrailingBackslash(inPath + UTF8Encode(Rec.Name)));
     140        FileSearch(IncludeTrailingBackslash(inPath + Rec.Name));
    143141    until SysUtils.FindNext(Rec) <> 0;
    144142  finally

  • trunk/Packages/Common/UJobProgressView.lfm

    r15 r25  
    11object FormJobProgressView: TFormJobProgressView
    22  Left = 467
    3   Height = 246
     3  Height = 414
    44  Top = 252
    5   Width = 328
     5  Width = 647
    66  BorderIcons = [biSystemMenu]
    7   ClientHeight = 246
    8   ClientWidth = 328
    9   Font.Height = -11
    10   Font.Name = 'MS Sans Serif'
     7  ClientHeight = 414
     8  ClientWidth = 647
     9  DesignTimePPI = 144
    1110  OnClose = FormClose
    1211  OnCloseQuery = FormCloseQuery
    1312  OnCreate = FormCreate
    14   OnDestroy = FormDestroy
     13  OnHide = FormHide
     14  OnShow = FormShow
    1515  Position = poScreenCenter
    16   LCLVersion = '1.6.0.4'
     16  LCLVersion = '2.2.0.4'
    1717  object PanelOperationsTitle: TPanel
    1818    Left = 0
    19     Height = 24
     19    Height = 38
    2020    Top = 0
    21     Width = 328
     21    Width = 647
    2222    Align = alTop
    2323    BevelOuter = bvNone
    24     ClientHeight = 24
    25     ClientWidth = 328
     24    ClientHeight = 38
     25    ClientWidth = 647
    2626    FullRepaint = False
    2727    TabOrder = 0
    2828    object LabelOperation: TLabel
    29       Left = 8
    30       Height = 13
    31       Top = 8
    32       Width = 66
     29      Left = 10
     30      Height = 26
     31      Top = 10
     32      Width = 99
    3333      Caption = 'Operations:'
    34       Font.Height = -11
    35       Font.Name = 'MS Sans Serif'
    36       Font.Style = [fsBold]
    37       ParentColor = False
    3834      ParentFont = False
    3935    end
    … …  
    4137  object PanelLog: TPanel
    4238    Left = 0
    43     Height = 122
    44     Top = 124
    45     Width = 328
     39    Height = 161
     40    Top = 253
     41    Width = 647
    4642    Align = alClient
    4743    BevelOuter = bvSpace
    48     ClientHeight = 122
    49     ClientWidth = 328
     44    ClientHeight = 161
     45    ClientWidth = 647
    5046    TabOrder = 1
    5147    object MemoLog: TMemo
    52       Left = 8
    53       Height = 106
    54       Top = 8
    55       Width = 312
     48      Left = 10
     49      Height = 141
     50      Top = 10
     51      Width = 627
    5652      Anchors = [akTop, akLeft, akRight, akBottom]
    5753      ReadOnly = True
    … …  
    6258  object PanelProgress: TPanel
    6359    Left = 0
    64     Height = 38
    65     Top = 50
    66     Width = 328
     60    Height = 65
     61    Top = 126
     62    Width = 647
    6763    Align = alTop
    6864    BevelOuter = bvNone
    69     ClientHeight = 38
    70     ClientWidth = 328
     65    ClientHeight = 65
     66    ClientWidth = 647
    7167    TabOrder = 2
    7268    object ProgressBarPart: TProgressBar
    73       Left = 8
    74       Height = 17
    75       Top = 16
    76       Width = 312
     69      Left = 12
     70      Height = 29
     71      Top = 29
     72      Width = 628
    7773      Anchors = [akTop, akLeft, akRight]
    7874      TabOrder = 0
    7975    end
    8076    object LabelEstimatedTimePart: TLabel
    81       Left = 8
    82       Height = 13
     77      Left = 10
     78      Height = 26
    8379      Top = -2
    84       Width = 71
     80      Width = 132
    8581      Caption = 'Estimated time:'
    86       ParentColor = False
    8782    end
    8883  end
    8984  object PanelOperations: TPanel
    9085    Left = 0
    91     Height = 26
    92     Top = 24
    93     Width = 328
     86    Height = 50
     87    Top = 76
     88    Width = 647
    9489    Align = alTop
    9590    BevelOuter = bvNone
    96     ClientHeight = 26
    97     ClientWidth = 328
     91    ClientHeight = 50
     92    ClientWidth = 647
    9893    FullRepaint = False
    9994    TabOrder = 3
    10095    object ListViewJobs: TListView
    101       Left = 8
    102       Height = 16
    103       Top = 5
    104       Width = 312
     96      Left = 10
     97      Height = 38
     98      Top = 6
     99      Width = 627
    105100      Anchors = [akTop, akLeft, akRight, akBottom]
    106101      AutoWidthLastColumn = True
    … …  
    109104      Columns = <     
    110105        item
    111           Width = 312
     106          Width = 614
    112107        end>
    113108      OwnerData = True
    … …  
    122117  object PanelProgressTotal: TPanel
    123118    Left = 0
    124     Height = 36
    125     Top = 88
    126     Width = 328
     119    Height = 62
     120    Top = 191
     121    Width = 647
    127122    Align = alTop
    128123    BevelOuter = bvNone
    129     ClientHeight = 36
    130     ClientWidth = 328
     124    ClientHeight = 62
     125    ClientWidth = 647
    131126    TabOrder = 4
    132127    object LabelEstimatedTimeTotal: TLabel
    133       Left = 8
    134       Height = 13
     128      Left = 10
     129      Height = 26
    135130      Top = 0
    136       Width = 97
     131      Width = 178
    137132      Caption = 'Total estimated time:'
    138       ParentColor = False
    139133    end
    140134    object ProgressBarTotal: TProgressBar
    141       Left = 8
    142       Height = 16
    143       Top = 16
    144       Width = 312
     135      Left = 10
     136      Height = 29
     137      Top = 29
     138      Width = 627
    145139      Anchors = [akTop, akLeft, akRight]
    146140      TabOrder = 0
    147141    end
    148142  end
     143  object PanelText: TPanel
     144    Left = 0
     145    Height = 38
     146    Top = 38
     147    Width = 647
     148    Align = alTop
     149    BevelOuter = bvNone
     150    ClientHeight = 38
     151    ClientWidth = 647
     152    TabOrder = 5
     153    object LabelText: TLabel
     154      Left = 10
     155      Height = 29
     156      Top = 10
     157      Width = 630
     158      Anchors = [akTop, akLeft, akRight]
     159      AutoSize = False
     160    end
     161  end
    149162  object ImageList1: TImageList
    150     BkColor = clForeground
    151     left = 200
    152     top = 8
     163    Left = 240
     164    Top = 10
    153165    Bitmap = {
    154       4C69020000001000000010000000FF00FF00FF00FF00FF00FF00FF00FF00FF00
    155       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    156       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    157       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    158       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    159       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    160       FF00000000FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    161       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF000000
    162       00FF000000FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    163       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF0000
    164       00FF000000FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    165       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF0000
    166       00FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    167       FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FF0000
    168       00FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FFFF00FF00FF00
    169       FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FF000000FFFF00
    170       FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FFFF00
    171       FF00FF00FF00FF00FF00000000FF000000FF000000FF000000FFFF00FF00FF00
    172       FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FF0000
    173       00FFFF00FF00000000FF000000FF000000FF000000FFFF00FF00FF00FF00FF00
    174       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF0000
    175       00FF000000FF000000FF000000FF000000FFFF00FF00FF00FF00FF00FF00FF00
    176       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF0000
    177       00FF000000FF000000FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00
    178       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF000000
    179       00FF000000FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    180       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    181       FF00000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    182       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    183       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    184       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    185       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    186       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    187       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    188       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    189       FF00FF00FF00FF00FF00FF00FF00000000FFFF00FF00FF00FF00FF00FF00FF00
    190       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    191       FF00FF00FF00FF00FF00FF00FF00000000FF000000FFFF00FF00FF00FF00FF00
    192       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    193       FF00FF00FF00FF00FF00FF00FF00000000FF000084FF000000FFFF00FF00FF00
    194       FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FF0000
    195       00FF000000FF000000FF000000FF000000FF0000FFFF000084FF000000FFFF00
    196       FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF0000FFFF0000FFFF0000
    197       FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF000084FF0000
    198       00FFFF00FF00FF00FF00FF00FF00FF00FF00000000FF0000FFFF0000FFFF0000
    199       FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000
    200       84FF000000FFFF00FF00FF00FF00FF00FF00000000FF0000FFFF0000FFFF0000
    201       FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000
    202       FFFF000084FF000000FFFF00FF00FF00FF00000000FF0000FFFF0000FFFF0000
    203       FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000
    204       84FF000000FFFF00FF00FF00FF00FF00FF00000000FF0000FFFF0000FFFF0000
    205       FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF000084FF0000
    206       00FFFF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FF0000
    207       00FF000000FF000000FF000000FF000000FF0000FFFF000084FF000000FFFF00
    208       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    209       FF00FF00FF00FF00FF00FF00FF00000000FF000084FF000000FFFF00FF00FF00
    210       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    211       FF00FF00FF00FF00FF00FF00FF00000000FF000000FFFF00FF00FF00FF00FF00
    212       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    213       FF00FF00FF00FF00FF00FF00FF00000000FFFF00FF00FF00FF00FF00FF00FF00
    214       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    215       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    216       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    217       FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
    218       FF00FF00FF00FF00FF00FF00FF00
     166      4C7A0200000010000000100000006A0000000000000078DAE593490E00100C45
     167      7B78F72E5684A63A1142C382BE4F0708F89C955117F4B016BE67B5FC6E96DB97
     168      B0D4B9F4CD949F36DED1DF922B0F1BD11FAB5AFC68DE5C44D40220A9FA779EC8
     169      6A349FD5A435E43CADA1E3678D73F773F1DBF3EFADFFEEFEBBF97F6696BE9D36
    219170    }
    220171  end
    … …  
    223174    Interval = 100
    224175    OnTimer = TimerUpdateTimer
    225     left = 264
    226     top = 8
     176    Left = 384
     177    Top = 10
    227178  end
    228179end

  • trunk/Packages/Common/UJobProgressView.pas

    r15 r25  
    11unit UJobProgressView;
    2 
    3 {$MODE Delphi}
    42
    53interface
    … …  
    75uses
    86  SysUtils, Variants, Classes, Graphics, Controls, Forms, Syncobjs,
    9   Dialogs, ComCtrls, StdCtrls, ExtCtrls, Contnrs, UThreading,
     7  Dialogs, ComCtrls, StdCtrls, ExtCtrls, Generics.Collections, UThreading, Math,
    108  DateUtils;
    119
    … …  
    1311  EstimatedTimeShowTreshold = 4;
    1412  EstimatedTimeShowTresholdTotal = 1;
    15   MemoLogHeight = 200;
    1613  UpdateInterval = 100; // ms
    1714
    … …  
    2421    FLock: TCriticalSection;
    2522    FOnChange: TNotifyEvent;
     23    FText: string;
    2624    FValue: Integer;
    2725    FMax: Integer;
    2826    procedure SetMax(const AValue: Integer);
     27    procedure SetText(AValue: string);
    2928    procedure SetValue(const AValue: Integer);
    3029  public
    … …  
    3534    property Value: Integer read FValue write SetValue;
    3635    property Max: Integer read FMax write SetMax;
     36    property Text: string read FText write SetText;
    3737    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    3838  end;
    … …  
    6969  end;
    7070
     71  TJobs = class(TObjectList<TJob>)
     72  end;
     73
    7174  TJobThread = class(TListedThread)
    7275    procedure Execute; override;
    … …  
    8083  TFormJobProgressView = class(TForm)
    8184    ImageList1: TImageList;
     85    LabelText: TLabel;
    8286    Label2: TLabel;
    8387    LabelOperation: TLabel;
    … …  
    8690    ListViewJobs: TListView;
    8791    MemoLog: TMemo;
     92    PanelText: TPanel;
    8893    PanelProgressTotal: TPanel;
    8994    PanelOperationsTitle: TPanel;
    … …  
    9499    ProgressBarTotal: TProgressBar;
    95100    TimerUpdate: TTimer;
     101    procedure FormHide(Sender: TObject);
     102    procedure FormShow(Sender: TObject);
     103    procedure ReloadJobList;
    96104    procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
    97     procedure FormDestroy(Sender: TObject);
    98105    procedure ListViewJobsData(Sender: TObject; Item: TListItem);
    99106    procedure TimerUpdateTimer(Sender: TObject);
    100107    procedure FormCreate(Sender: TObject);
    101108    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
     109    procedure UpdateHeight;
    102110  public
    103111    JobProgressView: TJobProgressView;
    … …  
    118126    TotalStartTime: TDateTime;
    119127    Log: TStringList;
     128    FForm: TFormJobProgressView;
    120129    procedure SetTerminate(const AValue: Boolean);
    121130    procedure UpdateProgress;
    122     procedure ReloadJobList;
    123     procedure StartJobs;
    124     procedure UpdateHeight;
    125131    procedure JobProgressChange(Sender: TObject);
    126132  public
    127     Form: TFormJobProgressView;
    128     Jobs: TObjectList; // TListObject<TJob>
     133    Jobs: TJobs;
    129134    CurrentJob: TJob;
    130135    CurrentJobIndex: Integer;
    … …  
    132137    destructor Destroy; override;
    133138    procedure Clear;
    134     procedure AddJob(Title: string; Method: TJobProgressViewMethod;
    135       NoThreaded: Boolean = False; WaitFor: Boolean = False);
    136     procedure Start(AAutoClose: Boolean = True);
     139    function AddJob(Title: string; Method: TJobProgressViewMethod;
     140      NoThreaded: Boolean = False; WaitFor: Boolean = False): TJob;
     141    procedure Start;
    137142    procedure Stop;
    138143    procedure TermSleep(Delay: Integer);
     144    property Form: TFormJobProgressView read FForm;
    139145    property Terminate: Boolean read FTerminate write SetTerminate;
    140146  published
    … …  
    156162  SExecuted = 'Executed';
    157163
     164
    158165implementation
    159166
    … …  
    166173  STotalEstimatedTime = 'Total estimated time: %s';
    167174  SFinished = 'Finished';
    168   SOperations = 'Operations';
    169175
    170176procedure Register;
    … …  
    172178  RegisterComponents('Common', [TJobProgressView]);
    173179end;
     180
     181{ TJobThread }
    174182
    175183procedure TJobThread.Execute;
    … …  
    190198end;
    191199
    192 procedure TJobProgressView.AddJob(Title: string; Method: TJobProgressViewMethod;
    193   NoThreaded: Boolean = False; WaitFor: Boolean = False);
     200{ TFormJobProgressView }
     201
     202procedure TFormJobProgressView.UpdateHeight;
    194203var
    195   NewJob: TJob;
    196 begin
    197   NewJob := TJob.Create;
    198   NewJob.ProgressView := Self;
    199   NewJob.Title := Title;
    200   NewJob.Method := Method;
    201   NewJob.NoThreaded := NoThreaded;
    202   NewJob.WaitFor := WaitFor;
    203   NewJob.Progress.Max := 100;
    204   NewJob.Progress.Reset;
    205   NewJob.Progress.OnChange := JobProgressChange;
    206   Jobs.Add(NewJob);
     204  H: Integer;
     205  PanelOperationsVisible: Boolean;
     206  PanelOperationsHeight: Integer;
     207  PanelProgressVisible: Boolean;
     208  PanelProgressTotalVisible: Boolean;
     209  PanelLogVisible: Boolean;
     210  MemoLogHeight: Integer = 200;
     211  I: Integer;
     212  ItemRect: TRect;
     213  MaxH: Integer;
     214begin
     215    H := PanelOperationsTitle.Height;
     216    PanelOperationsVisible := JobProgressView.Jobs.Count > 0;
     217    if PanelOperationsVisible <> PanelOperations.Visible then
     218      PanelOperations.Visible := PanelOperationsVisible;
     219    if ListViewJobs.Items.Count > 0 then begin
     220      Maxh := 0;
     221      for I := 0 to ListViewJobs.Items.Count - 1 do
     222      begin
     223        ItemRect := ListViewJobs.Items[i].DisplayRect(drBounds);
     224        Maxh := Max(Maxh, ItemRect.Top + (ItemRect.Bottom - ItemRect.Top));
     225      end;
     226      PanelOperationsHeight := Scale96ToScreen(12) + Maxh;
     227    end else PanelOperationsHeight := Scale96ToScreen(8);
     228    if PanelOperationsHeight <> PanelOperations.Height then
     229      PanelOperations.Height := PanelOperationsHeight;
     230    if PanelOperationsVisible then
     231      H := H + PanelOperations.Height;
     232
     233    PanelProgressVisible := (JobProgressView.Jobs.Count > 0) and not JobProgressView.Finished;
     234    if PanelProgressVisible <> PanelProgress.Visible then
     235      PanelProgress.Visible := PanelProgressVisible;
     236    if PanelProgressVisible then
     237      H := H + PanelProgress.Height;
     238    PanelProgressTotalVisible := (JobProgressView.Jobs.Count > 1) and not JobProgressView.Finished;
     239    if PanelProgressTotalVisible <> PanelProgressTotal.Visible then
     240      PanelProgressTotal.Visible := PanelProgressTotalVisible;
     241    if PanelProgressTotalVisible then
     242      H := H + PanelProgressTotal.Height;
     243    Constraints.MinHeight := H;
     244    PanelLogVisible := MemoLog.Lines.Count > 0;
     245    if PanelLogVisible <> PanelLog.Visible then
     246      PanelLog.Visible := PanelLogVisible;
     247    if PanelLogVisible then
     248      H := H + Scale96ToScreen(MemoLogHeight);
     249    if PanelText.Visible then
     250      H := H + PanelText.Height;
     251    if Height <> H then begin
     252      Height := H;
     253      Top := (Screen.Height - H) div 2;
     254    end;
     255end;
     256
     257procedure TFormJobProgressView.TimerUpdateTimer(Sender: TObject);
     258var
     259  ProgressBarPartVisible: Boolean;
     260  ProgressBarTotalVisible: Boolean;
     261begin
     262  JobProgressView.UpdateProgress;
     263  if Visible and (not ProgressBarPart.Visible) and
     264  Assigned(JobProgressView.CurrentJob) and
     265  (JobProgressView.CurrentJob.Progress.Value > 0) then begin
     266    ProgressBarPartVisible := True;
     267    if ProgressBarPartVisible <> ProgressBarPart.Visible then
     268      ProgressBarPart.Visible := ProgressBarPartVisible;
     269    ProgressBarTotalVisible := True;
     270    if ProgressBarTotalVisible <> ProgressBarTotal.Visible then
     271      ProgressBarTotal.Visible := ProgressBarTotalVisible;
     272  end;
     273  if not Visible then begin
     274    TimerUpdate.Interval := UpdateInterval;
     275    if not JobProgressView.OwnerDraw then Show;
     276  end;
     277  if Assigned(JobProgressView.CurrentJob) then begin
     278    LabelText.Caption := JobProgressView.CurrentJob.Progress.Text;
     279    if LabelText.Caption <> '' then begin
     280      PanelText.Visible := True;
     281      UpdateHeight;
     282    end;
     283  end;
     284end;
     285
     286procedure TFormJobProgressView.ListViewJobsData(Sender: TObject; Item: TListItem);
     287begin
     288  if (Item.Index >= 0) and (Item.Index < JobProgressView.Jobs.Count) then
     289  with JobProgressView.Jobs[Item.Index] do begin
     290    Item.Caption := Title;
     291    if Item.Index = JobProgressView.CurrentJobIndex then Item.ImageIndex := 1
     292      else if Finished then Item.ImageIndex := 0
     293      else Item.ImageIndex := 2;
     294    Item.Data := JobProgressView.Jobs[Item.Index];
     295  end;
     296end;
     297
     298procedure TFormJobProgressView.FormClose(Sender: TObject;
     299  var CloseAction: TCloseAction);
     300begin
     301end;
     302
     303procedure TFormJobProgressView.FormCreate(Sender: TObject);
     304begin
     305  Caption := SPleaseWait;
     306  try
     307    //Animate1.FileName := ExtractFileDir(UTF8Encode(Application.ExeName)) +
     308    //  DirectorySeparator + 'horse.avi';
     309    //Animate1.Active := True;
     310  except
     311
     312  end;
     313end;
     314
     315procedure TFormJobProgressView.ReloadJobList;
     316begin
     317  // Workaround for not showing first line
     318  //Form.ListViewJobs.Items.Count := Jobs.Count + 1;
     319  //Form.ListViewJobs.Refresh;
     320
     321  if ListViewJobs.Items.Count <> JobProgressView.Jobs.Count then
     322    ListViewJobs.Items.Count := JobProgressView.Jobs.Count;
     323  ListViewJobs.Refresh;
     324  Application.ProcessMessages;
     325  UpdateHeight;
     326end;
     327
     328procedure TFormJobProgressView.FormShow(Sender: TObject);
     329begin
     330  ReloadJobList;
     331end;
     332
     333procedure TFormJobProgressView.FormHide(Sender: TObject);
     334begin
     335  JobProgressView.Jobs.Clear;
     336  ReloadJobList;
     337end;
     338
     339procedure TFormJobProgressView.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
     340begin
     341  CanClose := JobProgressView.Finished;
     342  JobProgressView.Terminate := True;
     343  Caption := SPleaseWait + STerminate;
     344end;
     345
     346
     347{ TJobProgressView }
     348
     349function TJobProgressView.AddJob(Title: string; Method: TJobProgressViewMethod;
     350  NoThreaded: Boolean = False; WaitFor: Boolean = False): TJob;
     351begin
     352  Result := TJob.Create;
     353  Result.ProgressView := Self;
     354  Result.Title := Title;
     355  Result.Method := Method;
     356  Result.NoThreaded := NoThreaded;
     357  Result.WaitFor := WaitFor;
     358  Result.Progress.Max := 100;
     359  Result.Progress.Reset;
     360  Result.Progress.OnChange := JobProgressChange;
     361  Jobs.Add(Result);
    207362  //ReloadJobList;
    208363end;
    209364
    210 procedure TJobProgressView.Start(AAutoClose: Boolean = True);
    211 begin
    212   AutoClose := AAutoClose;
    213   StartJobs;
    214 end;
    215 
    216 procedure TJobProgressView.StartJobs;
     365procedure TJobProgressView.Start;
    217366var
    218367  I: Integer;
    … …  
    229378    Form.MemoLog.Clear;
    230379
     380    Form.PanelText.Visible := False;
    231381    Form.LabelEstimatedTimePart.Visible := False;
    232382    Form.LabelEstimatedTimeTotal.Visible := False;
    … …  
    249399    I := 0;
    250400    while I < Jobs.Count do
    251     with TJob(Jobs[I]) do begin
     401    with Jobs[I] do begin
    252402      CurrentJobIndex := I;
    253       CurrentJob := TJob(Jobs[I]);
     403      CurrentJob := Jobs[I];
    254404      JobProgressChange(Self);
    255405      StartTime := Now;
    … …  
    258408      Form.ProgressBarPart.Visible := False;
    259409      //Show;
    260       ReloadJobList;
     410      Form.ReloadJobList;
    261411      Application.ProcessMessages;
    262412      if NoThreaded then begin
    … …  
    264414        Method(CurrentJob);
    265415      end else begin
     416        Thread := TJobThread.Create(True);
    266417        try
    267           Thread := TJobThread.Create(True);
    268418          with Thread do begin
    269419            FreeOnTerminate := False;
    … …  
    296446    //if Visible then Hide;
    297447    Form.MemoLog.Lines.Assign(Log);
    298     if (Form.MemoLog.Lines.Count = 0) and AutoClose then begin
     448    if (Form.MemoLog.Lines.Count = 0) and FAutoClose then begin
    299449      Form.Hide;
    300450    end;
    301     Clear;
     451    if not Form.Visible then Clear;
    302452    Form.Caption := SFinished;
    303453    //LabelEstimatedTimePart.Visible := False;
    304454    Finished := True;
    305455    CurrentJobIndex := -1;
    306     ReloadJobList;
    307   end;
    308 end;
    309 
    310 procedure TJobProgressView.UpdateHeight;
    311 var
    312   H: Integer;
    313   PanelOperationsVisible: Boolean;
    314   PanelOperationsHeight: Integer;
    315   PanelProgressVisible: Boolean;
    316   PanelProgressTotalVisible: Boolean;
    317   PanelLogVisible: Boolean;
    318 begin
    319   with Form do begin
    320   H := PanelOperationsTitle.Height;
    321   PanelOperationsVisible := Jobs.Count > 0;
    322   if PanelOperationsVisible <> PanelOperations.Visible then
    323     PanelOperations.Visible := PanelOperationsVisible;
    324   PanelOperationsHeight := 8 + 18 * Jobs.Count;
    325   if PanelOperationsHeight <> PanelOperations.Height then
    326     PanelOperations.Height := PanelOperationsHeight;
    327   if PanelOperationsVisible then
    328     H := H + PanelOperations.Height;
    329 
    330   PanelProgressVisible := (Jobs.Count > 0) and not Finished;
    331   if PanelProgressVisible <> PanelProgress.Visible then
    332     PanelProgress.Visible := PanelProgressVisible;
    333   if PanelProgressVisible then
    334     H := H + PanelProgress.Height;
    335   PanelProgressTotalVisible := (Jobs.Count > 1) and not Finished;
    336   if PanelProgressTotalVisible <> PanelProgressTotal.Visible then
    337     PanelProgressTotal.Visible := PanelProgressTotalVisible;
    338   if PanelProgressTotalVisible then
    339     H := H + PanelProgressTotal.Height;
    340   Constraints.MinHeight := H;
    341   PanelLogVisible := MemoLog.Lines.Count > 0;
    342   if PanelLogVisible <> PanelLog.Visible then
    343     PanelLog.Visible := PanelLogVisible;
    344   if PanelLogVisible then
    345     H := H + MemoLogHeight;
    346   if Height <> H then Height := H;
     456    Form.ReloadJobList;
    347457  end;
    348458end;
    … …  
    352462  if Assigned(FOnOwnerDraw) then
    353463    FOnOwnerDraw(Self);
    354 end;
    355 
    356 procedure TFormJobProgressView.TimerUpdateTimer(Sender: TObject);
    357 var
    358   ProgressBarPartVisible: Boolean;
    359   ProgressBarTotalVisible: Boolean;
    360 begin
    361   JobProgressView.UpdateProgress;
    362   if Visible and (not ProgressBarPart.Visible) and
    363   Assigned(JobProgressView.CurrentJob) and
    364   (JobProgressView.CurrentJob.Progress.Value > 0) then begin
    365     ProgressBarPartVisible := True;
    366     if ProgressBarPartVisible <> ProgressBarPart.Visible then
    367       ProgressBarPart.Visible := ProgressBarPartVisible;
    368     ProgressBarTotalVisible := True;
    369     if ProgressBarTotalVisible <> ProgressBarTotal.Visible then
    370       ProgressBarTotal.Visible := ProgressBarTotalVisible;
    371   end;
    372   if not Visible then begin
    373     TimerUpdate.Interval := UpdateInterval;
    374     if not JobProgressView.OwnerDraw then Show;
    375   end;
    376 end;
    377 
    378 procedure TFormJobProgressView.FormDestroy(Sender:TObject);
    379 begin
    380 end;
    381 
    382 procedure TFormJobProgressView.ListViewJobsData(Sender: TObject; Item: TListItem);
    383 begin
    384   if (Item.Index >= 0) and (Item.Index < JobProgressView.Jobs.Count) then
    385   with TJob(JobProgressView.Jobs[Item.Index]) do begin
    386     Item.Caption := Title;
    387     if Item.Index = JobProgressView.CurrentJobIndex then Item.ImageIndex := 1
    388       else if Finished then Item.ImageIndex := 0
    389       else Item.ImageIndex := 2;
    390     Item.Data := JobProgressView.Jobs[Item.Index];
    391   end;
    392 end;
    393 
    394 procedure TFormJobProgressView.FormClose(Sender: TObject;
    395   var CloseAction: TCloseAction);
    396 begin
    397   ListViewJobs.Clear;
    398 end;
    399 
    400 procedure TFormJobProgressView.FormCreate(Sender: TObject);
    401 begin
    402   Caption := SPleaseWait;
    403   try
    404     //Animate1.FileName := ExtractFileDir(UTF8Encode(Application.ExeName)) +
    405     //  DirectorySeparator + 'horse.avi';
    406     //Animate1.Active := True;
    407   except
    408 
    409   end;
    410464end;
    411465
    … …  
    428482end;
    429483
    430 procedure TFormJobProgressView.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    431 begin
    432   CanClose := JobProgressView.Finished;
    433   JobProgressView.Terminate := True;
    434   Caption := SPleaseWait + STerminate;
    435 end;
    436 
    437484procedure TJobProgressView.SetTerminate(const AValue: Boolean);
    438485var
    … …  
    441488  if AValue = FTerminate then Exit;
    442489  for I := 0 to Jobs.Count - 1 do
    443     TJob(Jobs[I]).Terminate := AValue;
     490    Jobs[I].Terminate := AValue;
    444491  FTerminate := AValue;
    445492end;
    … …  
    490537end;
    491538
    492 procedure TJobProgressView.ReloadJobList;
    493 begin
    494   UpdateHeight;
    495   // Workaround for not showing first line
    496   Form.ListViewJobs.Items.Count := Jobs.Count + 1;
    497   Form.ListViewJobs.Refresh;
    498 
    499   if Form.ListViewJobs.Items.Count <> Jobs.Count then
    500     Form.ListViewJobs.Items.Count := Jobs.Count;
    501   Form.ListViewJobs.Refresh;
    502   //Application.ProcessMessages;
    503 end;
    504 
    505539constructor TJobProgressView.Create(TheOwner: TComponent);
    506540begin
    507541  inherited;
    508542  if not (csDesigning in ComponentState) then begin
    509     Form := TFormJobProgressView.Create(Self);
    510     Form.JobProgressView := Self;
    511   end;
    512   Jobs := TObjectList.Create;
     543    FForm := TFormJobProgressView.Create(Self);
     544    FForm.JobProgressView := Self;
     545  end;
     546  Jobs := TJobs.Create;
    513547  Log := TStringList.Create;
    514548  //PanelOperationsTitle.Height := 80;
    515   ShowDelay := 0; //1000; // ms
     549  AutoClose := True;
     550  ShowDelay := 0;
    516551end;
    517552
    … …  
    519554begin
    520555  Jobs.Clear;
     556  Log.Clear;
    521557  //ReloadJobList;
    522558end;
    … …  
    528564  inherited;
    529565end;
     566
     567{ TProgress }
    530568
    531569procedure TProgress.SetMax(const AValue: Integer);
    … …  
    536574    if FMax < 1 then FMax := 1;
    537575    if FValue >= FMax then FValue := FMax;
     576  finally
     577    FLock.Release;
     578  end;
     579end;
     580
     581procedure TProgress.SetText(AValue: string);
     582begin
     583  try
     584    FLock.Acquire;
     585    if FText = AValue then Exit;
     586    FText := AValue;
    538587  finally
    539588    FLock.Release;
    … …  
    563612end;
    564613
    565 { TProgress }
    566 
    567614procedure TProgress.Increment;
    568615begin
    569   try
    570     FLock.Acquire;
     616  FLock.Acquire;
     617  try
    571618    Value := Value + 1;
    572619  finally
    … …  
    577624procedure TProgress.Reset;
    578625begin
    579   try
    580     FLock.Acquire;
     626  FLock.Acquire;
     627  try
    581628    FValue := 0;
    582629  finally
    … …  
    594641begin
    595642  FLock.Free;
    596   inherited Destroy;
     643  inherited;
    597644end;
    598645
    … …  
    625672destructor TJob.Destroy;
    626673begin
    627   Progress.Free;
     674  FreeAndNil(Progress);
    628675  inherited;
    629676end;

  • trunk/Packages/Common/ULastOpenedList.pas

    r10 r25  
    11unit ULastOpenedList;
    2 
    3 {$mode delphi}
    42
    53interface
    64
    75uses
    8   Classes, SysUtils, Registry, URegistry, Menus, XMLConf;
     6  Classes, SysUtils, Registry, URegistry, Menus, XMLConf, DOM;
    97
    108type
    … …  
    3028    procedure SaveToXMLConfig(XMLConfig: TXMLConfig; Path: string);
    3129    procedure AddItem(FileName: string);
     30    function GetFirstFileName: string;
    3231  published
    3332    property MaxCount: Integer read FMaxCount write SetMaxCount;
    … …  
    8382destructor TLastOpenedList.Destroy;
    8483begin
    85   Items.Free;
     84  FreeAndNil(Items);
    8685  inherited;
    8786end;
    … …  
    9392begin
    9493  if Assigned(MenuItem) then begin
    95     MenuItem.Clear;
     94    while MenuItem.Count > Items.Count do
     95      MenuItem.Delete(MenuItem.Count - 1);
     96    while MenuItem.Count < Items.Count do begin
     97      NewMenuItem := TMenuItem.Create(MenuItem);
     98      MenuItem.Add(NewMenuItem);
     99    end;
    96100    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);
     101      MenuItem.Items[I].Caption := Items[I];
     102      MenuItem.Items[I].OnClick := ClickAction;
    101103    end;
    102104  end;
    … …  
    139141    OpenKey(Context.Key, True);
    140142    for I := 0 to Items.Count - 1 do
    141       WriteString('File' + IntToStr(I), UTF8Decode(Items[I]));
     143      WriteString('File' + IntToStr(I), Items[I]);
    142144  finally
    143145    Free;
    … …  
    153155begin
    154156  with XMLConfig do begin
    155     Count := GetValue(Path + '/Count', 0);
     157    Count := GetValue(DOMString(Path + '/Count'), 0);
    156158    if Count > MaxCount then Count := MaxCount;
    157159    Items.Clear;
    158160    for I := 0 to Count - 1 do begin
    159       Value := GetValue(Path + '/File' + IntToStr(I), '');
     161      Value := string(GetValue(DOMString(Path + '/File' + IntToStr(I)), ''));
    160162      if Trim(Value) <> '' then Items.Add(Value);
    161163    end;
    … …  
    170172begin
    171173  with XMLConfig do begin
    172     SetValue(Path + '/Count', Items.Count);
     174    SetValue(DOMString(Path + '/Count'), Items.Count);
    173175    for I := 0 to Items.Count - 1 do
    174       SetValue(Path + '/File' + IntToStr(I), Items[I]);
     176      SetValue(DOMString(Path + '/File' + IntToStr(I)), DOMString(Items[I]));
    175177    Flush;
    176178  end;
    … …  
    185187end;
    186188
     189function TLastOpenedList.GetFirstFileName: string;
     190begin
     191  if Items.Count > 0 then Result := Items[0]
     192    else Result := '';
     193end;
     194
    187195end.
    188196

  • trunk/Packages/Common/UListViewSort.pas

    r15 r25  
    11unit UListViewSort;
    22
    3 // Date: 2010-11-03
    4 
    5 {$mode delphi}
     3// Date: 2019-05-17
    64
    75interface
    86
    97uses
    10   {$IFDEF Windows}Windows, CommCtrl, {$ENDIF}Classes, Graphics, ComCtrls, SysUtils,
    11   Controls, DateUtils, Dialogs, SpecializedList, Forms, Grids, StdCtrls, ExtCtrls,
    12   LclIntf, LMessages, LclType, LResources;
     8  {$IFDEF Windows}Windows, CommCtrl, LMessages, {$ENDIF}Classes, Graphics, ComCtrls, SysUtils,
     9  Controls, DateUtils, Dialogs, Forms, Grids, StdCtrls, ExtCtrls,
     10  LclIntf, LclType, LResources, Generics.Collections, Generics.Defaults;
    1311
    1412type
    … …  
    1917  TCompareEvent = function (Item1, Item2: TObject): Integer of object;
    2018  TListFilterEvent = procedure (ListViewSort: TListViewSort) of object;
     19
     20  TObjects = TObjectList<TObject>;
    2121
    2222  { TListViewSort }
    … …  
    5252    {$ENDIF}
    5353  public
    54     List: TListObject;
    55     Source: TListObject;
     54    Source: TObjects;
     55    List: TObjects;
    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;
    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
    … …  
    142190var
    143191  I: Integer;
     192  R: TRect;
    144193begin
    145194  with FStringGrid1 do begin
    146     Options := Options - [goEditing, goAlwaysShowEditor];
    147     //Columns.Clear;
    148195    while Columns.Count > ListView.Columns.Count do Columns.Delete(Columns.Count - 1);
    149196    while Columns.Count < ListView.Columns.Count do Columns.Add;
    150197    for I := 0 to ListView.Columns.Count - 1 do begin
    151198      Columns[I].Width := ListView.Columns[I].Width;
     199      if Selection.Left = I then begin
     200        R := CellRect(I, 0);
     201        Editor.Left := R.Left + 2;
     202        Editor.Width := R.Width - 4;
     203      end;
    152204    end;
    153     Options := Options + [goEditing, goAlwaysShowEditor];
    154205  end;
    155206end;
    … …  
    182233    Result := StringGrid.Cells[Index, 0]
    183234    else Result := '';
     235end;
     236
     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;
    184245end;
    185246
    … …  
    274335end;
    275336
     337var
     338  ListViewSortCompare: TCompareEvent;
     339
     340function ListViewCompare(constref Item1, Item2: TObject): Integer;
     341begin
     342  Result := ListViewSortCompare(Item1, Item2);
     343end;
     344
    276345procedure TListViewSort.Sort(Compare: TCompareEvent);
    277346begin
     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;
    278350  if (List.Count > 0) then
    279     List.Sort(Compare);
     351    List.Sort(TComparer<TObject>.Construct(ListViewCompare));
    280352end;
    281353
    … …  
    283355begin
    284356  if Assigned(FOnFilter) then FOnFilter(Self)
    285   else if Assigned(Source) then
    286     List.Assign(Source) else
     357  else if Assigned(Source) then begin
    287358    List.Clear;
     359    List.AddRange(Source);
     360  end else List.Clear;
    288361  if ListView.Items.Count <> List.Count then
    289362    ListView.Items.Count := List.Count;
    … …  
    340413begin
    341414  inherited;
    342   List := TListObject.Create;
     415  List := TObjects.Create;
    343416  List.OwnsObjects := False;
    344417end;
    … …  
    346419destructor TListViewSort.Destroy;
    347420begin
    348   List.Free;
     421  FreeAndNil(List);
    349422  inherited;
    350423end;
    … …  
    381454  ItemLeft := Item.Left;
    382455  ItemLeft := 23; // Windows 7 workaround
    383  
     456
    384457  Rect1.Left := ItemLeft - CheckWidth - BiasLeft + 1 + XBias;
    385458  //ShowMessage(IntToStr(Tp1.Y) + ', ' + IntToStr(BiasTop) + ', ' + IntToStr(XBias));
    … …  
    480553    FHeaderHandle := ListView_GetHeader(FListView.Handle);
    481554    for I := 0 to FListView.Columns.Count - 1 do begin
     555      {$push}{$warn 5057 off}
    482556      FillChar(Item, SizeOf(THDItem), 0);
     557      {$pop}
    483558      Item.Mask := HDI_FORMAT;
    484559      Header_GetItem(FHeaderHandle, I, Item);

  • trunk/Packages/Common/UMemory.pas

    r15 r25  
    11unit UMemory;
    2 
    3 {$mode Delphi}{$H+}
    42
    53interface
    … …  
    4442  end;
    4543
     44
    4645implementation
    4746
    … …  
    5049procedure TPositionMemory.SetSize(AValue: Integer);
    5150begin
    52   inherited SetSize(AValue);
     51  inherited;
    5352  if FPosition > FSize then FPosition := FSize;
    5453end;
    … …  
    107106begin
    108107  Size := 0;
    109   inherited Destroy;
     108  inherited;
    110109end;
    111110
    112111procedure TMemory.WriteMemory(Position: Integer; Memory: TMemory);
    113112begin
    114   Move(Memory.FData, PByte(@FData + Position)^, Memory.Size);
     113  Move(Memory.FData, PByte(PByte(@FData) + Position)^, Memory.Size);
    115114end;
    116115
    117116procedure TMemory.ReadMemory(Position: Integer; Memory: TMemory);
    118117begin
    119   Move(PByte(@FData + Position)^, Memory.FData, Memory.Size);
     118  Move(PByte(PByte(@FData) + Position)^, Memory.FData, Memory.Size);
    120119end;
    121120

  • trunk/Packages/Common/UPersistentForm.pas

    r20 r25  
    11unit UPersistentForm;
    22
    3 {$mode delphi}
    4 
    5 // Date: 2015-04-18
     3// Date: 2020-11-26
    64
    75interface
    86
    97uses
    10   Classes, SysUtils, Forms, URegistry, LCLIntf, Registry, Controls, ComCtrls;
     8  Classes, SysUtils, Forms, URegistry, LCLIntf, Registry, Controls, ComCtrls,
     9  ExtCtrls, LCLType;
    1110
    1211type
    … …  
    2524    FormRestoredSize: TRect;
    2625    FormWindowState: TWindowState;
     26    FormFullScreen: Boolean;
    2727    Form: TForm;
    2828    procedure LoadFromRegistry(RegistryContext: TRegistryContext);
    … …  
    3030    function CheckEntireVisible(Rect: TRect): TRect;
    3131    function CheckPartVisible(Rect: TRect; Part: Integer): TRect;
    32     procedure Load(Form: TForm; DefaultMaximized: Boolean = False);
     32    procedure Load(Form: TForm; DefaultMaximized: Boolean = False;
     33      DefaultFullScreen: Boolean = False);
    3334    procedure Save(Form: TForm);
    3435    constructor Create(AOwner: TComponent); override;
     36    procedure SetFullScreen(State: Boolean);
    3537    property RegistryContext: TRegistryContext read FRegistryContext
    3638      write FRegistryContext;
    … …  
    4244procedure Register;
    4345
     46
    4447implementation
    45 
    4648
    4749procedure Register;
    … …  
    7173  end;
    7274
     75  if (Control is TPanel) then begin
     76    with Form, TRegistryEx.Create do
     77    try
     78      RootKey := RegistryContext.RootKey;
     79      OpenKey(RegistryContext.Key + '\Forms\' + Form.Name + '\' + Control.Name, True);
     80      if (TPanel(Control).Align = alRight) or (TPanel(Control).Align = alLeft) then begin
     81        if ValueExists('Width') then
     82          TPanel(Control).Width := ReadInteger('Width');
     83      end;
     84      if (TPanel(Control).Align = alTop) or (TPanel(Control).Align = alBottom) then begin
     85        if ValueExists('Height') then
     86          TPanel(Control).Height := ReadInteger('Height');
     87      end;
     88    finally
     89      Free;
     90    end;
     91  end;
     92
    7393  if Control is TWinControl then begin
    7494    WinControl := TWinControl(Control);
    … …  
    95115      for I := 0 to TListView(Control).Columns.Count - 1 do begin
    96116        WriteInteger('ColWidth' + IntToStr(I), TListView(Control).Columns[I].Width);
     117      end;
     118    finally
     119      Free;
     120    end;
     121  end;
     122
     123  if (Control is TPanel) then begin
     124    with Form, TRegistryEx.Create do
     125    try
     126      RootKey := RegistryContext.RootKey;
     127      OpenKey(RegistryContext.Key + '\Forms\' + Form.Name + '\' + Control.Name, True);
     128      if (TPanel(Control).Align = alRight) or (TPanel(Control).Align = alLeft) then begin
     129        WriteInteger('Width', TPanel(Control).Width);
     130      end;
     131      if (TPanel(Control).Align = alTop) or (TPanel(Control).Align = alBottom) then begin
     132        WriteInteger('Height', TPanel(Control).Height);
    97133      end;
    98134    finally
    … …  
    134170      + FormRestoredSize.Top;
    135171    // Other state
    136     FormWindowState := TWindowState(ReadIntegerWithDefault('WindowState', Integer(wsNormal)));
     172    FormWindowState := TWindowState(ReadIntegerWithDefault('WindowState', Integer(FormWindowState)));
     173    FormFullScreen := ReadBoolWithDefault('FullScreen', FormFullScreen);
    137174  finally
    138175    Free;
    … …  
    158195    // Other state
    159196    WriteInteger('WindowState', Integer(FormWindowState));
     197    WriteBool('FullScreen', FormFullScreen);
    160198  finally
    161199    Free;
    … …  
    215253end;
    216254
    217 procedure TPersistentForm.Load(Form: TForm; DefaultMaximized: Boolean = False);
     255procedure TPersistentForm.Load(Form: TForm; DefaultMaximized: Boolean = False;
     256  DefaultFullScreen: Boolean = False);
    218257begin
    219258  Self.Form := Form;
    … …  
    223262  FormRestoredSize := Bounds((Screen.Width - Form.Width) div 2,
    224263    (Screen.Height - Form.Height) div 2, Form.Width, Form.Height);
     264  FormWindowState := Form.WindowState;
     265  FormFullScreen := DefaultFullScreen;
    225266
    226267  LoadFromRegistry(RegistryContext);
    … …  
    242283      Form.BoundsRect := FormNormalSize;
    243284  end;
     285  if FormFullScreen then SetFullScreen(True);
    244286  LoadControl(Form);
    245287end;
    … …  
    249291  Self.Form := Form;
    250292  FormNormalSize := Bounds(Form.Left, Form.Top, Form.Width, Form.Height);
    251   FormRestoredSize := Bounds(Form.RestoredLeft, Form.RestoredTop, Form.RestoredWidth,
    252     Form.RestoredHeight);
     293  if not FormFullScreen then
     294    FormRestoredSize := Bounds(Form.RestoredLeft, Form.RestoredTop, Form.RestoredWidth,
     295      Form.RestoredHeight);
    253296  FormWindowState := Form.WindowState;
    254297  SaveToRegistry(RegistryContext);
    … …  
    265308end;
    266309
     310procedure TPersistentForm.SetFullScreen(State: Boolean);
     311begin
     312  if State then begin
     313    FormFullScreen := True;
     314    FormNormalSize := Form.BoundsRect;
     315    FormRestoredSize := Bounds(Form.RestoredLeft, Form.RestoredTop, Form.RestoredWidth,
     316      Form.RestoredHeight);
     317    FormWindowState := Form.WindowState;
     318    ShowWindow(Form.Handle, SW_SHOWFULLSCREEN);
     319    {$IFDEF WINDOWS}
     320    Form.BorderStyle := bsNone;
     321    {$ENDIF}
     322  end else begin
     323    FormFullScreen := False;
     324    {$IFDEF WINDOWS}
     325    Form.BorderStyle := bsSizeable;
     326    {$ENDIF}
     327    ShowWindow(Form.Handle, SW_SHOWNORMAL);
     328    if FormWindowState = wsNormal then begin
     329      Form.BoundsRect := FormNormalSize;
     330    end else
     331    if FormWindowState = wsMaximized then begin
     332      Form.BoundsRect := FormRestoredSize;
     333      Form.WindowState := wsMaximized;
     334    end;
     335  end;
     336end;
     337
    267338end.
    268339

  • trunk/Packages/Common/UPool.pas

    r10 r25  
    11unit UPool;
    22
    3 {$mode Delphi}{$H+}
    4 
    53interface
    64
    75uses
    8   Classes, SysUtils, syncobjs, SpecializedList, UThreading;
     6  Classes, SysUtils, syncobjs, Generics.Collections, UThreading;
    97
    108type
    … …  
    2220    function NewItemObject: TObject; virtual;
    2321  public
    24     Items: TListObject;
    25     FreeItems: TListObject;
     22    Items: TObjectList<TObject>;
     23    FreeItems: TObjectList<TObject>;
    2624    function Acquire: TObject; virtual;
    2725    procedure Release(Item: TObject); virtual;
    … …  
    108106constructor TThreadedPool.Create;
    109107begin
    110   inherited Create;
     108  inherited;
    111109  Lock := TCriticalSection.Create;
    112110end;
    … …  
    116114  TotalCount := 0;
    117115  Lock.Free;
    118   inherited Destroy;
     116  inherited;
    119117end;
    120118
    … …  
    185183begin
    186184  inherited;
    187   Items := TListObject.Create;
    188   FreeItems := TListObject.Create;
     185  Items := TObjectList<TObject>.Create;
     186  FreeItems := TObjectList<TObject>.Create;
    189187  FreeItems.OwnsObjects := False;
    190188  FReleaseEvent := TEvent.Create(nil, False, False, '');

  • trunk/Packages/Common/UPrefixMultiplier.pas

    r10 r25  
    22
    33// Date: 2010-06-01
    4 
    5 {$mode delphi}
    64
    75interface
    … …  
    2119  { TPrefixMultiplier }
    2220
    23   TPrefixMultiplier = class
     21  TPrefixMultiplier = class(TComponent)
    2422  private
    25     function TruncateDigits(Value:Double;Digits:Integer=3):Double;
     23    function TruncateDigits(Value: Double; Digits: Integer = 3): Double;
    2624  public
    2725    function Add(Value: Double; PrefixMultipliers: TPrefixMultiplierDef;
    … …  
    7270  );
    7371
     72procedure Register;
     73
     74
    7475implementation
     76
     77procedure Register;
     78begin
     79  RegisterComponents('Common', [TPrefixMultiplier]);
     80end;
    7581
    7682{ TPrefixMultiplier }
    … …  
    9298end;
    9399
    94 function TPrefixMultiplier.Add(Value:Double;PrefixMultipliers:TPrefixMultiplierDef
    95   ;UnitText:string;Digits:Integer):string;
     100function TPrefixMultiplier.Add(Value: Double; PrefixMultipliers: TPrefixMultiplierDef
     101  ; UnitText:string; Digits: Integer): string;
    96102var
    97103  I: Integer;

  • trunk/Packages/Common/URegistry.pas

    r20 r25  
    11unit URegistry;
    2 
    3 {$MODE Delphi}
    42
    53interface
    … …  
    1715    RootKey: HKEY;
    1816    Key: string;
     17    class function Create(RootKey: TRegistryRoot; Key: string): TRegistryContext; static; overload;
     18    class function Create(RootKey: HKEY; Key: string): TRegistryContext; static; overload;
    1919    class operator Equal(A, B: TRegistryContext): Boolean;
    20     function Create(RootKey: TRegistryRoot; Key: string): TRegistryContext; overload;
    21     function Create(RootKey: HKEY; Key: string): TRegistryContext; overload;
    2220  end;
    2321
    … …  
    2927    procedure SetCurrentContext(AValue: TRegistryContext);
    3028  public
     29    function ReadChar(const Name: string): Char;
     30    procedure WriteChar(const Name: string; Value: Char);
    3131    function ReadBoolWithDefault(const Name: string;
    3232      DefaultValue: Boolean): Boolean;
    3333    function ReadIntegerWithDefault(const Name: string; DefaultValue: Integer): Integer;
    3434    function ReadStringWithDefault(const Name: string; DefaultValue: string): string;
     35    function ReadCharWithDefault(const Name: string; DefaultValue: Char): Char;
    3536    function ReadFloatWithDefault(const Name: string;
    3637      DefaultValue: Double): Double;
    … …  
    4142    function GetValue(const Name: string; const DefaultValue: Boolean): Boolean; overload;
    4243    function GetValue(const Name: string; const DefaultValue: Double): Double; overload;
     44    function GetValue(const Name: string; const DefaultValue: Char): Char; overload;
    4345    procedure SetValue(const Name: string; const Value: Integer); overload;
    4446    procedure SetValue(const Name: string; const Value: string); overload;
    4547    procedure SetValue(const Name: string; const Value: Boolean); overload;
    4648    procedure SetValue(const Name: string; const Value: Double); overload;
     49    procedure SetValue(const Name: string; const Value: Char); overload;
    4750    property CurrentContext: TRegistryContext read GetCurrentContext write SetCurrentContext;
    4851  end;
    … …  
    5356    HKEY_CURRENT_CONFIG, HKEY_DYN_DATA);
    5457
     58
    5559implementation
    5660
    57 
    5861{ TRegistryContext }
    5962
    … …  
    6366end;
    6467
    65 function TRegistryContext.Create(RootKey: TRegistryRoot; Key: string): TRegistryContext;
     68class function TRegistryContext.Create(RootKey: TRegistryRoot; Key: string): TRegistryContext;
    6669begin
    6770  Result.RootKey := RegistryRootHKEY[RootKey];
    … …  
    6972end;
    7073
    71 function TRegistryContext.Create(RootKey: HKEY; Key: string): TRegistryContext;
     74class function TRegistryContext.Create(RootKey: HKEY; Key: string): TRegistryContext;
    7275begin
    7376  Result.RootKey := RootKey;
    … …  
    97100end;
    98101
     102function TRegistryEx.ReadCharWithDefault(const Name: string; DefaultValue: Char
     103  ): Char;
     104begin
     105  if ValueExists(Name) then Result := ReadChar(Name)
     106    else begin
     107      WriteChar(Name, DefaultValue);
     108      Result := DefaultValue;
     109    end;
     110end;
     111
    99112function TRegistryEx.ReadFloatWithDefault(const Name: string;
    100113  DefaultValue: Double): Double;
    … …  
    131144end;
    132145
     146function TRegistryEx.GetValue(const Name: string; const DefaultValue: Char
     147  ): Char;
     148begin
     149  Result := ReadCharWithDefault(Name, DefaultValue);
     150end;
     151
    133152procedure TRegistryEx.SetValue(const Name: string; const Value: Integer);
    134153begin
    … …  
    149168begin
    150169  WriteFloat(Name, Value);
     170end;
     171
     172procedure TRegistryEx.SetValue(const Name: string; const Value: Char);
     173begin
     174  WriteChar(Name, Value);
    151175end;
    152176
    … …  
    171195function TRegistryEx.OpenKey(const Key: string; CanCreate: Boolean): Boolean;
    172196begin
    173   {$IFDEF Linux}
    174   CloseKey;
     197  {$IFDEF UNIX}
     198  //CloseKey;
    175199  {$ENDIF}
    176200  Result := inherited OpenKey(Key, CanCreate);
    … …  
    179203function TRegistryEx.GetCurrentContext: TRegistryContext;
    180204begin
    181   Result.Key := CurrentPath;
     205  Result.Key := String(CurrentPath);
    182206  Result.RootKey := RootKey;
    183207end;
    … …  
    189213end;
    190214
     215function TRegistryEx.ReadChar(const Name: string): Char;
     216var
     217  S: string;
     218begin
     219  S := ReadString(Name);
     220  if Length(S) > 0 then Result := S[1]
     221    else Result := #0;
     222end;
     223
     224procedure TRegistryEx.WriteChar(const Name: string; Value: Char);
     225begin
     226  WriteString(Name, Value);
     227end;
     228
    191229function TRegistryEx.ReadBoolWithDefault(const Name: string;
    192230  DefaultValue: Boolean): Boolean;

  • trunk/Packages/Common/UResetableThread.pas

    r10 r25  
    11unit UResetableThread;
    2 
    3 {$mode Delphi}{$H+}
    42
    53interface
    … …  
    156154  FThread.Name := 'ResetableThread';
    157155  FThread.Parent := Self;
    158   FThread.Resume;
     156  FThread.Start;
    159157end;
    160158
    … …  
    167165  FreeAndNil(FStopEvent);
    168166  FreeAndNil(FLock);
    169   inherited Destroy;
     167  inherited;
    170168end;
    171169
    … …  
    286284constructor TThreadPool.Create;
    287285begin
    288   inherited Create;
     286  inherited;
    289287end;
    290288
    … …  
    293291  TotalCount := 0;
    294292  WaitForEmpty;
    295   inherited Destroy;
     293  inherited;
    296294end;
    297295

  • trunk/Packages/Common/UScaleDPI.pas

    r15 r25  
    33{ See: http://wiki.lazarus.freepascal.org/High_DPI }
    44
    5 {$mode delphi}{$H+}
    6 
    75interface
    86
    97uses
    10   Classes, Forms, Graphics, Controls, ComCtrls, LCLType, SysUtils, StdCtrls,
    11   Contnrs;
     8  Classes, Forms, Graphics, Controls, ComCtrls, LCLType, SysUtils,
     9  Generics.Collections;
    1210
    1311type
     12  TControlDimensions = class;
    1413
    1514  { TControlDimension }
    … …  
    1817    BoundsRect: TRect;
    1918    FontHeight: Integer;
    20     Controls: TObjectList; // TList<TControlDimension>
     19    Controls: TControlDimensions;
    2120    // Class specifics
    2221    ButtonSize: TPoint; // TToolBar
    … …  
    2625    constructor Create;
    2726    destructor Destroy; override;
     27  end;
     28
     29  TControlDimensions = class(TObjectList<TControlDimension>)
    2830  end;
    2931
    … …  
    7375constructor TControlDimension.Create;
    7476begin
    75   Controls := TObjectList.Create;
     77  Controls := TControlDimensions.Create;
    7678end;
    7779
    … …  
    7981begin
    8082  FreeAndNil(Controls);
    81   inherited Destroy;
     83  inherited;
    8284end;
    8385
    … …  
    212214  TempBmp: TBitmap;
    213215  Temp: array of TBitmap;
    214   NewWidth, NewHeight: integer;
    215   I: Integer;
    216 begin
    217   NewWidth := ScaleX(ImgList.Width, FromDPI.X);
    218   NewHeight := ScaleY(ImgList.Height, FromDPI.Y);
    219 
    220   SetLength(Temp, ImgList.Count);
    221   for I := 0 to ImgList.Count - 1 do
    222   begin
    223     TempBmp := TBitmap.Create;
    224     TempBmp.PixelFormat := pf32bit;
    225     ImgList.GetBitmap(I, TempBmp);
    226     Temp[I] := TBitmap.Create;
    227     Temp[I].SetSize(NewWidth, NewHeight);
    228     Temp[I].PixelFormat := pf32bit;
    229     Temp[I].TransparentColor := TempBmp.TransparentColor;
    230     //Temp[I].TransparentMode := TempBmp.TransparentMode;
    231     Temp[I].Transparent := True;
    232     Temp[I].Canvas.Brush.Style := bsSolid;
    233     Temp[I].Canvas.Brush.Color := Temp[I].TransparentColor;
    234     Temp[I].Canvas.FillRect(0, 0, Temp[I].Width, Temp[I].Height);
    235 
    236     if (Temp[I].Width = 0) or (Temp[I].Height = 0) then Continue;
    237     Temp[I].Canvas.StretchDraw(Rect(0, 0, Temp[I].Width, Temp[I].Height), TempBmp);
    238     TempBmp.Free;
    239   end;
    240 
    241   ImgList.Clear;
    242   ImgList.Width := NewWidth;
    243   ImgList.Height := NewHeight;
    244 
    245   for I := 0 to High(Temp) do
    246   begin
    247     ImgList.Add(Temp[I], nil);
    248     Temp[i].Free;
     216  NewWidth: Integer;
     217  NewHeight: Integer;
     218  I: Integer;
     219begin
     220  ImgList.BeginUpdate;
     221  try
     222    NewWidth := ScaleX(ImgList.Width, FromDPI.X);
     223    NewHeight := ScaleY(ImgList.Height, FromDPI.Y);
     224
     225    Temp := nil;
     226    SetLength(Temp, ImgList.Count);
     227    for I := 0 to ImgList.Count - 1 do
     228    begin
     229      TempBmp := TBitmap.Create;
     230      try
     231        TempBmp.PixelFormat := pf32bit;
     232        ImgList.GetBitmap(I, TempBmp);
     233        Temp[I] := TBitmap.Create;
     234        Temp[I].SetSize(NewWidth, NewHeight);
     235        {$IFDEF UNIX}
     236        Temp[I].PixelFormat := pf24bit;
     237        {$ELSE}
     238        Temp[I].PixelFormat := pf32bit;
     239        {$ENDIF}
     240        Temp[I].TransparentColor := TempBmp.TransparentColor;
     241        //Temp[I].TransparentMode := TempBmp.TransparentMode;
     242        Temp[I].Transparent := True;
     243        Temp[I].Canvas.Brush.Style := bsSolid;
     244        Temp[I].Canvas.Brush.Color := Temp[I].TransparentColor;
     245        Temp[I].Canvas.FillRect(0, 0, Temp[I].Width, Temp[I].Height);
     246
     247        if (Temp[I].Width = 0) or (Temp[I].Height = 0) then Continue;
     248        Temp[I].Canvas.StretchDraw(Rect(0, 0, Temp[I].Width, Temp[I].Height), TempBmp);
     249      finally
     250        TempBmp.Free;
     251      end;
     252    end;
     253
     254    ImgList.Clear;
     255    ImgList.Width := NewWidth;
     256    ImgList.Height := NewHeight;
     257
     258    for I := 0 to High(Temp) do
     259    begin
     260      ImgList.Add(Temp[I], nil);
     261      Temp[i].Free;
     262    end;
     263  finally
     264    ImgList.EndUpdate;
    249265  end;
    250266end;
    … …  
    284300  WinControl: TWinControl;
    285301  ToolBarControl: TToolBar;
    286   OldAnchors: TAnchors;
    287   OldAutoSize: Boolean;
    288 begin
     302  //OldAnchors: TAnchors;
     303  //OldAutoSize: Boolean;
     304begin
     305  //if not (Control is TCustomPage) then
     306  // Resize childs first
     307  if Control is TWinControl then begin
     308    WinControl := TWinControl(Control);
     309    if WinControl.ControlCount > 0 then begin
     310      for I := 0 to WinControl.ControlCount - 1 do begin
     311        if WinControl.Controls[I] is TControl then begin
     312          ScaleControl(WinControl.Controls[I], FromDPI);
     313        end;
     314      end;
     315    end;
     316  end;
     317
    289318  //if Control is TMemo then Exit;
    290319  //if Control is TForm then
    … …  
    312341  with TCoolBar(Control) do begin
    313342    BeginUpdate;
    314     for I := 0 to Bands.Count - 1 do
    315       with Bands[I] do begin
    316         MinWidth := ScaleX(MinWidth, FromDPI.X);
    317         MinHeight := ScaleY(MinHeight, FromDPI.Y);
    318         Width := ScaleX(Width, FromDPI.X);
    319         //Control.Invalidate;
     343    try
     344      for I := 0 to Bands.Count - 1 do
     345        with Bands[I] do begin
     346          MinWidth := ScaleX(MinWidth, FromDPI.X);
     347          MinHeight := ScaleY(MinHeight, FromDPI.Y);
     348          // Workaround to bad band width auto sizing
     349          //Width := ScaleX(Width, FromDPI.X);
     350          Width := ScaleX(Control.Width + 28, FromDPI.X);
     351          //Control.Invalidate;
     352        end;
     353      // Workaround for bad autosizing of coolbar
     354      if AutoSize then begin
     355        AutoSize := False;
     356        Height := ScaleY(Height, FromDPI.Y);
     357        AutoSize := True;
    320358      end;
    321     EndUpdate;
     359    finally
     360      EndUpdate;
     361    end;
    322362  end;
    323363
    … …  
    330370  end;
    331371
    332   //if not (Control is TCustomPage) then
    333   if Control is TWinControl then begin
    334     WinControl := TWinControl(Control);
    335     if WinControl.ControlCount > 0 then begin
    336       for I := 0 to WinControl.ControlCount - 1 do begin
    337         if WinControl.Controls[I] is TControl then begin
    338           ScaleControl(WinControl.Controls[I], FromDPI);
    339         end;
    340       end;
    341     end;
    342   end;
    343372  //if Control is TForm then
    344373  //  Control.EnableAutoSizing;

  • trunk/Packages/Common/USyncCounter.pas

    r10 r25  
    11unit USyncCounter;
    2 
    3 {$mode delphi}
    42
    53interface
    … …  
    2523    procedure Assign(Source: TSyncCounter);
    2624  end;
     25
    2726
    2827implementation
    … …  
    6968begin
    7069  Lock.Free;
    71   inherited Destroy;
     70  inherited;
    7271end;
    7372

  • trunk/Packages/Common/UTheme.pas

    r16 r25  
    55uses
    66  Classes, SysUtils, Graphics, ComCtrls, Controls, ExtCtrls, Menus, StdCtrls,
    7   Spin, Forms, Contnrs, Grids;
     7  Spin, Forms, Generics.Collections, Grids;
    88
    99type
    … …  
    1919  { TThemes }
    2020
    21   TThemes = class(TObjectList)
     21  TThemes = class(TObjectList<TTheme>)
    2222    function AddNew(Name: string): TTheme;
    2323    function FindByName(Name: string): TTheme;
    … …  
    4242  end;
    4343
     44const
     45  ThemeNameSystem = 'System';
     46  ThemeNameLight = 'Light';
     47  ThemeNameDark = 'Dark';
     48
    4449procedure Register;
     50
    4551
    4652implementation
    … …  
    7480procedure TThemes.LoadToStrings(Strings: TStrings);
    7581var
    76   Theme: TTheme;
     82  I: Integer;
    7783begin
    78   Strings.Clear;
    79   for Theme in Self do
    80     Strings.AddObject(Theme.Name, Theme);
     84  Strings.BeginUpdate;
     85  try
     86    while Strings.Count < Count do Strings.Add('');
     87    while Strings.Count > Count do Strings.Delete(Strings.Count - 1);
     88    for I := 0 to Count - 1 do begin
     89      Strings[I] := Items[I].Name;
     90      Strings.Objects[I] := Items[I];
     91    end;
     92  finally
     93    Strings.EndUpdate;
     94  end;
    8195end;
    8296
    … …  
    97111  inherited;
    98112  Themes := TThemes.Create;
    99   with Themes.AddNew('System') do begin
     113  with Themes.AddNew(ThemeNameSystem) do begin
    100114    ColorWindow := clWindow;
    101115    ColorWindowText := clWindowText;
    … …  
    105119  end;
    106120  Theme := TTheme(Themes.First);
    107   with Themes.AddNew('Dark') do begin
     121  with Themes.AddNew(ThemeNameDark) do begin
    108122    ColorWindow := RGBToColor($20, $20, $20);
    109123    ColorWindowText := clWhite;
    … …  
    112126    ColorControlSelected := RGBToColor(96, 125, 155);
    113127  end;
    114   with Themes.AddNew('Light') do begin
     128  with Themes.AddNew(ThemeNameLight) do begin
    115129    ColorWindow := clWhite;
    116130    ColorWindowText := clBlack;
    … …  
    123137destructor TThemeManager.Destroy;
    124138begin
    125   Themes.Free;
    126   inherited Destroy;
     139  FreeAndNil(Themes);
     140  inherited;
    127141end;
    128142
    … …  
    132146  I: Integer;
    133147begin
    134   for I := 0 to Component.ComponentCount - 1 do
    135     ApplyTheme(Component.Components[I]);
     148  if Component is TWinControl then begin
     149    for I := 0 to TWinControl(Component).ControlCount - 1 do
     150      ApplyTheme(TWinControl(Component).Controls[I]);
     151  end;
    136152
    137153  if Component is TControl then begin
    … …  
    139155    if (Control is TEdit) or (Control is TSpinEdit) or (Control is TComboBox) and
    140156    (Control is TMemo) or (Control is TListView) or (Control is TCustomDrawGrid) or
    141     (Control is TCheckBox) then begin
     157    (Control is TCheckBox) or (Control is TPageControl) or (Control is TRadioButton) then begin
    142158      Control.Color := FTheme.ColorWindow;
    143159      Control.Font.Color := FTheme.ColorWindowText;
    … …  
    151167      (Control as TCustomDrawGrid).Editor.Font.Color := FTheme.ColorWindowText;
    152168    end;
     169
     170    if Control is TPageControl then begin
     171      for I := 0 to TPageControl(Component).PageCount - 1 do
     172        ApplyTheme(TPageControl(Component).Pages[I]);
     173    end;
     174
     175    if Control is TCoolBar then begin
     176      (Control as TCoolBar).Themed := False;
     177    end;
    153178  end;
    154179end;
    … …  
    156181procedure TThemeManager.UseTheme(Form: TForm);
    157182begin
    158   if not Used and (FTheme.Name = 'System') then Exit;
     183  if not Used and (FTheme.Name = ThemeNameSystem) then Exit;
    159184  ApplyTheme(Form);
    160185  Used := True;

  • trunk/Packages/Common/UThreading.pas

    r10 r25  
    11unit UThreading;
    22
    3 {$mode delphi}
    4 
    53interface
    64
    75uses
    8   Classes, SysUtils, Forms, Contnrs, SyncObjs;
     6  Classes, SysUtils, Forms, Generics.Collections, SyncObjs;
    97
    108type
    119  TExceptionEvent = procedure (Sender: TObject; E: Exception) of object;
    1210  TMethodCall = procedure of object;
    13 
    1411
    1512  { TVirtualThread }
    … …  
    2219    function GetSuspended: Boolean; virtual; abstract;
    2320    function GetTerminated: Boolean; virtual; abstract;
    24     function GetThreadId: Integer; virtual; abstract;
     21    function GetThreadId: TThreadID; virtual; abstract;
    2522    procedure SetFreeOnTerminate(const AValue: Boolean); virtual; abstract;
    2623    procedure SetPriority(const AValue: TThreadPriority); virtual; abstract;
    … …  
    3027    Name: string;
    3128    procedure Execute; virtual; abstract;
    32     procedure Resume; virtual; abstract;
    33     procedure Suspend; virtual; abstract;
    3429    procedure Start; virtual; abstract;
    3530    procedure Terminate; virtual; abstract;
    … …  
    4439    property Terminated: Boolean read GetTerminated write SetTerminated;
    4540    property Finished: Boolean read GetFinished;
    46     property ThreadId: Integer read GetThreadId;
     41    property ThreadId: TThreadID read GetThreadId;
    4742  end;
    4843
    … …  
    7065    function GetSuspended: Boolean; override;
    7166    function GetTerminated: Boolean; override;
    72     function GetThreadId: Integer; override;
     67    function GetThreadId: TThreadID; override;
    7368    procedure SetFreeOnTerminate(const AValue: Boolean); override;
    7469    procedure SetPriority(const AValue: TThreadPriority); override;
    … …  
    8176    procedure Sleep(Delay: Integer); override;
    8277    procedure Execute; override;
    83     procedure Resume; override;
    84     procedure Suspend; override;
    8578    procedure Start; override;
    8679    procedure Terminate; override;
    … …  
    10699  { TThreadList }
    107100
    108   TThreadList = class(TObjectList)
    109     function FindById(Id: Integer): TVirtualThread;
     101  TThreadList = class(TObjectList<TVirtualThread>)
     102    function FindById(Id: TThreadID): TVirtualThread;
    110103    constructor Create; virtual;
    111104  end;
    … …  
    134127    Thread.FreeOnTerminate := False;
    135128    Thread.Method := Method;
    136     Thread.Resume;
     129    Thread.Start;
    137130    while (Thread.State = ttsRunning) or (Thread.State = ttsReady) do begin
    138131      if MainThreadID = ThreadID then Application.ProcessMessages;
    … …  
    155148    Thread.Method := Method;
    156149    Thread.OnFinished := CallBack;
    157     Thread.Resume;
     150    Thread.Start;
    158151    //if Thread.State = ttsExceptionOccured then
    159152    //  raise Exception.Create(Thread.ExceptionMessage);
    … …  
    168161  if MainThreadID = ThreadID then Method
    169162  else begin
    170     Thread := ThreadList.FindById(ThreadID);
     163    try
     164      ThreadListLock.Acquire;
     165      Thread := ThreadList.FindById(ThreadID);
     166    finally
     167      ThreadListLock.Release;
     168    end;
    171169    if Assigned(Thread) then begin
    172170      Thread.Synchronize(Method);
    … …  
    177175{ TThreadList }
    178176
    179 function TThreadList.FindById(Id: Integer): TVirtualThread;
     177function TThreadList.FindById(Id: TThreadID): TVirtualThread;
    180178var
    181179  I: Integer;
    182180begin
    183181  I := 0;
    184   while (I < ThreadList.Count) and (TVirtualThread(ThreadList[I]).ThreadID <> Id) do
     182  while (I < ThreadList.Count) and (ThreadList[I].ThreadID <> Id) do
    185183    Inc(I);
    186   if I < ThreadList.Count then Result := TVirtualThread(ThreadList[I])
     184  if I < ThreadList.Count then Result := ThreadList[I]
    187185    else Result := nil;
    188186end;
    … …  
    237235end;
    238236
    239 function TListedThread.GetThreadId: Integer;
     237function TListedThread.GetThreadId: TThreadID;
    240238begin
    241239  Result := FThread.ThreadID;
    … …  
    294292  end;
    295293  FThread.Free;
    296   inherited Destroy;
     294  inherited;
    297295end;
    298296
    … …  
    313311procedure TListedThread.Execute;
    314312begin
    315 end;
    316 
    317 procedure TListedThread.Resume;
    318 begin
    319   FThread.Resume;
    320 end;
    321 
    322 procedure TListedThread.Suspend;
    323 begin
    324   FThread.Suspend;
    325313end;
    326314

  • trunk/Packages/Common/UURI.pas

    r10 r25  
    22
    33// Date: 2011-04-04
    4 
    5 {$mode delphi}
    64
    75interface
    … …  
    8583  end;
    8684
     85
    8786implementation
    8887
    8988function LeftCutString(var Source: string; out Output: string; Delimiter: string; Allowed: string = ''): Boolean;
    9089var
    91   I, J: Integer;
     90  I: Integer;
    9291  Matched: Boolean;
    9392begin
    … …  
    113112function RightCutString(var Source: string; out Output: string; Delimiter: string; Allowed: string = ''): Boolean;
    114113var
    115   I, J: Integer;
     114  I: Integer;
    116115  Matched: Boolean;
    117116begin
    … …  
    183182begin
    184183  Items.Free;
    185   inherited Destroy;
     184  inherited;
    186185end;
    187186
    … …  
    202201
    203202procedure TURI.SetAsString(Value: string);
    204 var
    205   HostAddr: string;
    206   HostPort: string;
    207203begin
    208204  LeftCutString(Value, Scheme, ':');
    … …  
    235231begin
    236232  Path.Free;
    237   inherited Destroy;
     233  inherited;
    238234end;
    239235
    … …  
    246242    Fragment := TURI(Source).Fragment;
    247243    Query := TURI(Source).Query;
    248   end else inherited Assign(Source);
     244  end else inherited;
    249245end;
    250246
    … …  
    294290destructor TURL.Destroy;
    295291begin
    296   inherited Destroy;
     292  inherited;
    297293end;
    298294
    … …  
    347343begin
    348344  Directory.Free;
    349   inherited Destroy;
    350 end;
    351 
     345  inherited;
     346end;
    352347
    353348end.

  • trunk/Packages/Common/UXMLUtils.pas

    r15 r25  
    11unit UXMLUtils;
    2 
    3 {$mode delphi}
    42
    53interface
    … …  
    75uses
    86  {$IFDEF WINDOWS}Windows,{$ENDIF}
    9   Classes, SysUtils, DateUtils, XMLRead, XMLWrite, DOM;
     7  Classes, SysUtils, DateUtils, DOM, xmlread;
    108
    119function XMLTimeToDateTime(XMLDateTime: string): TDateTime;
    12 function DateTimeToXMLTime(Value: TDateTime; ApplyLocalBias: Boolean = True): WideString;
     10function DateTimeToXMLTime(Value: TDateTime; ApplyLocalBias: Boolean = True): string;
    1311procedure WriteInteger(Node: TDOMNode; Name: string; Value: Integer);
    1412procedure WriteInt64(Node: TDOMNode; Name: string; Value: Int64);
    … …  
    2119function ReadString(Node: TDOMNode; Name: string; DefaultValue: string): string;
    2220function ReadDateTime(Node: TDOMNode; Name: string; DefaultValue: TDateTime): TDateTime;
     21procedure ReadXMLFileParser(out Doc: TXMLDocument; FileName: string);
    2322
    2423
    2524implementation
     25
     26procedure ReadXMLFileParser(out Doc: TXMLDocument; FileName: string);
     27var
     28  Parser: TDOMParser;
     29  Src: TXMLInputSource;
     30  InFile: TFileStream;
     31begin
     32  try
     33    InFile := TFileStream.Create(FileName, fmOpenRead);
     34    Src := TXMLInputSource.Create(InFile);
     35    Parser := TDOMParser.Create;
     36    Parser.Options.PreserveWhitespace := True;
     37    Parser.Parse(Src, Doc);
     38  finally
     39    Src.Free;
     40    Parser.Free;
     41    InFile.Free;
     42  end;
     43end;
    2644
    2745function GetTimeZoneBias: Integer;
    … …  
    3048  TimeZoneInfo: TTimeZoneInformation;
    3149begin
     50  {$push}{$warn 5057 off}
    3251  case GetTimeZoneInformation(TimeZoneInfo) of
    33   TIME_ZONE_ID_STANDARD: Result := TimeZoneInfo.Bias + TimeZoneInfo.StandardBias;
    34   TIME_ZONE_ID_DAYLIGHT: Result := TimeZoneInfo.Bias + TimeZoneInfo.DaylightBias;
     52    TIME_ZONE_ID_STANDARD: Result := TimeZoneInfo.Bias + TimeZoneInfo.StandardBias;
     53    TIME_ZONE_ID_DAYLIGHT: Result := TimeZoneInfo.Bias + TimeZoneInfo.DaylightBias;
    3554  else
    3655    Result := 0;
    3756  end;
     57  {$pop}
    3858end;
    3959{$ELSE}
    … …  
    4565function LeftCutString(var Source: string; out Output: string; Delimiter: string; Allowed: string = ''): Boolean;
    4666var
    47   I, J: Integer;
     67  I: Integer;
    4868  Matched: Boolean;
    4969begin
    … …  
    99119      if Pos('Z', XMLDateTime) > 0 then
    100120        LeftCutString(XMLDateTime, Part, 'Z');
    101       SecondFraction := StrToFloat('0' + DecimalSeparator + Part);
     121      SecondFraction := StrToFloat('0' + DefaultFormatSettings.DecimalSeparator + Part);
    102122      Millisecond := Trunc(SecondFraction * 1000);
    103123    end else begin
    … …  
    118138end;
    119139
    120 function DateTimeToXMLTime(Value: TDateTime; ApplyLocalBias: Boolean = True): WideString;
     140function DateTimeToXMLTime(Value: TDateTime; ApplyLocalBias: Boolean = True): string;
    121141const
    122142  Neg: array[Boolean] of string =  ('+', '-');
    … …  
    139159  NewNode: TDOMNode;
    140160begin
    141   NewNode := Node.OwnerDocument.CreateElement(Name);
    142   NewNode.TextContent := IntToStr(Value);
     161  NewNode := Node.OwnerDocument.CreateElement(DOMString(Name));
     162  NewNode.TextContent := DOMString(IntToStr(Value));
    143163  Node.AppendChild(NewNode);
    144164end;
    … …  
    148168  NewNode: TDOMNode;
    149169begin
    150   NewNode := Node.OwnerDocument.CreateElement(Name);
    151   NewNode.TextContent := IntToStr(Value);
     170  NewNode := Node.OwnerDocument.CreateElement(DOMString(Name));
     171  NewNode.TextContent := DOMString(IntToStr(Value));
    152172  Node.AppendChild(NewNode);
    153173end;
    … …  
    157177  NewNode: TDOMNode;
    158178begin
    159   NewNode := Node.OwnerDocument.CreateElement(Name);
    160   NewNode.TextContent := BoolToStr(Value);
     179  NewNode := Node.OwnerDocument.CreateElement(DOMString(Name));
     180  NewNode.TextContent := DOMString(BoolToStr(Value));
    161181  Node.AppendChild(NewNode);
    162182end;
    … …  
    166186  NewNode: TDOMNode;
    167187begin
    168   NewNode := Node.OwnerDocument.CreateElement(Name);
    169   NewNode.TextContent := Value;
     188  NewNode := Node.OwnerDocument.CreateElement(DOMString(Name));
     189  NewNode.TextContent := DOMString(Value);
    170190  Node.AppendChild(NewNode);
    171191end;
    … …  
    175195  NewNode: TDOMNode;
    176196begin
    177   NewNode := Node.OwnerDocument.CreateElement(Name);
    178   NewNode.TextContent := DateTimeToXMLTime(Value);
     197  NewNode := Node.OwnerDocument.CreateElement(DOMString(Name));
     198  NewNode.TextContent := DOMString(DateTimeToXMLTime(Value));
    179199  Node.AppendChild(NewNode);
    180200end;
    … …  
    185205begin
    186206  Result := DefaultValue;
    187   NewNode := Node.FindNode(Name);
    188   if Assigned(NewNode) then
    189     Result := StrToInt(NewNode.TextContent);
     207  NewNode := Node.FindNode(DOMString(Name));
     208  if Assigned(NewNode) then
     209    Result := StrToInt(string(NewNode.TextContent));
    190210end;
    191211
    … …  
    195215begin
    196216  Result := DefaultValue;
    197   NewNode := Node.FindNode(Name);
    198   if Assigned(NewNode) then
    199     Result := StrToInt64(NewNode.TextContent);
     217  NewNode := Node.FindNode(DOMString(Name));
     218  if Assigned(NewNode) then
     219    Result := StrToInt64(string(NewNode.TextContent));
    200220end;
    201221
    … …  
    205225begin
    206226  Result := DefaultValue;
    207   NewNode := Node.FindNode(Name);
    208   if Assigned(NewNode) then
    209     Result := StrToBool(NewNode.TextContent);
     227  NewNode := Node.FindNode(DOMString(Name));
     228  if Assigned(NewNode) then
     229    Result := StrToBool(string(NewNode.TextContent));
    210230end;
    211231
    … …  
    215235begin
    216236  Result := DefaultValue;
    217   NewNode := Node.FindNode(Name);
    218   if Assigned(NewNode) then
    219     Result := NewNode.TextContent;
     237  NewNode := Node.FindNode(DOMString(Name));
     238  if Assigned(NewNode) then
     239    Result := string(NewNode.TextContent);
    220240end;
    221241
    … …  
    226246begin
    227247  Result := DefaultValue;
    228   NewNode := Node.FindNode(Name);
    229   if Assigned(NewNode) then
    230     Result := XMLTimeToDateTime(NewNode.TextContent);
     248  NewNode := Node.FindNode(DOMString(Name));
     249  if Assigned(NewNode) then
     250    Result := XMLTimeToDateTime(string(NewNode.TextContent));
    231251end;
    232252
Note: See TracChangeset for help on using the changeset viewer.