Changeset 75 for trunk/Packages/Common


Ignore:
Timestamp:
Jun 4, 2024, 12:22:49 AM (6 months ago)
Author:
chronos
Message:
  • Modified: Removed U prefix from unit names.
  • Modified: Updated Common package.
Location:
trunk/Packages/Common
Files:
49 added
6 deleted
2 edited
1 copied
22 moved

Legend:

Unmodified
Added
Removed

  • trunk/Packages/Common/ApplicationInfo.pas

    r74 r75  
    1 unit UApplicationInfo;
    2 
    3 {$mode delphi}
     1unit ApplicationInfo;
    42
    53interface
    64
    75uses
    8   SysUtils, Registry, Classes, Forms, URegistry;
     6  SysUtils, Classes, Forms, RegistryEx, Controls, Graphics, LCLType;
    97
    108type
    … …  
    1412  TApplicationInfo = class(TComponent)
    1513  private
     14    FDescription: TTranslateString;
     15    FIcon: TBitmap;
    1616    FIdentification: Byte;
     17    FLicense: string;
    1718    FVersionMajor: Byte;
    1819    FVersionMinor: Byte;
    … …  
    3132  public
    3233    constructor Create(AOwner: TComponent); override;
     34    destructor Destroy; override;
    3335    property Version: string read GetVersion;
     36    function GetRegistryContext: TRegistryContext;
    3437  published
    3538    property Identification: Byte read FIdentification write FIdentification;
    … …  
    4447    property EmailContact: string read FEmailContact write FEmailContact;
    4548    property AppName: string read FAppName write FAppName;
     49    property Description: TTranslateString read FDescription write FDescription;
    4650    property ReleaseDate: TDateTime read FReleaseDate write FReleaseDate;
    4751    property RegistryKey: string read FRegistryKey write FRegistryKey;
    4852    property RegistryRoot: TRegistryRoot read FRegistryRoot write FRegistryRoot;
     53    property License: string read FLicense write FLicense;
     54    property Icon: TBitmap read FIcon write FIcon;
    4955  end;
    5056
    5157procedure Register;
    5258
     59
    5360implementation
    54                        
     61
    5562procedure Register;
    5663begin
    … …  
    6976constructor TApplicationInfo.Create(AOwner: TComponent);
    7077begin
    71   inherited Create(AOwner);
     78  inherited;
    7279  FVersionMajor := 1;
    7380  FIdentification := 1;
    … …  
    7582  FRegistryKey := '\Software\' + FAppName;
    7683  FRegistryRoot := rrKeyCurrentUser;
     84  FIcon := TBitmap.Create;
     85end;
     86
     87destructor TApplicationInfo.Destroy;
     88begin
     89  FreeAndNil(FIcon);
     90  inherited;
     91end;
     92
     93function TApplicationInfo.GetRegistryContext: TRegistryContext;
     94begin
     95  Result := TRegistryContext.Create(RegistryRoot, RegistryKey);
    7796end;
    7897

  • trunk/Packages/Common/Common.Delay.pas

    r74 r75  
    1 unit UDelay;
    2 
    3 {$mode delphi}
     1unit Common.Delay;
    42
    53interface
    … …  
    7371
    7472end.
    75 

  • trunk/Packages/Common/Common.lpk

    r74 r75  
    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"/>
     6    <Type Value="RunAndDesignTime"/>
    67    <AddToProjectUsesSection Value="True"/>
    78    <Author Value="Chronos (robie@centrum.cz)"/>
    … …  
    1011      <PathDelim Value="\"/>
    1112      <SearchPaths>
    12         <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
     13        <OtherUnitFiles Value="Forms"/>
     14        <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)-$(BuildMode)"/>
    1315      </SearchPaths>
     16      <Parsing>
     17        <SyntaxOptions>
     18          <SyntaxMode Value="Delphi"/>
     19          <CStyleOperator Value="False"/>
     20          <AllowLabel Value="False"/>
     21          <CPPInline Value="False"/>
     22        </SyntaxOptions>
     23      </Parsing>
     24      <CodeGeneration>
     25        <Optimizations>
     26          <OptimizationLevel Value="0"/>
     27        </Optimizations>
     28      </CodeGeneration>
     29      <Linking>
     30        <Debugging>
     31          <GenerateDebugInfo Value="False"/>
     32        </Debugging>
     33      </Linking>
    1434      <Other>
    1535        <CompilerMessages>
    16           <UseMsgFile Value="True"/>
     36          <IgnoredMessages idx6058="True" idx5071="True" idx5024="True" idx3124="True" idx3123="True"/>
    1737        </CompilerMessages>
    18         <CompilerPath Value="$(CompPath)"/>
    1938      </Other>
    2039    </CompilerOptions>
    21     <Description Value="Various libraries"/>
    22     <License Value="GNU/GPL"/>
    23     <Version Minor="7"/>
    24     <Files Count="19">
     40    <Description Value="Common package with various useful units.
     41
     42Source: https://svn.zdechov.net/PascalClassLibrary/Common/"/>
     43    <License Value="Copy left."/>
     44    <Version Minor="12"/>
     45    <Files Count="36">
    2546      <Item1>
    2647        <Filename Value="StopWatch.pas"/>
    … …  
    2849      </Item1>
    2950      <Item2>
    30         <Filename Value="UCommon.pas"/>
    31         <UnitName Value="UCommon"/>
     51        <Filename Value="Common.pas"/>
     52        <UnitName Value="Common"/>
    3253      </Item2>
    3354      <Item3>
    34         <Filename Value="UDebugLog.pas"/>
    35         <HasRegisterProc Value="True"/>
    36         <UnitName Value="UDebugLog"/>
     55        <Filename Value="DebugLog.pas"/>
     56        <HasRegisterProc Value="True"/>
     57        <UnitName Value="DebugLog"/>
    3758      </Item3>
    3859      <Item4>
    39         <Filename Value="UDelay.pas"/>
    40         <UnitName Value="UDelay"/>
     60        <Filename Value="Common.Delay.pas"/>
     61        <UnitName Value="Common.Delay"/>
    4162      </Item4>
    4263      <Item5>
    43         <Filename Value="UPrefixMultiplier.pas"/>
    44         <UnitName Value="UPrefixMultiplier"/>
     64        <Filename Value="PrefixMultiplier.pas"/>
     65        <HasRegisterProc Value="True"/>
     66        <UnitName Value="PrefixMultiplier"/>
    4567      </Item5>
    4668      <Item6>
    47         <Filename Value="UURI.pas"/>
    48         <UnitName Value="UURI"/>
     69        <Filename Value="URI.pas"/>
     70        <UnitName Value="URI"/>
    4971      </Item6>
    5072      <Item7>
    51         <Filename Value="UThreading.pas"/>
    52         <UnitName Value="UThreading"/>
     73        <Filename Value="Threading.pas"/>
     74        <UnitName Value="Threading"/>
    5375      </Item7>
    5476      <Item8>
    55         <Filename Value="UMemory.pas"/>
    56         <UnitName Value="UMemory"/>
     77        <Filename Value="Memory.pas"/>
     78        <UnitName Value="Memory"/>
    5779      </Item8>
    5880      <Item9>
    59         <Filename Value="UResetableThread.pas"/>
    60         <UnitName Value="UResetableThread"/>
     81        <Filename Value="ResetableThread.pas"/>
     82        <UnitName Value="ResetableThread"/>
    6183      </Item9>
    6284      <Item10>
    63         <Filename Value="UPool.pas"/>
    64         <UnitName Value="UPool"/>
     85        <Filename Value="Pool.pas"/>
     86        <UnitName Value="Pool"/>
    6587      </Item10>
    6688      <Item11>
    67         <Filename Value="ULastOpenedList.pas"/>
    68         <HasRegisterProc Value="True"/>
    69         <UnitName Value="ULastOpenedList"/>
     89        <Filename Value="LastOpenedList.pas"/>
     90        <HasRegisterProc Value="True"/>
     91        <UnitName Value="LastOpenedList"/>
    7092      </Item11>
    7193      <Item12>
    72         <Filename Value="URegistry.pas"/>
    73         <UnitName Value="URegistry"/>
     94        <Filename Value="RegistryEx.pas"/>
     95        <UnitName Value="RegistryEx"/>
    7496      </Item12>
    7597      <Item13>
    76         <Filename Value="UJobProgressView.pas"/>
    77         <HasRegisterProc Value="True"/>
    78         <UnitName Value="UJobProgressView"/>
     98        <Filename Value="JobProgressView.pas"/>
     99        <HasRegisterProc Value="True"/>
     100        <UnitName Value="JobProgressView"/>
    79101      </Item13>
    80102      <Item14>
    81         <Filename Value="UXMLUtils.pas"/>
    82         <UnitName Value="UXMLUtils"/>
     103        <Filename Value="XML.pas"/>
     104        <UnitName Value="XML"/>
    83105      </Item14>
    84106      <Item15>
    85         <Filename Value="UApplicationInfo.pas"/>
    86         <HasRegisterProc Value="True"/>
    87         <UnitName Value="UApplicationInfo"/>
     107        <Filename Value="ApplicationInfo.pas"/>
     108        <HasRegisterProc Value="True"/>
     109        <UnitName Value="ApplicationInfo"/>
    88110      </Item15>
    89111      <Item16>
    90         <Filename Value="USyncCounter.pas"/>
    91         <UnitName Value="USyncCounter"/>
     112        <Filename Value="SyncCounter.pas"/>
     113        <UnitName Value="SyncCounter"/>
    92114      </Item16>
    93115      <Item17>
    94         <Filename Value="UListViewSort.pas"/>
    95         <HasRegisterProc Value="True"/>
    96         <UnitName Value="UListViewSort"/>
     116        <Filename Value="ListViewSort.pas"/>
     117        <HasRegisterProc Value="True"/>
     118        <UnitName Value="ListViewSort"/>
    97119      </Item17>
    98120      <Item18>
    99         <Filename Value="UPersistentForm.pas"/>
    100         <HasRegisterProc Value="True"/>
    101         <UnitName Value="UPersistentForm"/>
     121        <Filename Value="PersistentForm.pas"/>
     122        <HasRegisterProc Value="True"/>
     123        <UnitName Value="PersistentForm"/>
    102124      </Item18>
    103125      <Item19>
    104         <Filename Value="UFindFile.pas"/>
    105         <HasRegisterProc Value="True"/>
    106         <UnitName Value="UFindFile"/>
     126        <Filename Value="FindFile.pas"/>
     127        <HasRegisterProc Value="True"/>
     128        <UnitName Value="FindFile"/>
    107129      </Item19>
     130      <Item20>
     131        <Filename Value="ScaleDPI.pas"/>
     132        <HasRegisterProc Value="True"/>
     133        <UnitName Value="ScaleDPI"/>
     134      </Item20>
     135      <Item21>
     136        <Filename Value="Theme.pas"/>
     137        <HasRegisterProc Value="True"/>
     138        <UnitName Value="Theme"/>
     139      </Item21>
     140      <Item22>
     141        <Filename Value="StringTable.pas"/>
     142        <UnitName Value="StringTable"/>
     143      </Item22>
     144      <Item23>
     145        <Filename Value="MetaCanvas.pas"/>
     146        <UnitName Value="MetaCanvas"/>
     147      </Item23>
     148      <Item24>
     149        <Filename Value="Geometric.pas"/>
     150        <UnitName Value="Geometric"/>
     151      </Item24>
     152      <Item25>
     153        <Filename Value="Translator.pas"/>
     154        <HasRegisterProc Value="True"/>
     155        <UnitName Value="Translator"/>
     156      </Item25>
     157      <Item26>
     158        <Filename Value="Languages.pas"/>
     159        <UnitName Value="Languages"/>
     160      </Item26>
     161      <Item27>
     162        <Filename Value="PixelPointer.pas"/>
     163        <UnitName Value="PixelPointer"/>
     164      </Item27>
     165      <Item28>
     166        <Filename Value="DataFile.pas"/>
     167        <UnitName Value="DataFile"/>
     168      </Item28>
     169      <Item29>
     170        <Filename Value="TestCase.pas"/>
     171        <UnitName Value="TestCase"/>
     172      </Item29>
     173      <Item30>
     174        <Filename Value="Generics.pas"/>
     175        <UnitName Value="Generics"/>
     176      </Item30>
     177      <Item31>
     178        <Filename Value="CommonPackage.pas"/>
     179        <Type Value="Main Unit"/>
     180        <UnitName Value="CommonPackage"/>
     181      </Item31>
     182      <Item32>
     183        <Filename Value="Table.pas"/>
     184        <UnitName Value="Table"/>
     185      </Item32>
     186      <Item33>
     187        <Filename Value="FormEx.pas"/>
     188        <HasRegisterProc Value="True"/>
     189        <UnitName Value="FormEx"/>
     190      </Item33>
     191      <Item34>
     192        <Filename Value="Forms\FormTests.pas"/>
     193        <UnitName Value="FormTests"/>
     194      </Item34>
     195      <Item35>
     196        <Filename Value="Forms\FormTest.pas"/>
     197        <UnitName Value="FormTest"/>
     198      </Item35>
     199      <Item36>
     200        <Filename Value="Forms\FormAbout.pas"/>
     201        <UnitName Value="FormAbout"/>
     202      </Item36>
    108203    </Files>
     204    <CompatibilityMode Value="True"/>
    109205    <i18n>
    110206      <EnableI18N Value="True"/>
    111207      <OutDir Value="Languages"/>
     208      <EnableI18NForLFM Value="True"/>
    112209    </i18n>
    113     <Type Value="RunAndDesignTime"/>
    114210    <RequiredPkgs Count="2">
    115211      <Item1>
    116         <PackageName Value="TemplateGenerics"/>
     212        <PackageName Value="LCL"/>
    117213      </Item1>
    118214      <Item2>

  • trunk/Packages/Common/Common.pas

    r74 r75  
    1 unit UCommon;
    2 
    3 {$mode delphi}
     1unit Common;
    42
    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: string; List: TList<string>): string;
     68function Implode(Separator: string; List: TStringList; Around: string = ''): string;
     69function LastPos(const SubStr: String; const S: String): Integer;
     70function LoadFileToStr(const FileName: TFileName): AnsiString;
     71function LoggedOnUserNameEx(Format: TUserNameFormat): string;
     72function MergeArray(A, B: array of string): TStringArray;
     73function OccurenceOfChar(What: Char; Where: string): Integer;
     74procedure OpenWebPage(URL: string);
     75procedure OpenEmail(Email: string);
     76procedure OpenFileInShell(FileName: string);
     77function PosFromIndex(SubStr: string; Text: string;
     78  StartIndex: Integer): Integer;
     79function PosFromIndexReverse(SubStr: string; Text: string;
     80  StartIndex: Integer): Integer;
     81function RemoveQuotes(Text: string): string;
     82procedure SaveStringToFile(S, FileName: string);
    5383procedure SetBit(var Variable: Int64; Index: Byte; State: Boolean); overload;
    5484procedure SetBit(var Variable: QWord; Index: Byte; State: Boolean); overload;
    5585procedure SetBit(var Variable: Cardinal; Index: Byte; State: Boolean); overload;
    5686procedure 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(CommandLine: 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;
     87procedure SearchFiles(AList: TStrings; Dir: string;
     88  FilterMethod: TFilterMethod = nil; FileNameMethod: TFileNameMethod = nil);
     89function SplitString(var Text: string; Count: Word): string;
     90function StripTags(const S: string): string;
     91function TryHexToInt(Data: string; out Value: Integer): Boolean;
     92function TryBinToInt(Data: string; out Value: Integer): Boolean;
     93procedure SortStrings(Strings: TStrings);
    7394
    7495
    … …  
    98119  I: Integer;
    99120begin
     121  Result := '';
    100122  for I := 1 to Length(Source) do begin
    101123    Result := Result + LowerCase(IntToHex(Ord(Source[I]), 2));
    … …  
    112134  Path := IncludeTrailingPathDelimiter(APath);
    113135
    114   Find := FindFirst(UTF8Decode(Path + AFileSpec), faAnyFile xor faDirectory, SearchRec);
     136  Find := FindFirst(Path + AFileSpec, faAnyFile xor faDirectory, SearchRec);
    115137  while Find = 0 do begin
    116     DeleteFile(Path + UTF8Encode(SearchRec.Name));
     138    DeleteFile(Path + SearchRec.Name);
    117139
    118140    Find := SysUtils.FindNext(SearchRec);
    … …  
    185207end;*)
    186208
     209function Implode(Separator: string; List: TStringList; Around: string = ''): string;
     210var
     211  I: Integer;
     212begin
     213  Result := '';
     214  for I := 0 to List.Count - 1 do begin
     215    Result := Result + Around + List[I] + Around;
     216    if I < List.Count - 1 then Result := Result + Separator;
     217  end;
     218end;
     219
    187220function LastPos(const SubStr: String; const S: String): Integer;
    188221begin
    … …  
    230263end;
    231264
    232 function TryHexToInt(Data: string; var Value: Integer): Boolean;
     265function TryHexToInt(Data: string; out Value: Integer): Boolean;
    233266var
    234267  I: Integer;
    … …  
    246279end;
    247280
    248 function TryBinToInt(Data: string; var Value: Integer): Boolean;
     281function TryBinToInt(Data: string; out Value: Integer): Boolean;
    249282var
    250283  I: Integer;
    … …  
    274307end;
    275308
    276 function Explode(Separator: char; Data: string): TArrayOfString;
    277 begin
    278   SetLength(Result, 0);
    279   while Pos(Separator, Data) > 0 do begin
     309function Explode(Separator: Char; Data: string): TStringArray;
     310var
     311  Index: Integer;
     312begin
     313  Result := Default(TStringArray);
     314  repeat
     315    Index := Pos(Separator, Data);
     316    if Index > 0 then begin
     317      SetLength(Result, Length(Result) + 1);
     318      Result[High(Result)] := Copy(Data, 1, Index - 1);
     319      Delete(Data, 1, Index);
     320    end else Break;
     321  until False;
     322  if Data <> '' then begin
    280323    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}
     324    Result[High(Result)] := Data;
     325  end;
     326end;
     327
     328function Implode(Separator: string; List: TList<string>): string;
     329var
     330  I: Integer;
     331begin
     332  Result := '';
     333  for I := 0 to List.Count - 1 do begin
     334    Result := Result + List[I];
     335    if I < List.Count - 1 then Result := Result + Separator;
     336  end;
     337end;
     338
     339{$IFDEF WINDOWS}
    289340function GetUserName: string;
    290341const
    … …  
    294345begin
    295346  L := MAX_USERNAME_LENGTH + 2;
     347  Result := Default(string);
    296348  SetLength(Result, L);
    297349  if Windows.GetUserName(PChar(Result), L) and (L > 0) then begin
    … …  
    307359  end;
    308360end;
    309 {$endif}
     361{$ENDIF}
    310362
    311363function ComputerName: string;
    312 {$ifdef mswindows}
     364{$IFDEF WINDOWS}
    313365const
    314366 INFO_BUFFER_SIZE = 32767;
    … …  
    325377  end;
    326378end;
    327 {$endif}
    328 {$ifdef unix}
     379{$ENDIF}
     380{$IFDEF UNIX}
    329381var
    330382  Name: UtsName;
    331383begin
     384  Name := Default(UtsName);
    332385  fpuname(Name);
    333386  Result := Name.Nodename;
    334387end;
    335 {$endif}
    336 
    337 {$ifdef windows}
     388{$ENDIF}
     389
     390{$IFDEF WINDOWS}
    338391function LoggedOnUserNameEx(Format: TUserNameFormat): string;
    339392const
    … …  
    413466procedure LoadLibraries;
    414467begin
    415   {$IFDEF Windows}
     468  {$IFDEF WINDOWS}
    416469  DLLHandle1 := LoadLibrary('secur32.dll');
    417470  if DLLHandle1 <> 0 then
    … …  
    424477procedure FreeLibraries;
    425478begin
    426   {$IFDEF Windows}
     479  {$IFDEF WINDOWS}
    427480  if DLLHandle1 <> 0 then FreeLibrary(DLLHandle1);
    428481  {$ENDIF}
    429482end;
    430483
    431 procedure ExecuteProgram(CommandLine: string);
     484procedure ExecuteProgram(Executable: string; Parameters: array of string);
    432485var
    433486  Process: TProcess;
     487  I: Integer;
    434488begin
    435489  try
    436490    Process := TProcess.Create(nil);
    437     Process.CommandLine := CommandLine;
     491    Process.Executable := Executable;
     492    for I := 0 to Length(Parameters) - 1 do
     493      Process.Parameters.Add(Parameters[I]);
    438494    Process.Options := [poNoConsole];
    439495    Process.Execute;
    … …  
    454510end;
    455511
     512procedure OpenEmail(Email: string);
     513begin
     514  OpenURL('mailto:' + Email);
     515end;
     516
    456517procedure OpenFileInShell(FileName: string);
    457518begin
    458   ExecuteProgram('cmd.exe /c start "' + FileName + '"');
     519  ExecuteProgram('cmd.exe', ['/c', 'start', FileName]);
    459520end;
    460521
    … …  
    482543end;
    483544
    484 function MergeArray(A, B: array of string): TArrayOfString;
    485 var
    486   I: Integer;
    487 begin
     545function MergeArray(A, B: array of string): TStringArray;
     546var
     547  I: Integer;
     548begin
     549  Result := Default(TStringArray);
    488550  SetLength(Result, Length(A) + Length(B));
    489551  for I := 0 to Length(A) - 1 do
    … …  
    511573end;
    512574
     575function DefaultSearchFilter(const FileName: string): Boolean;
     576begin
     577  Result := True;
     578end;
     579
     580procedure SaveStringToFile(S, FileName: string);
     581var
     582  F: TextFile;
     583begin
     584  AssignFile(F, FileName);
     585  try
     586    ReWrite(F);
     587    Write(F, S);
     588  finally
     589    CloseFile(F);
     590  end;
     591end;
     592
     593procedure SearchFiles(AList: TStrings; Dir: string;
     594  FilterMethod: TFilterMethod = nil; FileNameMethod: TFileNameMethod = nil);
     595var
     596  SR: TSearchRec;
     597begin
     598  Dir := IncludeTrailingPathDelimiter(Dir);
     599  if FindFirst(Dir + '*', faAnyFile, SR) = 0 then
     600    try
     601      repeat
     602        if (SR.Name = '.') or (SR.Name = '..') or (Assigned(FilterMethod) and (not FilterMethod(SR.Name) or
     603          not FilterMethod(Copy(Dir, 3, Length(Dir)) + SR.Name))) then Continue;
     604        if Assigned(FileNameMethod) then
     605          FileNameMethod(Dir + SR.Name);
     606        AList.Add(Dir + SR.Name);
     607        if (SR.Attr and faDirectory) <> 0 then
     608          SearchFiles(AList, Dir + SR.Name, FilterMethod);
     609      until FindNext(SR) <> 0;
     610    finally
     611      FindClose(SR);
     612    end;
     613end;
     614
     615function GetStringPart(var Text: string; Separator: string): string;
     616var
     617  P: Integer;
     618begin
     619  P := Pos(Separator, Text);
     620  if P > 0 then begin
     621    Result := Copy(Text, 1, P - 1);
     622    Delete(Text, 1, P - 1 + Length(Separator));
     623  end else begin
     624    Result := Text;
     625    Text := '';
     626  end;
     627  Result := Trim(Result);
     628  Text := Trim(Text);
     629end;
     630
     631function StripTags(const S: string): string;
     632var
     633  Len: Integer;
     634
     635  function ReadUntil(const ReadFrom: Integer; const C: Char): Integer;
     636  var
     637    J: Integer;
     638  begin
     639    for J := ReadFrom to Len do
     640      if (S[j] = C) then
     641      begin
     642        Result := J;
     643        Exit;
     644      end;
     645    Result := Len + 1;
     646  end;
     647
     648var
     649  I, APos: Integer;
     650begin
     651  Len := Length(S);
     652  I := 0;
     653  Result := '';
     654  while (I <= Len) do begin
     655    Inc(I);
     656    APos := ReadUntil(I, '<');
     657    Result := Result + Copy(S, I, APos - i);
     658    I := ReadUntil(APos + 1, '>');
     659  end;
     660end;
     661
     662function PosFromIndex(SubStr: string; Text: string;
     663  StartIndex: Integer): Integer;
     664var
     665  I, MaxLen: SizeInt;
     666  Ptr: PAnsiChar;
     667begin
     668  Result := 0;
     669  if (StartIndex < 1) or (StartIndex > Length(Text) - Length(SubStr)) then Exit;
     670  if Length(SubStr) > 0 then begin
     671    MaxLen := Length(Text) - Length(SubStr) + 1;
     672    I := StartIndex;
     673    Ptr := @Text[StartIndex];
     674    while (I <= MaxLen) do begin
     675      if (SubStr[1] = Ptr^) and (CompareByte(Substr[1], Ptr^, Length(SubStr)) = 0) then begin
     676        Result := I;
     677        Exit;
     678      end;
     679      Inc(I);
     680      Inc(Ptr);
     681    end;
     682  end;
     683end;
     684
     685function PosFromIndexReverse(SubStr: string; Text: string;
     686  StartIndex: Integer): Integer;
     687var
     688  I: SizeInt;
     689  Ptr: PAnsiChar;
     690begin
     691  Result := 0;
     692  if (StartIndex < 1) or (StartIndex > Length(Text)) then Exit;
     693  if Length(SubStr) > 0 then begin
     694    I := StartIndex;
     695    Ptr := @Text[StartIndex];
     696    while (I > 0) do begin
     697      if (SubStr[1] = Ptr^) and (CompareByte(Substr[1], Ptr^, Length(SubStr)) = 0) then begin
     698        Result := I;
     699        Exit;
     700      end;
     701      Dec(I);
     702      Dec(Ptr);
     703    end;
     704  end;
     705end;
     706
     707procedure CopyStringArray(Dest: TStringArray; Source: array of string);
     708var
     709  I: Integer;
     710begin
     711  SetLength(Dest, Length(Source));
     712  for I := 0 to Length(Dest) - 1 do
     713    Dest[I] := Source[I];
     714end;
     715
     716function CombinePaths(Path1, Path2: string): string;
     717begin
     718  Result := Path1;
     719  if Result <> '' then Result := Result + DirectorySeparator + Path2
     720    else Result := Path2;
     721end;
     722
     723procedure SortStrings(Strings: TStrings);
     724var
     725  Tmp: TStringList;
     726begin
     727  Strings.BeginUpdate;
     728  try
     729    if Strings is TStringList then begin
     730      TStringList(Strings).Sort;
     731    end else begin
     732      Tmp := TStringList.Create;
     733      try
     734        Tmp.Assign(Strings);
     735        Tmp.Sort;
     736        Strings.Assign(Tmp);
     737      finally
     738        Tmp.Free;
     739      end;
     740    end;
     741  finally
     742    Strings.EndUpdate;
     743  end;
     744end;
    513745
    514746

  • trunk/Packages/Common/CommonPackage.pas

    r74 r75  
    33 }
    44
    5 unit Common;
     5unit CommonPackage;
    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, LazarusPackageIntf;
     11  StopWatch, Common, DebugLog, Common.Delay, PrefixMultiplier, URI, Threading,
     12  Memory, ResetableThread, Pool, LastOpenedList, RegistryEx, JobProgressView,
     13  XML, ApplicationInfo, SyncCounter, ListViewSort, PersistentForm, FindFile,
     14  ScaleDPI, Theme, StringTable, MetaCanvas, Geometric, Translator, Languages,
     15  PixelPointer, DataFile, TestCase, Generics, Table, FormEx, FormTests,
     16  FormTest, FormAbout, LazarusPackageIntf;
    1417
    1518implementation
    … …  
    1720procedure Register;
    1821begin
    19   RegisterUnit('UDebugLog', @UDebugLog.Register);
    20   RegisterUnit('ULastOpenedList', @ULastOpenedList.Register);
    21   RegisterUnit('UJobProgressView', @UJobProgressView.Register);
    22   RegisterUnit('UApplicationInfo', @UApplicationInfo.Register);
    23   RegisterUnit('UListViewSort', @UListViewSort.Register);
    24   RegisterUnit('UPersistentForm', @UPersistentForm.Register);
    25   RegisterUnit('UFindFile', @UFindFile.Register);
     22  RegisterUnit('DebugLog', @DebugLog.Register);
     23  RegisterUnit('PrefixMultiplier', @PrefixMultiplier.Register);
     24  RegisterUnit('LastOpenedList', @LastOpenedList.Register);
     25  RegisterUnit('JobProgressView', @JobProgressView.Register);
     26  RegisterUnit('ApplicationInfo', @ApplicationInfo.Register);
     27  RegisterUnit('ListViewSort', @ListViewSort.Register);
     28  RegisterUnit('PersistentForm', @PersistentForm.Register);
     29  RegisterUnit('FindFile', @FindFile.Register);
     30  RegisterUnit('ScaleDPI', @ScaleDPI.Register);
     31  RegisterUnit('Theme', @Theme.Register);
     32  RegisterUnit('Translator', @Translator.Register);
     33  RegisterUnit('FormEx', @FormEx.Register);
    2634end;
    2735

  • trunk/Packages/Common/DebugLog.pas

    r74 r75  
    1 unit UDebugLog;
    2 
    3 {$mode delphi}
     1unit DebugLog;
    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;
    132134
    133135end.
    134 

  • trunk/Packages/Common/FindFile.pas

    r74 r75  
    1919}
    2020
    21 unit UFindFile;
     21unit FindFile;
    2222
    2323interface
    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
    … …  
    5552  end;
    5653
     54const
     55{$IFDEF WINDOWS}
     56  FilterAll = '*.*';
     57{$ENDIF}
     58{$IFDEF UNIX}
     59  FilterAll = '*';
     60{$ENDIF}
     61
    5762procedure Register;
     63
    5864
    5965implementation
    … …  
    7177  inherited Create(AOwner);
    7278  Path := IncludeTrailingBackslash(UTF8Encode(GetCurrentDir));
    73   FileMask := '*.*';
     79  FileMask := FilterAll;
    7480  FileAttr := [ffaAnyFile];
    7581  s := TStringList.Create;
    … …  
    7985begin
    8086  s.Free;
    81   inherited Destroy;
     87  inherited;
    8288end;
    8389
    … …  
    109115  Attr := 0;
    110116  if ffaReadOnly in FileAttr then Attr := Attr + faReadOnly;
    111   if ffaHidden in FileAttr then Attr := Attr + faHidden;
    112   if ffaSysFile in FileAttr then Attr := Attr + faSysFile;
    113   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;
    114120  if ffaDirectory in FileAttr then Attr := Attr + faDirectory;
    115121  if ffaArchive in FileAttr then Attr := Attr + faArchive;
    116122  if ffaAnyFile in FileAttr then Attr := Attr + faAnyFile;
    117123
    118   if SysUtils.FindFirst(UTF8Decode(inPath + FileMask), Attr, Rec) = 0 then
     124  if SysUtils.FindFirst(inPath + FileMask, Attr, Rec) = 0 then
    119125  try
    120126    repeat
    121       s.Add(inPath + UTF8Encode(Rec.Name));
     127      s.Add(inPath + Rec.Name);
    122128    until SysUtils.FindNext(Rec) <> 0;
    123129  finally
    … …  
    127133  If not InSubFolders then Exit;
    128134
    129   if SysUtils.FindFirst(UTF8Decode(inPath + '*.*'), faDirectory, Rec) = 0 then
     135  if SysUtils.FindFirst(inPath + FilterAll, faDirectory, Rec) = 0 then
    130136  try
    131137    repeat
    132138      if ((Rec.Attr and faDirectory) > 0) and (Rec.Name <> '.')
    133139      and (Rec.Name <> '..') then
    134         FileSearch(IncludeTrailingBackslash(inPath + UTF8Encode(Rec.Name)));
     140        FileSearch(IncludeTrailingBackslash(inPath + Rec.Name));
    135141    until SysUtils.FindNext(Rec) <> 0;
    136142  finally
    137143    SysUtils.FindClose(Rec);
    138144  end;
    139 end; 
     145end;
    140146
    141147end.
    142 

  • trunk/Packages/Common/JobProgressView.lfm

    r74 r75  
    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.1'
     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/JobProgressView.pas

    r74 r75  
    1 unit UJobProgressView;
    2 
    3 {$MODE Delphi}
     1unit JobProgressView;
    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, Threading, 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
    … …  
    148154  end;
    149155
    150   //var
    151   //  FormJobProgressView: TFormJobProgressView;
    152 
    153156procedure Register;
    154157
    155158resourcestring
    156159  SExecuted = 'Executed';
     160
    157161
    158162implementation
    … …  
    172176end;
    173177
     178{ TJobThread }
     179
    174180procedure TJobThread.Execute;
    175181begin
    176182  try
    177183    try
    178       //raise Exception.Create('Exception in job');
    179184      ProgressView.CurrentJob.Method(Job);
    180185    except
    … …  
    189194end;
    190195
    191 procedure TJobProgressView.AddJob(Title: string; Method: TJobProgressViewMethod;
    192   NoThreaded: Boolean = False; WaitFor: Boolean = False);
     196{ TFormJobProgressView }
     197
     198procedure TFormJobProgressView.UpdateHeight;
    193199var
    194   NewJob: TJob;
    195 begin
    196   NewJob := TJob.Create;
    197   NewJob.ProgressView := Self;
    198   NewJob.Title := Title;
    199   NewJob.Method := Method;
    200   NewJob.NoThreaded := NoThreaded;
    201   NewJob.WaitFor := WaitFor;
    202   NewJob.Progress.Max := 100;
    203   NewJob.Progress.Reset;
    204   NewJob.Progress.OnChange := JobProgressChange;
    205   Jobs.Add(NewJob);
     200  H: Integer;
     201  PanelOperationsVisible: Boolean;
     202  PanelOperationsHeight: Integer;
     203  PanelProgressVisible: Boolean;
     204  PanelProgressTotalVisible: Boolean;
     205  PanelLogVisible: Boolean;
     206  MemoLogHeight: Integer = 200;
     207  I: Integer;
     208  ItemRect: TRect;
     209  MaxH: Integer;
     210begin
     211    H := PanelOperationsTitle.Height;
     212    PanelOperationsVisible := JobProgressView.Jobs.Count > 0;
     213    if PanelOperationsVisible <> PanelOperations.Visible then
     214      PanelOperations.Visible := PanelOperationsVisible;
     215    if ListViewJobs.Items.Count > 0 then begin
     216      Maxh := 0;
     217      for I := 0 to ListViewJobs.Items.Count - 1 do
     218      begin
     219        ItemRect := ListViewJobs.Items[i].DisplayRect(drBounds);
     220        Maxh := Max(Maxh, ItemRect.Top + (ItemRect.Bottom - ItemRect.Top));
     221      end;
     222      PanelOperationsHeight := Scale96ToScreen(12) + Maxh;
     223    end else PanelOperationsHeight := Scale96ToScreen(8);
     224    if PanelOperationsHeight <> PanelOperations.Height then
     225      PanelOperations.Height := PanelOperationsHeight;
     226    if PanelOperationsVisible then
     227      H := H + PanelOperations.Height;
     228
     229    PanelProgressVisible := (JobProgressView.Jobs.Count > 0) and not JobProgressView.Finished;
     230    if PanelProgressVisible <> PanelProgress.Visible then
     231      PanelProgress.Visible := PanelProgressVisible;
     232    if PanelProgressVisible then
     233      H := H + PanelProgress.Height;
     234    PanelProgressTotalVisible := (JobProgressView.Jobs.Count > 1) and not JobProgressView.Finished;
     235    if PanelProgressTotalVisible <> PanelProgressTotal.Visible then
     236      PanelProgressTotal.Visible := PanelProgressTotalVisible;
     237    if PanelProgressTotalVisible then
     238      H := H + PanelProgressTotal.Height;
     239    Constraints.MinHeight := H;
     240    PanelLogVisible := MemoLog.Lines.Count > 0;
     241    if PanelLogVisible <> PanelLog.Visible then
     242      PanelLog.Visible := PanelLogVisible;
     243    if PanelLogVisible then
     244      H := H + Scale96ToScreen(MemoLogHeight);
     245    if PanelText.Visible then
     246      H := H + PanelText.Height;
     247    if Height <> H then begin
     248      Height := H;
     249      Top := (Screen.Height - H) div 2;
     250    end;
     251end;
     252
     253procedure TFormJobProgressView.TimerUpdateTimer(Sender: TObject);
     254var
     255  ProgressBarPartVisible: Boolean;
     256  ProgressBarTotalVisible: Boolean;
     257begin
     258  JobProgressView.UpdateProgress;
     259  if Visible and (not ProgressBarPart.Visible) and
     260  Assigned(JobProgressView.CurrentJob) and
     261  (JobProgressView.CurrentJob.Progress.Value > 0) then begin
     262    ProgressBarPartVisible := True;
     263    if ProgressBarPartVisible <> ProgressBarPart.Visible then
     264      ProgressBarPart.Visible := ProgressBarPartVisible;
     265    ProgressBarTotalVisible := True;
     266    if ProgressBarTotalVisible <> ProgressBarTotal.Visible then
     267      ProgressBarTotal.Visible := ProgressBarTotalVisible;
     268  end;
     269  if not Visible then begin
     270    TimerUpdate.Interval := UpdateInterval;
     271    if not JobProgressView.OwnerDraw then Show;
     272  end;
     273  if Assigned(JobProgressView.CurrentJob) then begin
     274    LabelText.Caption := JobProgressView.CurrentJob.Progress.Text;
     275    if LabelText.Caption <> '' then begin
     276      PanelText.Visible := True;
     277      UpdateHeight;
     278    end;
     279  end;
     280end;
     281
     282procedure TFormJobProgressView.ListViewJobsData(Sender: TObject; Item: TListItem);
     283begin
     284  if (Item.Index >= 0) and (Item.Index < JobProgressView.Jobs.Count) then
     285  with JobProgressView.Jobs[Item.Index] do begin
     286    Item.Caption := Title;
     287    if Item.Index = JobProgressView.CurrentJobIndex then Item.ImageIndex := 1
     288      else if Finished then Item.ImageIndex := 0
     289      else Item.ImageIndex := 2;
     290    Item.Data := JobProgressView.Jobs[Item.Index];
     291  end;
     292end;
     293
     294procedure TFormJobProgressView.FormClose(Sender: TObject;
     295  var CloseAction: TCloseAction);
     296begin
     297end;
     298
     299procedure TFormJobProgressView.FormCreate(Sender: TObject);
     300begin
     301  Caption := SPleaseWait;
     302  try
     303    //Animate1.FileName := ExtractFileDir(UTF8Encode(Application.ExeName)) +
     304    //  DirectorySeparator + 'horse.avi';
     305    //Animate1.Active := True;
     306  except
     307
     308  end;
     309end;
     310
     311procedure TFormJobProgressView.ReloadJobList;
     312begin
     313  // Workaround for not showing first line
     314  //Form.ListViewJobs.Items.Count := Jobs.Count + 1;
     315  //Form.ListViewJobs.Refresh;
     316
     317  if ListViewJobs.Items.Count <> JobProgressView.Jobs.Count then
     318    ListViewJobs.Items.Count := JobProgressView.Jobs.Count;
     319  ListViewJobs.Refresh;
     320  Application.ProcessMessages;
     321  UpdateHeight;
     322end;
     323
     324procedure TFormJobProgressView.FormShow(Sender: TObject);
     325begin
     326  ReloadJobList;
     327end;
     328
     329procedure TFormJobProgressView.FormHide(Sender: TObject);
     330begin
     331  JobProgressView.Jobs.Clear;
     332  ReloadJobList;
     333end;
     334
     335procedure TFormJobProgressView.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
     336begin
     337  CanClose := JobProgressView.Finished;
     338  JobProgressView.Terminate := True;
     339  Caption := SPleaseWait + STerminate;
     340end;
     341
     342
     343{ TJobProgressView }
     344
     345function TJobProgressView.AddJob(Title: string; Method: TJobProgressViewMethod;
     346  NoThreaded: Boolean = False; WaitFor: Boolean = False): TJob;
     347begin
     348  Result := TJob.Create;
     349  Result.ProgressView := Self;
     350  Result.Title := Title;
     351  Result.Method := Method;
     352  Result.NoThreaded := NoThreaded;
     353  Result.WaitFor := WaitFor;
     354  Result.Progress.Max := 100;
     355  Result.Progress.Reset;
     356  Result.Progress.OnChange := JobProgressChange;
     357  Jobs.Add(Result);
    206358  //ReloadJobList;
    207359end;
    208360
    209 procedure TJobProgressView.Start(AAutoClose: Boolean = True);
    210 begin
    211   AutoClose := AAutoClose;
    212   StartJobs;
    213 end;
    214 
    215 procedure TJobProgressView.StartJobs;
     361procedure TJobProgressView.Start;
    216362var
    217363  I: Integer;
    … …  
    228374    Form.MemoLog.Clear;
    229375
     376    Form.PanelText.Visible := False;
    230377    Form.LabelEstimatedTimePart.Visible := False;
    231378    Form.LabelEstimatedTimeTotal.Visible := False;
    … …  
    248395    I := 0;
    249396    while I < Jobs.Count do
    250     with TJob(Jobs[I]) do begin
     397    with Jobs[I] do begin
    251398      CurrentJobIndex := I;
    252       CurrentJob := TJob(Jobs[I]);
     399      CurrentJob := Jobs[I];
    253400      JobProgressChange(Self);
    254401      StartTime := Now;
    … …  
    257404      Form.ProgressBarPart.Visible := False;
    258405      //Show;
    259       ReloadJobList;
     406      Form.ReloadJobList;
    260407      Application.ProcessMessages;
    261408      if NoThreaded then begin
    … …  
    263410        Method(CurrentJob);
    264411      end else begin
     412        Thread := TJobThread.Create(True);
    265413        try
    266           Thread := TJobThread.Create(True);
    267414          with Thread do begin
    268415            FreeOnTerminate := False;
    … …  
    295442    //if Visible then Hide;
    296443    Form.MemoLog.Lines.Assign(Log);
    297     if (Form.MemoLog.Lines.Count = 0) and AutoClose then begin
     444    if (Form.MemoLog.Lines.Count = 0) and FAutoClose then begin
    298445      Form.Hide;
    299446    end;
    300     Clear;
     447    if not Form.Visible then Clear;
    301448    Form.Caption := SFinished;
    302449    //LabelEstimatedTimePart.Visible := False;
    303450    Finished := True;
    304451    CurrentJobIndex := -1;
    305     ReloadJobList;
    306   end;
    307 end;
    308 
    309 procedure TJobProgressView.UpdateHeight;
    310 var
    311   H: Integer;
    312   PanelOperationsVisible: Boolean;
    313   PanelOperationsHeight: Integer;
    314   PanelProgressVisible: Boolean;
    315   PanelProgressTotalVisible: Boolean;
    316   PanelLogVisible: Boolean;
    317 begin
    318   with Form do begin
    319   H := PanelOperationsTitle.Height;
    320   PanelOperationsVisible := Jobs.Count > 0;
    321   if PanelOperationsVisible <> PanelOperations.Visible then
    322     PanelOperations.Visible := PanelOperationsVisible;
    323   PanelOperationsHeight := 8 + 18 * Jobs.Count;
    324   if PanelOperationsHeight <> PanelOperations.Height then
    325     PanelOperations.Height := PanelOperationsHeight;
    326   if PanelOperationsVisible then
    327     H := H + PanelOperations.Height;
    328 
    329   PanelProgressVisible := (Jobs.Count > 0) and not Finished;
    330   if PanelProgressVisible <> PanelProgress.Visible then
    331     PanelProgress.Visible := PanelProgressVisible;
    332   if PanelProgressVisible then
    333     H := H + PanelProgress.Height;
    334   PanelProgressTotalVisible := (Jobs.Count > 1) and not Finished;
    335   if PanelProgressTotalVisible <> PanelProgressTotal.Visible then
    336     PanelProgressTotal.Visible := PanelProgressTotalVisible;
    337   if PanelProgressTotalVisible then
    338     H := H + PanelProgressTotal.Height;
    339   Constraints.MinHeight := H;
    340   PanelLogVisible := MemoLog.Lines.Count > 0;
    341   if PanelLogVisible <> PanelLog.Visible then
    342     PanelLog.Visible := PanelLogVisible;
    343   if PanelLogVisible then
    344     H := H + MemoLogHeight;
    345   if Height <> H then Height := H;
     452    Form.ReloadJobList;
    346453  end;
    347454end;
    … …  
    351458  if Assigned(FOnOwnerDraw) then
    352459    FOnOwnerDraw(Self);
    353 end;
    354 
    355 procedure TFormJobProgressView.TimerUpdateTimer(Sender: TObject);
    356 var
    357   ProgressBarPartVisible: Boolean;
    358   ProgressBarTotalVisible: Boolean;
    359 begin
    360   JobProgressView.UpdateProgress;
    361   if Visible and (not ProgressBarPart.Visible) and
    362   Assigned(JobProgressView.CurrentJob) and
    363   (JobProgressView.CurrentJob.Progress.Value > 0) then begin
    364     ProgressBarPartVisible := True;
    365     if ProgressBarPartVisible <> ProgressBarPart.Visible then
    366       ProgressBarPart.Visible := ProgressBarPartVisible;
    367     ProgressBarTotalVisible := True;
    368     if ProgressBarTotalVisible <> ProgressBarTotal.Visible then
    369       ProgressBarTotal.Visible := ProgressBarTotalVisible;
    370   end;
    371   if not Visible then begin
    372     TimerUpdate.Interval := UpdateInterval;
    373     if not JobProgressView.OwnerDraw then Show;
    374   end;
    375 end;
    376 
    377 procedure TFormJobProgressView.FormDestroy(Sender:TObject);
    378 begin
    379 end;
    380 
    381 procedure TFormJobProgressView.ListViewJobsData(Sender: TObject; Item: TListItem);
    382 begin
    383   if (Item.Index >= 0) and (Item.Index < JobProgressView.Jobs.Count) then
    384   with TJob(JobProgressView.Jobs[Item.Index]) do begin
    385     Item.Caption := Title;
    386     if Item.Index = JobProgressView.CurrentJobIndex then Item.ImageIndex := 1
    387       else if Finished then Item.ImageIndex := 0
    388       else Item.ImageIndex := 2;
    389     Item.Data := JobProgressView.Jobs[Item.Index];
    390   end;
    391 end;
    392 
    393 procedure TFormJobProgressView.FormClose(Sender: TObject;
    394   var CloseAction: TCloseAction);
    395 begin
    396   ListViewJobs.Clear;
    397 end;
    398 
    399 procedure TFormJobProgressView.FormCreate(Sender: TObject);
    400 begin
    401   Caption := SPleaseWait;
    402   try
    403     //Animate1.FileName := ExtractFileDir(UTF8Encode(Application.ExeName)) +
    404     //  DirectorySeparator + 'horse.avi';
    405     //Animate1.Active := True;
    406   except
    407 
    408   end;
    409460end;
    410461
    … …  
    427478end;
    428479
    429 procedure TFormJobProgressView.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    430 begin
    431   CanClose := JobProgressView.Finished;
    432   JobProgressView.Terminate := True;
    433   Caption := SPleaseWait + STerminate;
    434 end;
    435 
    436480procedure TJobProgressView.SetTerminate(const AValue: Boolean);
    437481var
    … …  
    440484  if AValue = FTerminate then Exit;
    441485  for I := 0 to Jobs.Count - 1 do
    442     TJob(Jobs[I]).Terminate := AValue;
     486    Jobs[I].Terminate := AValue;
    443487  FTerminate := AValue;
    444488end;
    … …  
    489533end;
    490534
    491 procedure TJobProgressView.ReloadJobList;
    492 begin
    493   UpdateHeight;
    494   // Workaround for not showing first line
    495   Form.ListViewJobs.Items.Count := Jobs.Count + 1;
    496   Form.ListViewJobs.Refresh;
    497 
    498   if Form.ListViewJobs.Items.Count <> Jobs.Count then
    499     Form.ListViewJobs.Items.Count := Jobs.Count;
    500   Form.ListViewJobs.Refresh;
    501   //Application.ProcessMessages;
    502 end;
    503 
    504535constructor TJobProgressView.Create(TheOwner: TComponent);
    505536begin
    506537  inherited;
    507538  if not (csDesigning in ComponentState) then begin
    508     Form := TFormJobProgressView.Create(Self);
    509     Form.JobProgressView := Self;
    510   end;
    511   Jobs := TObjectList.Create;
     539    FForm := TFormJobProgressView.Create(Self);
     540    FForm.JobProgressView := Self;
     541  end;
     542  Jobs := TJobs.Create;
    512543  Log := TStringList.Create;
    513544  //PanelOperationsTitle.Height := 80;
    514   ShowDelay := 0; //1000; // ms
     545  AutoClose := True;
     546  ShowDelay := 0;
    515547end;
    516548
    … …  
    518550begin
    519551  Jobs.Clear;
     552  Log.Clear;
    520553  //ReloadJobList;
    521554end;
    … …  
    527560  inherited;
    528561end;
     562
     563{ TProgress }
    529564
    530565procedure TProgress.SetMax(const AValue: Integer);
    … …  
    535570    if FMax < 1 then FMax := 1;
    536571    if FValue >= FMax then FValue := FMax;
     572  finally
     573    FLock.Release;
     574  end;
     575end;
     576
     577procedure TProgress.SetText(AValue: string);
     578begin
     579  try
     580    FLock.Acquire;
     581    if FText = AValue then Exit;
     582    FText := AValue;
    537583  finally
    538584    FLock.Release;
    … …  
    562608end;
    563609
    564 { TProgress }
    565 
    566610procedure TProgress.Increment;
    567611begin
    568   try
    569     FLock.Acquire;
     612  FLock.Acquire;
     613  try
    570614    Value := Value + 1;
    571615  finally
    … …  
    576620procedure TProgress.Reset;
    577621begin
    578   try
    579     FLock.Acquire;
     622  FLock.Acquire;
     623  try
    580624    FValue := 0;
    581625  finally
    … …  
    593637begin
    594638  FLock.Free;
    595   inherited Destroy;
     639  inherited;
    596640end;
    597641
    … …  
    624668destructor TJob.Destroy;
    625669begin
    626   Progress.Free;
     670  FreeAndNil(Progress);
    627671  inherited;
    628672end;

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

    r74 r75  
    11msgid ""
    22msgstr ""
    3 "Content-Type: text/plain; charset=UTF-8\n"
    43"Project-Id-Version: \n"
    54"POT-Creation-Date: \n"
    … …  
    76"Last-Translator: Jiří Hajda <robie@centrum.cz>\n"
    87"Language-Team: \n"
     8"Language: cs\n"
    99"MIME-Version: 1.0\n"
     10"Content-Type: text/plain; charset=UTF-8\n"
    1011"Content-Transfer-Encoding: 8bit\n"
     12"X-Generator: Poedit 3.0.1\n"
    1113
    12 #: udebuglog.sfilenamenotdefined
     14#: debuglog.sfilenamenotdefined
     15msgctxt "debuglog.sfilenamenotdefined"
    1316msgid "Filename not defined"
    1417msgstr "Neurčen soubor"

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

    r74 r75  
    11msgid ""
    22msgstr ""
    3 "Content-Type: text/plain; charset=UTF-8\n"
    43"Project-Id-Version: \n"
    54"POT-Creation-Date: \n"
    … …  
    76"Last-Translator: Chronos <robie@centrum.cz>\n"
    87"Language-Team: \n"
     8"Language: cs\n"
    99"MIME-Version: 1.0\n"
     10"Content-Type: text/plain; charset=UTF-8\n"
    1011"Content-Transfer-Encoding: 8bit\n"
     12"X-Generator: Poedit 3.0.1\n"
    1113
    12 #: upool.sobjectpoolempty
     14#: pool.sobjectpoolempty
     15msgctxt "pool.sobjectpoolempty"
    1316msgid "Object pool is empty"
    1417msgstr "Zásobník objektů je prázdný"
    1518
    16 #: upool.sreleaseerror
     19#: pool.sreleaseerror
     20msgctxt "pool.sreleaseerror"
    1721msgid "Unknown object for release from pool"
    1822msgstr "Neznýmý objekt pro uvolnění ze zásobníku"

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

    r74 r75  
    11msgid ""
    22msgstr ""
    3 "Content-Type: text/plain; charset=UTF-8\n"
    43"Project-Id-Version: \n"
    54"POT-Creation-Date: \n"
    … …  
    76"Last-Translator: Chronos <robie@centrum.cz>\n"
    87"Language-Team: \n"
     8"Language: cs\n"
    99"MIME-Version: 1.0\n"
     10"Content-Type: text/plain; charset=UTF-8\n"
    1011"Content-Transfer-Encoding: 8bit\n"
     12"X-Generator: Poedit 3.0.1\n"
    1113
    12 #: uresetablethread.swaiterror
     14#: resetablethread.swaiterror
     15msgctxt "resetablethread.swaiterror"
    1316msgid "WaitFor error"
    1417msgstr "Chyba WaitFor"

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

    r74 r75  
    11msgid ""
    22msgstr ""
    3 "Content-Type: text/plain; charset=UTF-8\n"
    43"Project-Id-Version: \n"
    54"POT-Creation-Date: \n"
    … …  
    76"Last-Translator: Chronos <robie@centrum.cz>\n"
    87"Language-Team: \n"
     8"Language: cs\n"
    99"MIME-Version: 1.0\n"
     10"Content-Type: text/plain; charset=UTF-8\n"
    1011"Content-Transfer-Encoding: 8bit\n"
     12"X-Generator: Poedit 3.0.1\n"
    1113
    12 #: uthreading.scurrentthreadnotfound
     14#: threading.scurrentthreadnotfound
     15#, object-pascal-format
     16msgctxt "threading.scurrentthreadnotfound"
    1317msgid "Current thread ID %d not found in virtual thread list."
    1418msgstr "Aktuální vlákno ID %d nenalezeno v seznamu virtuálních vláken."

  • trunk/Packages/Common/LastOpenedList.pas

    r74 r75  
    1 unit ULastOpenedList;
    2 
    3 {$mode delphi}
     1unit LastOpenedList;
    42
    53interface
    64
    75uses
    8   Classes, SysUtils, Registry, URegistry, Menus;
     6  Classes, SysUtils, Registry, RegistryEx, Menus, XMLConf, DOM;
    97
    108type
    … …  
    2725    procedure LoadFromRegistry(Context: TRegistryContext);
    2826    procedure SaveToRegistry(Context: TRegistryContext);
     27    procedure LoadFromXMLConfig(XMLConfig: TXMLConfig; Path: string);
     28    procedure SaveToXMLConfig(XMLConfig: TXMLConfig; Path: string);
    2929    procedure AddItem(FileName: string);
     30    function GetFirstFileName: string;
    3031  published
    3132    property MaxCount: Integer read FMaxCount write SetMaxCount;
    … …  
    8182destructor TLastOpenedList.Destroy;
    8283begin
    83   Items.Free;
     84  FreeAndNil(Items);
    8485  inherited;
    8586end;
    … …  
    9192begin
    9293  if Assigned(MenuItem) then begin
    93     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;
    94100    for I := 0 to Items.Count - 1 do begin
    95       NewMenuItem := TMenuItem.Create(MenuItem);
    96       NewMenuItem.Caption := Items[I];
    97       NewMenuItem.OnClick := ClickAction;
    98       MenuItem.Add(NewMenuItem);
     101      MenuItem.Items[I].Caption := Items[I];
     102      MenuItem.Items[I].OnClick := ClickAction;
    99103    end;
    100104  end;
    … …  
    137141    OpenKey(Context.Key, True);
    138142    for I := 0 to Items.Count - 1 do
    139       WriteString('File' + IntToStr(I), UTF8Decode(Items[I]));
     143      WriteString('File' + IntToStr(I), Items[I]);
    140144  finally
    141145    Free;
     146  end;
     147end;
     148
     149procedure TLastOpenedList.LoadFromXMLConfig(XMLConfig: TXMLConfig; Path: string
     150  );
     151var
     152  I: Integer;
     153  Value: string;
     154  Count: Integer;
     155begin
     156  with XMLConfig do begin
     157    Count := GetValue(DOMString(Path + '/Count'), 0);
     158    if Count > MaxCount then Count := MaxCount;
     159    Items.Clear;
     160    for I := 0 to Count - 1 do begin
     161      Value := string(GetValue(DOMString(Path + '/File' + IntToStr(I)), ''));
     162      if Trim(Value) <> '' then Items.Add(Value);
     163    end;
     164    if Assigned(FOnChange) then
     165      FOnChange(Self);
     166  end;
     167end;
     168
     169procedure TLastOpenedList.SaveToXMLConfig(XMLConfig: TXMLConfig; Path: string);
     170var
     171  I: Integer;
     172begin
     173  with XMLConfig do begin
     174    SetValue(DOMString(Path + '/Count'), Items.Count);
     175    for I := 0 to Items.Count - 1 do
     176      SetValue(DOMString(Path + '/File' + IntToStr(I)), DOMString(Items[I]));
     177    Flush;
    142178  end;
    143179end;
    … …  
    151187end;
    152188
     189function TLastOpenedList.GetFirstFileName: string;
     190begin
     191  if Items.Count > 0 then Result := Items[0]
     192    else Result := '';
     193end;
     194
    153195end.
    154 

  • trunk/Packages/Common/ListViewSort.pas

    r74 r75  
    1 unit UListViewSort;
    2 
    3 // Date: 2010-11-03
    4 
    5 {$mode delphi}
     1unit ListViewSort;
     2
     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;
     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;
    1211
    1312type
    … …  
    1817  TCompareEvent = function (Item1, Item2: TObject): Integer of object;
    1918  TListFilterEvent = procedure (ListViewSort: TListViewSort) of object;
     19
     20  TObjects = TObjectList<TObject>;
     21
     22  { TListViewSort }
    2023
    2124  TListViewSort = class(TComponent)
    … …  
    2831    FColumn: Integer;
    2932    FOrder: TSortOrder;
     33    FOldListViewWindowProc: TWndMethod;
     34    FOnColumnWidthChanged: TNotifyEvent;
     35    procedure DoColumnBeginResize(const AColIndex: Integer);
     36    procedure DoColumnResized(const AColIndex: Integer);
     37    procedure DoColumnResizing(const AColIndex, AWidth: Integer);
    3038    procedure SetListView(const Value: TListView);
    3139    procedure ColumnClick(Sender: TObject; Column: TListColumn);
    … …  
    4048    procedure SetColumn(const Value: Integer);
    4149    procedure SetOrder(const Value: TSortOrder);
     50    {$IFDEF WINDOWS}
     51    procedure NewListViewWindowProc(var AMsg: TMessage);
     52    {$ENDIF}
    4253  public
    43     List: TListObject;
    44     Source: TListObject;
     54    Source: TObjects;
     55    List: TObjects;
    4556    constructor Create(AOwner: TComponent); override;
    4657    destructor Destroy; override;
    … …  
    5869    property OnCustomDraw: TLVCustomDrawItemEvent read FOnCustomDraw
    5970      write FOnCustomDraw;
     71    property OnColumnWidthChanged: TNotifyEvent read FOnColumnWidthChanged
     72      write FOnColumnWidthChanged;
    6073    property Column: Integer read FColumn write SetColumn;
    6174    property Order: TSortOrder read FOrder write SetOrder;
    … …  
    6881    FOnChange: TNotifyEvent;
    6982    FStringGrid1: TStringGrid;
    70     procedure DoOnKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
     83    procedure DoOnChange;
     84    procedure GridDoOnKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
     85    procedure GridDoOnResize(Sender: TObject);
    7186  public
    7287    constructor Create(AOwner: TComponent); override;
    7388    procedure UpdateFromListView(ListView: TListView);
    7489    function TextEntered: Boolean;
     90    function TextEnteredCount: Integer;
     91    function TextEnteredColumn(Index: Integer): Boolean;
    7592    function GetColValue(Index: Integer): string;
     93    procedure Reset;
    7694    property StringGrid: TStringGrid read FStringGrid1 write FStringGrid1;
    7795  published
    … …  
    7997    property Align;
    8098    property Anchors;
     99    property BorderSpacing;
     100  end;
     101
     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;
    81118  end;
    82119
    … …  
    88125procedure Register;
    89126begin
    90   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;
    91152end;
    92153
    93154{ TListViewFilter }
    94155
    95 procedure TListViewFilter.DoOnKeyUp(Sender: TObject; var Key: Word;
     156procedure TListViewFilter.DoOnChange;
     157begin
     158  if Assigned(FOnChange) then FOnChange(Self);
     159end;
     160
     161procedure TListViewFilter.GridDoOnKeyUp(Sender: TObject; var Key: Word;
    96162  Shift: TShiftState);
    97163begin
    98   if Assigned(FOnChange) then
    99     FOnChange(Self);
     164  DoOnChange;
     165end;
     166
     167procedure TListViewFilter.GridDoOnResize(Sender: TObject);
     168begin
     169  FStringGrid1.DefaultRowHeight := FStringGrid1.Height;
    100170end;
    101171
    … …  
    113183  FStringGrid1.Options := [goFixedHorzLine, goFixedVertLine, goVertLine,
    114184    goHorzLine, goRangeSelect, goEditing, goAlwaysShowEditor, goSmoothScroll];
    115   FStringGrid1.OnKeyUp := DoOnKeyUp;
     185  FStringGrid1.OnKeyUp := GridDoOnKeyUp;
     186  FStringGrid1.OnResize := GridDoOnResize;
    116187end;
    117188
    … …  
    119190var
    120191  I: Integer;
    121   NewColumn: TGridColumn;
     192  R: TRect;
    122193begin
    123194  with FStringGrid1 do begin
    124     Columns.Clear;
    125195    while Columns.Count > ListView.Columns.Count do Columns.Delete(Columns.Count - 1);
    126     while Columns.Count < ListView.Columns.Count do NewColumn := Columns.Add;
     196    while Columns.Count < ListView.Columns.Count do Columns.Add;
    127197    for I := 0 to ListView.Columns.Count - 1 do begin
    128198      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;
    129204    end;
    130205  end;
    … …  
    132207
    133208function TListViewFilter.TextEntered: Boolean;
     209begin
     210  Result := TextEnteredCount > 0;
     211end;
     212
     213function TListViewFilter.TextEnteredCount: Integer;
    134214var
    135215  I: Integer;
    136216begin
    137   Result := False;
     217  Result := 0;
    138218  for I := 0 to FStringGrid1.ColCount - 1 do begin
    139219    if FStringGrid1.Cells[I, 0] <> '' then begin
    140       Result := True;
    141       Break;
     220      Inc(Result);
    142221    end;
    143222  end;
     223end;
     224
     225function TListViewFilter.TextEnteredColumn(Index: Integer): Boolean;
     226begin
     227  Result := FStringGrid1.Cells[Index, 0] <> '';
    144228end;
    145229
    … …  
    151235end;
    152236
     237procedure TListViewFilter.Reset;
     238var
     239  I: Integer;
     240begin
     241  with StringGrid do
     242  for I := 0 to ColCount - 1 do
     243    Cells[I, 0] := '';
     244  DoOnChange;
     245end;
     246
    153247{ TListViewSort }
    154248
     249{$IFDEF WINDOWS}
     250procedure TListViewSort.NewListViewWindowProc(var AMsg: TMessage);
     251var
     252  vColWidth: Integer;
     253  vMsgNotify: TLMNotify absolute AMsg;
     254  Code: Integer;
     255begin
     256  // call the old WindowProc of ListView
     257  FOldListViewWindowProc(AMsg);
     258
     259  // Currently we care only with WM_NOTIFY message
     260  if AMsg.Msg = WM_NOTIFY then
     261  begin
     262    Code := NMHDR(PHDNotify(vMsgNotify.NMHdr)^.Hdr).Code;
     263    case Code of
     264      HDN_ENDTRACKA, HDN_ENDTRACKW:
     265        DoColumnResized(PHDNotify(vMsgNotify.NMHdr)^.Item);
     266
     267      HDN_BEGINTRACKA, HDN_BEGINTRACKW:
     268        DoColumnBeginResize(PHDNotify(vMsgNotify.NMHdr)^.Item);
     269
     270      HDN_TRACKA, HDN_TRACKW:
     271        begin
     272          vColWidth := -1;
     273          if (PHDNotify(vMsgNotify.NMHdr)^.PItem<>nil)
     274             and (PHDNotify(vMsgNotify.NMHdr)^.PItem^.Mask and HDI_WIDTH <> 0)
     275          then
     276            vColWidth := PHDNotify(vMsgNotify.NMHdr)^.PItem^.cxy;
     277
     278          DoColumnResizing(PHDNotify(vMsgNotify.NMHdr)^.Item, vColWidth);
     279        end;
     280    end;
     281  end;
     282end;
     283{$ENDIF}
     284
     285procedure TListViewSort.DoColumnBeginResize(const AColIndex: Integer);
     286begin
     287end;
     288
     289procedure TListViewSort.DoColumnResizing(const AColIndex, AWidth: Integer);
     290begin
     291end;
     292
     293procedure TListViewSort.DoColumnResized(const AColIndex: Integer);
     294begin
     295  if Assigned(FOnColumnWidthChanged) then
     296    FOnColumnWidthChanged(Self);
     297end;
    155298
    156299procedure TListViewSort.ColumnClick(Sender: TObject; Column: TListColumn);
    … …  
    179322procedure TListViewSort.SetListView(const Value: TListView);
    180323begin
     324  if FListView = Value then Exit;
     325  if Assigned(FListView) then
     326    ListView.WindowProc := FOldListViewWindowProc;
    181327  FListView := Value;
    182328  FListView.OnColumnClick := ColumnClick;
    183329  FListView.OnCustomDrawItem := ListViewCustomDrawItem;
    184330  FListView.OnClick := ListViewClick;
     331  FOldListViewWindowProc := FListView.WindowProc;
     332  {$IFDEF WINDOWS}
     333  FListView.WindowProc := NewListViewWindowProc;
     334  {$ENDIF}
     335end;
     336
     337var
     338  ListViewSortCompare: TCompareEvent;
     339
     340function ListViewCompare(constref Item1, Item2: TObject): Integer;
     341begin
     342  Result := ListViewSortCompare(Item1, Item2);
    185343end;
    186344
    187345procedure TListViewSort.Sort(Compare: TCompareEvent);
    188346begin
     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;
    189350  if (List.Count > 0) then
    190     List.Sort(Compare);
     351    List.Sort(TComparer<TObject>.Construct(ListViewCompare));
    191352end;
    192353
    … …  
    194355begin
    195356  if Assigned(FOnFilter) then FOnFilter(Self)
    196   else if Assigned(Source) then
    197     List.Assign(Source) else
     357  else if Assigned(Source) then begin
    198358    List.Clear;
     359    List.AddRange(Source);
     360  end else List.Clear;
    199361  if ListView.Items.Count <> List.Count then
    200362    ListView.Items.Count := List.Count;
    201   if Assigned(FOnCompareItem) then Sort(FOnCompareItem);
     363  if Assigned(FOnCompareItem) and (Order <> soNone) then Sort(FOnCompareItem);
    202364  //ListView.Items[-1]; // Workaround for not show first row if selected
    203365  ListView.Refresh;
    … …  
    251413begin
    252414  inherited;
    253   List := TListObject.Create;
     415  List := TObjects.Create;
    254416  List.OwnsObjects := False;
    255417end;
    … …  
    257419destructor TListViewSort.Destroy;
    258420begin
    259   List.Free;
     421  FreeAndNil(List);
    260422  inherited;
    261423end;
    … …  
    266428  TP1: TPoint;
    267429  XBias, YBias: Integer;
    268   OldColor: TColor;
     430  PenColor: TColor;
     431  BrushColor: TColor;
    269432  BiasTop, BiasLeft: Integer;
    270433  Rect1: TRect;
    … …  
    278441  Item.Left := 0;
    279442  GetCheckBias(XBias, YBias, BiasTop, BiasLeft, ListView);
    280   OldColor := ListView.Canvas.Pen.Color;
     443  PenColor := ListView.Canvas.Pen.Color;
     444  BrushColor := ListView.Canvas.Brush.Color;
    281445  //TP1 := Item.GetPosition;
    282446  lRect := Item.DisplayRect(drBounds); // Windows 7 workaround
    … …  
    290454  ItemLeft := Item.Left;
    291455  ItemLeft := 23; // Windows 7 workaround
    292  
     456
    293457  Rect1.Left := ItemLeft - CheckWidth - BiasLeft + 1 + XBias;
    294458  //ShowMessage(IntToStr(Tp1.Y) + ', ' + IntToStr(BiasTop) + ', ' + IntToStr(XBias));
    … …  
    321485  end;
    322486  //ListView.Canvas.Brush.Color := ListView.Color;
    323   ListView.Canvas.Brush.Color := clWindow;
    324   ListView.Canvas.Pen.Color := OldColor;
     487  ListView.Canvas.Brush.Color := BrushColor;
     488  ListView.Canvas.Pen.Color := PenColor;
    325489end;
    326490
    … …  
    389553    FHeaderHandle := ListView_GetHeader(FListView.Handle);
    390554    for I := 0 to FListView.Columns.Count - 1 do begin
     555      {$push}{$warn 5057 off}
    391556      FillChar(Item, SizeOf(THDItem), 0);
     557      {$pop}
    392558      Item.Mask := HDI_FORMAT;
    393559      Header_GetItem(FHeaderHandle, I, Item);

  • trunk/Packages/Common/Memory.pas

    r74 r75  
    1 unit UMemory;
    2 
    3 {$mode Delphi}{$H+}
     1unit Memory;
    42
    53interface
    … …  
    2422    constructor Create;
    2523    destructor Destroy; override;
     24    procedure WriteMemory(Position: Integer; Memory: TMemory);
     25    procedure ReadMemory(Position: Integer; Memory: TMemory);
    2626    property Data: PByte read FData;
    2727    property Size: Integer read FSize write SetSize;
    … …  
    4242  end;
    4343
     44
    4445implementation
    4546
    … …  
    4849procedure TPositionMemory.SetSize(AValue: Integer);
    4950begin
    50   inherited SetSize(AValue);
     51  inherited;
    5152  if FPosition > FSize then FPosition := FSize;
    5253end;
    … …  
    105106begin
    106107  Size := 0;
    107   inherited Destroy;
     108  inherited;
     109end;
     110
     111procedure TMemory.WriteMemory(Position: Integer; Memory: TMemory);
     112begin
     113  Move(Memory.FData, PByte(PByte(@FData) + Position)^, Memory.Size);
     114end;
     115
     116procedure TMemory.ReadMemory(Position: Integer; Memory: TMemory);
     117begin
     118  Move(PByte(PByte(@FData) + Position)^, Memory.FData, Memory.Size);
    108119end;
    109120
    110121end.
    111 

  • trunk/Packages/Common/Pool.pas

    r74 r75  
    1 unit UPool;
    2 
    3 {$mode Delphi}{$H+}
     1unit Pool;
    42
    53interface
    64
    75uses
    8   Classes, SysUtils, syncobjs, SpecializedList, UThreading;
     6  Classes, SysUtils, syncobjs, Generics.Collections, Threading;
    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, '');
    … …  
    201199
    202200end.
    203 

  • trunk/Packages/Common/PrefixMultiplier.pas

    r74 r75  
    1 unit UPrefixMultiplier;
     1unit PrefixMultiplier;
    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;
    … …  
    3331  (
    3432    (ShortText: 'y'; FullText: 'yocto'; Value: 1e-24),
    35           (ShortText: 'z'; FullText: 'zepto'; Value: 1e-21),
     33    (ShortText: 'z'; FullText: 'zepto'; Value: 1e-21),
    3634    (ShortText: 'a'; FullText: 'atto'; Value: 1e-18),
    3735    (ShortText: 'f'; FullText: 'femto'; Value: 1e-15),
    … …  
    5452  (
    5553    (ShortText: 'ys'; FullText: 'yocto'; Value: 1e-24),
    56           (ShortText: 'zs'; FullText: 'zepto'; Value: 1e-21),
     54    (ShortText: 'zs'; FullText: 'zepto'; Value: 1e-21),
    5755    (ShortText: 'as'; FullText: 'atto'; Value: 1e-18),
    5856    (ShortText: 'fs'; FullText: 'femto'; Value: 1e-15),
    … …  
    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;
    … …  
    118124
    119125end.
    120 

  • trunk/Packages/Common/RegistryEx.pas

    r74 r75  
    1 unit URegistry;
    2 
    3 {$MODE Delphi}
     1unit RegistryEx;
    42
    53interface
    … …  
    97
    108type
    11   TRegistryRoot = (rrKeyClassesRoot = HKEY($80000000),
    12     rrKeyCurrentUser = HKEY($80000001),
    13     rrKeyLocalMachine = HKEY($80000002),
    14     rrKeyUsers = HKEY($80000003),
    15     rrKeyPerformanceData = HKEY($80000004),
    16     rrKeyCurrentConfig = HKEY($80000005),
    17     rrKeyDynData = HKEY($80000006));
     9  TRegistryRoot = (rrKeyClassesRoot, rrKeyCurrentUser, rrKeyLocalMachine,
     10    rrKeyUsers, rrKeyPerformanceData, rrKeyCurrentConfig, rrKeyDynData);
    1811
    1912  { TRegistryContext }
    … …  
    2215    RootKey: HKEY;
    2316    Key: string;
     17    class function Create(RootKey: TRegistryRoot; Key: string): TRegistryContext; static; overload;
     18    class function Create(RootKey: HKEY; Key: string): TRegistryContext; static; overload;
    2419    class operator Equal(A, B: TRegistryContext): Boolean;
    2520  end;
    … …  
    3227    procedure SetCurrentContext(AValue: TRegistryContext);
    3328  public
     29    function ReadChar(const Name: string): Char;
     30    procedure WriteChar(const Name: string; Value: Char);
    3431    function ReadBoolWithDefault(const Name: string;
    3532      DefaultValue: Boolean): Boolean;
    3633    function ReadIntegerWithDefault(const Name: string; DefaultValue: Integer): Integer;
    3734    function ReadStringWithDefault(const Name: string; DefaultValue: string): string;
     35    function ReadCharWithDefault(const Name: string; DefaultValue: Char): Char;
    3836    function ReadFloatWithDefault(const Name: string;
    3937      DefaultValue: Double): Double;
    … …  
    4341  end;
    4442
    45 function RegContext(RootKey: HKEY; Key: string): TRegistryContext;
     43const
     44  RegistryRootHKEY: array[TRegistryRoot] of HKEY = (HKEY_CLASSES_ROOT,
     45    HKEY_CURRENT_USER, HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_PERFORMANCE_DATA,
     46    HKEY_CURRENT_CONFIG, HKEY_DYN_DATA);
    4647
    4748
    4849implementation
    49 
    50 function RegContext(RootKey: HKEY; Key: string): TRegistryContext;
    51 begin
    52   Result.RootKey := RootKey;
    53   Result.Key := Key;
    54 end;
    5550
    5651{ TRegistryContext }
    … …  
    5954begin
    6055  Result := (A.Key = B.Key) and (A.RootKey = B.RootKey);
     56end;
     57
     58class function TRegistryContext.Create(RootKey: TRegistryRoot; Key: string): TRegistryContext;
     59begin
     60  Result.RootKey := RegistryRootHKEY[RootKey];
     61  Result.Key := Key;
     62end;
     63
     64class function TRegistryContext.Create(RootKey: HKEY; Key: string): TRegistryContext;
     65begin
     66  Result.RootKey := RootKey;
     67  Result.Key := Key;
    6168end;
    6269
    … …  
    7986    else begin
    8087      WriteString(Name, DefaultValue);
     88      Result := DefaultValue;
     89    end;
     90end;
     91
     92function TRegistryEx.ReadCharWithDefault(const Name: string; DefaultValue: Char
     93  ): Char;
     94begin
     95  if ValueExists(Name) then Result := ReadChar(Name)
     96    else begin
     97      WriteChar(Name, DefaultValue);
    8198      Result := DefaultValue;
    8299    end;
    … …  
    113130function TRegistryEx.OpenKey(const Key: string; CanCreate: Boolean): Boolean;
    114131begin
    115   {$IFDEF Linux}
    116   CloseKey;
     132  {$IFDEF UNIX}
     133  //CloseKey;
    117134  {$ENDIF}
    118135  Result := inherited OpenKey(Key, CanCreate);
    … …  
    121138function TRegistryEx.GetCurrentContext: TRegistryContext;
    122139begin
    123   Result.Key := CurrentPath;
     140  Result.Key := String(CurrentPath);
    124141  Result.RootKey := RootKey;
    125142end;
    … …  
    129146  RootKey := AValue.RootKey;
    130147  OpenKey(AValue.Key, True);
     148end;
     149
     150function TRegistryEx.ReadChar(const Name: string): Char;
     151var
     152  S: string;
     153begin
     154  S := ReadString(Name);
     155  if Length(S) > 0 then Result := S[1]
     156    else Result := #0;
     157end;
     158
     159procedure TRegistryEx.WriteChar(const Name: string; Value: Char);
     160begin
     161  WriteString(Name, Value);
    131162end;
    132163

  • trunk/Packages/Common/ResetableThread.pas

    r74 r75  
    1 unit UResetableThread;
    2 
    3 {$mode Delphi}{$H+}
     1unit ResetableThread;
    42
    53interface
    64
    75uses
    8   Classes, SysUtils, syncobjs, UThreading, UPool;
     6  Classes, SysUtils, syncobjs, Threading, Pool;
    97
    108type
    … …  
    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
    298296end.
    299 

  • trunk/Packages/Common/StopWatch.pas

    r73 r75  
    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/SyncCounter.pas

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

  • trunk/Packages/Common/Threading.pas

    r74 r75  
    1 unit UThreading;
    2 
    3 {$mode delphi}
     1unit Threading;
    42
    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
    … …  
    378366
    379367end.
    380 

  • trunk/Packages/Common/URI.pas

    r74 r75  
    1 unit UURI;
     1unit URI;
    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.
    354 

  • trunk/Packages/Common/XML.pas

    r74 r75  
    1 unit UXMLUtils;
    2 
    3 {$mode delphi}
     1unit XML;
    42
    53interface
    … …  
    75uses
    86  {$IFDEF WINDOWS}Windows,{$ENDIF}
    9   Classes, SysUtils, DateUtils;
     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;
     11procedure WriteInteger(Node: TDOMNode; Name: string; Value: Integer);
     12procedure WriteInt64(Node: TDOMNode; Name: string; Value: Int64);
     13procedure WriteBoolean(Node: TDOMNode; Name: string; Value: Boolean);
     14procedure WriteString(Node: TDOMNode; Name: string; Value: string);
     15procedure WriteDateTime(Node: TDOMNode; Name: string; Value: TDateTime);
     16procedure WriteDouble(Node: TDOMNode; Name: string; Value: Double);
     17function ReadInteger(Node: TDOMNode; Name: string; DefaultValue: Integer): Integer;
     18function ReadInt64(Node: TDOMNode; Name: string; DefaultValue: Int64): Int64;
     19function ReadBoolean(Node: TDOMNode; Name: string; DefaultValue: Boolean): Boolean;
     20function ReadString(Node: TDOMNode; Name: string; DefaultValue: string): string;
     21function ReadDateTime(Node: TDOMNode; Name: string; DefaultValue: TDateTime): TDateTime;
     22function ReadDouble(Node: TDOMNode; Name: string; DefaultValue: Double): Double;
     23procedure ReadXMLFileParser(out Doc: TXMLDocument; FileName: string);
    1324
    1425
    1526implementation
     27
     28function ReadDouble(Node: TDOMNode; Name: string; DefaultValue: Double): Double;
     29var
     30  NewNode: TDOMNode;
     31begin
     32  Result := DefaultValue;
     33  NewNode := Node.FindNode(DOMString(Name));
     34  if Assigned(NewNode) then
     35    Result := StrToFloat(string(NewNode.TextContent));
     36end;
     37
     38procedure ReadXMLFileParser(out Doc: TXMLDocument; FileName: string);
     39var
     40  Parser: TDOMParser;
     41  Src: TXMLInputSource;
     42  InFile: TFileStream;
     43begin
     44  try
     45    InFile := TFileStream.Create(FileName, fmOpenRead);
     46    Src := TXMLInputSource.Create(InFile);
     47    Parser := TDOMParser.Create;
     48    Parser.Options.PreserveWhitespace := True;
     49    Parser.Parse(Src, Doc);
     50  finally
     51    Src.Free;
     52    Parser.Free;
     53    InFile.Free;
     54  end;
     55end;
    1656
    1757function GetTimeZoneBias: Integer;
    … …  
    2060  TimeZoneInfo: TTimeZoneInformation;
    2161begin
     62  {$push}{$warn 5057 off}
    2263  case GetTimeZoneInformation(TimeZoneInfo) of
    23   TIME_ZONE_ID_STANDARD: Result := TimeZoneInfo.Bias + TimeZoneInfo.StandardBias;
    24   TIME_ZONE_ID_DAYLIGHT: Result := TimeZoneInfo.Bias + TimeZoneInfo.DaylightBias;
     64    TIME_ZONE_ID_STANDARD: Result := TimeZoneInfo.Bias + TimeZoneInfo.StandardBias;
     65    TIME_ZONE_ID_DAYLIGHT: Result := TimeZoneInfo.Bias + TimeZoneInfo.DaylightBias;
    2566  else
    2667    Result := 0;
    2768  end;
     69  {$pop}
    2870end;
    2971{$ELSE}
    … …  
    3577function LeftCutString(var Source: string; out Output: string; Delimiter: string; Allowed: string = ''): Boolean;
    3678var
    37   I, J: Integer;
     79  I: Integer;
    3880  Matched: Boolean;
    3981begin
    … …  
    66108  Minute: Integer;
    67109  Second: Integer;
     110  SecondFraction: Double;
    68111  Millisecond: Integer;
    69112begin
    … …  
    88131      if Pos('Z', XMLDateTime) > 0 then
    89132        LeftCutString(XMLDateTime, Part, 'Z');
    90       Millisecond := StrToInt(Part);
     133      SecondFraction := StrToFloat('0' + DefaultFormatSettings.DecimalSeparator + Part);
     134      Millisecond := Trunc(SecondFraction * 1000);
    91135    end else begin
    92136      if Pos('+', XMLDateTime) > 0 then
    … …  
    106150end;
    107151
    108 function DateTimeToXMLTime(Value: TDateTime; ApplyLocalBias: Boolean = True): WideString;
     152function DateTimeToXMLTime(Value: TDateTime; ApplyLocalBias: Boolean = True): string;
    109153const
    110154  Neg: array[Boolean] of string =  ('+', '-');
    … …  
    123167end;
    124168
     169procedure WriteInteger(Node: TDOMNode; Name: string; Value: Integer);
     170var
     171  NewNode: TDOMNode;
     172begin
     173  NewNode := Node.OwnerDocument.CreateElement(DOMString(Name));
     174  NewNode.TextContent := DOMString(IntToStr(Value));
     175  Node.AppendChild(NewNode);
     176end;
     177
     178procedure WriteInt64(Node: TDOMNode; Name: string; Value: Int64);
     179var
     180  NewNode: TDOMNode;
     181begin
     182  NewNode := Node.OwnerDocument.CreateElement(DOMString(Name));
     183  NewNode.TextContent := DOMString(IntToStr(Value));
     184  Node.AppendChild(NewNode);
     185end;
     186
     187procedure WriteBoolean(Node: TDOMNode; Name: string; Value: Boolean);
     188var
     189  NewNode: TDOMNode;
     190begin
     191  NewNode := Node.OwnerDocument.CreateElement(DOMString(Name));
     192  NewNode.TextContent := DOMString(BoolToStr(Value));
     193  Node.AppendChild(NewNode);
     194end;
     195
     196procedure WriteString(Node: TDOMNode; Name: string; Value: string);
     197var
     198  NewNode: TDOMNode;
     199begin
     200  NewNode := Node.OwnerDocument.CreateElement(DOMString(Name));
     201  NewNode.TextContent := DOMString(Value);
     202  Node.AppendChild(NewNode);
     203end;
     204
     205procedure WriteDateTime(Node: TDOMNode; Name: string; Value: TDateTime);
     206var
     207  NewNode: TDOMNode;
     208begin
     209  NewNode := Node.OwnerDocument.CreateElement(DOMString(Name));
     210  NewNode.TextContent := DOMString(DateTimeToXMLTime(Value));
     211  Node.AppendChild(NewNode);
     212end;
     213
     214procedure WriteDouble(Node: TDOMNode; Name: string; Value: Double);
     215var
     216  NewNode: TDOMNode;
     217begin
     218  NewNode := Node.OwnerDocument.CreateElement(DOMString(Name));
     219  NewNode.TextContent := DOMString(FloatToStr(Value));
     220  Node.AppendChild(NewNode);
     221end;
     222
     223function ReadInteger(Node: TDOMNode; Name: string; DefaultValue: Integer): Integer;
     224var
     225  NewNode: TDOMNode;
     226begin
     227  Result := DefaultValue;
     228  NewNode := Node.FindNode(DOMString(Name));
     229  if Assigned(NewNode) then
     230    Result := StrToInt(string(NewNode.TextContent));
     231end;
     232
     233function ReadInt64(Node: TDOMNode; Name: string; DefaultValue: Int64): Int64;
     234var
     235  NewNode: TDOMNode;
     236begin
     237  Result := DefaultValue;
     238  NewNode := Node.FindNode(DOMString(Name));
     239  if Assigned(NewNode) then
     240    Result := StrToInt64(string(NewNode.TextContent));
     241end;
     242
     243function ReadBoolean(Node: TDOMNode; Name: string; DefaultValue: Boolean): Boolean;
     244var
     245  NewNode: TDOMNode;
     246begin
     247  Result := DefaultValue;
     248  NewNode := Node.FindNode(DOMString(Name));
     249  if Assigned(NewNode) then
     250    Result := StrToBool(string(NewNode.TextContent));
     251end;
     252
     253function ReadString(Node: TDOMNode; Name: string; DefaultValue: string): string;
     254var
     255  NewNode: TDOMNode;
     256begin
     257  Result := DefaultValue;
     258  NewNode := Node.FindNode(DOMString(Name));
     259  if Assigned(NewNode) then
     260    Result := string(NewNode.TextContent);
     261end;
     262
     263function ReadDateTime(Node: TDOMNode; Name: string; DefaultValue: TDateTime
     264  ): TDateTime;
     265var
     266  NewNode: TDOMNode;
     267begin
     268  Result := DefaultValue;
     269  NewNode := Node.FindNode(DOMString(Name));
     270  if Assigned(NewNode) then
     271    Result := XMLTimeToDateTime(string(NewNode.TextContent));
     272end;
     273
    125274end.
    126 
Note: See TracChangeset for help on using the changeset viewer.