Changeset 122 for trunk/Packages


Ignore:
Timestamp:
Jun 29, 2018, 11:44:07 PM (6 years ago)
Author:
chronos
Message:
  • Modified: Updated Common package.
  • Modified: Updated IPTV prices.
  • Added: deb package build script.
Location:
trunk/Packages
Files:
8 added
17 edited

Legend:

Unmodified
Added
Removed

  • trunk/Packages/Common/Common.lpk

    r89 r122  
    1 <?xml version="1.0"?>
     1<?xml version="1.0" encoding="UTF-8"?>
    22<CONFIG>
    33  <Package Version="4">
    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        <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)-$(BuildMode)"/>
    1314      </SearchPaths>
     15      <Parsing>
     16        <SyntaxOptions>
     17          <SyntaxMode Value="Delphi"/>
     18          <CStyleOperator Value="False"/>
     19          <AllowLabel Value="False"/>
     20          <CPPInline Value="False"/>
     21        </SyntaxOptions>
     22      </Parsing>
     23      <CodeGeneration>
     24        <Optimizations>
     25          <OptimizationLevel Value="0"/>
     26        </Optimizations>
     27      </CodeGeneration>
     28      <Linking>
     29        <Debugging>
     30          <GenerateDebugInfo Value="False"/>
     31        </Debugging>
     32      </Linking>
    1433      <Other>
    1534        <CompilerMessages>
    16           <UseMsgFile Value="True"/>
     35          <IgnoredMessages idx5024="True"/>
    1736        </CompilerMessages>
    18         <CompilerPath Value="$(CompPath)"/>
    1937      </Other>
    2038    </CompilerOptions>
    … …  
    2240    <License Value="GNU/GPL"/>
    2341    <Version Minor="7"/>
    24     <Files Count="15">
     42    <Files Count="22">
    2543      <Item1>
    2644        <Filename Value="StopWatch.pas"/>
    … …  
    87105        <UnitName Value="UApplicationInfo"/>
    88106      </Item15>
     107      <Item16>
     108        <Filename Value="USyncCounter.pas"/>
     109        <UnitName Value="USyncCounter"/>
     110      </Item16>
     111      <Item17>
     112        <Filename Value="UListViewSort.pas"/>
     113        <HasRegisterProc Value="True"/>
     114        <UnitName Value="UListViewSort"/>
     115      </Item17>
     116      <Item18>
     117        <Filename Value="UPersistentForm.pas"/>
     118        <HasRegisterProc Value="True"/>
     119        <UnitName Value="UPersistentForm"/>
     120      </Item18>
     121      <Item19>
     122        <Filename Value="UFindFile.pas"/>
     123        <HasRegisterProc Value="True"/>
     124        <UnitName Value="UFindFile"/>
     125      </Item19>
     126      <Item20>
     127        <Filename Value="UScaleDPI.pas"/>
     128        <HasRegisterProc Value="True"/>
     129        <UnitName Value="UScaleDPI"/>
     130      </Item20>
     131      <Item21>
     132        <Filename Value="UTheme.pas"/>
     133        <HasRegisterProc Value="True"/>
     134        <UnitName Value="UTheme"/>
     135      </Item21>
     136      <Item22>
     137        <Filename Value="UStringTable.pas"/>
     138        <UnitName Value="UStringTable"/>
     139      </Item22>
    89140    </Files>
    90141    <i18n>
    91142      <EnableI18N Value="True"/>
    92143      <OutDir Value="Languages"/>
     144      <EnableI18NForLFM Value="True"/>
    93145    </i18n>
    94     <Type Value="RunAndDesignTime"/>
    95     <RequiredPkgs Count="2">
     146    <RequiredPkgs Count="3">
    96147      <Item1>
    97         <PackageName Value="TemplateGenerics"/>
     148        <PackageName Value="LCL"/>
    98149      </Item1>
    99150      <Item2>
     151        <PackageName Value="TemplateGenerics"/>
     152      </Item2>
     153      <Item3>
    100154        <PackageName Value="FCL"/>
    101155        <MinVersion Major="1" Valid="True"/>
    102       </Item2>
     156      </Item3>
    103157    </RequiredPkgs>
    104158    <UsageOptions>

  • trunk/Packages/Common/Common.pas

    r89 r122  
    55unit Common;
    66
     7{$warn 5023 off : no warning about unused units}
    78interface
    89
    … …  
    1011  StopWatch, UCommon, UDebugLog, UDelay, UPrefixMultiplier, UURI, UThreading,
    1112  UMemory, UResetableThread, UPool, ULastOpenedList, URegistry,
    12   UJobProgressView, UXMLUtils, UApplicationInfo, LazarusPackageIntf;
     13  UJobProgressView, UXMLUtils, UApplicationInfo, USyncCounter, UListViewSort,
     14  UPersistentForm, UFindFile, UScaleDPI, UTheme, UStringTable,
     15  LazarusPackageIntf;
    1316
    1417implementation
    … …  
    2023  RegisterUnit('UJobProgressView', @UJobProgressView.Register);
    2124  RegisterUnit('UApplicationInfo', @UApplicationInfo.Register);
     25  RegisterUnit('UListViewSort', @UListViewSort.Register);
     26  RegisterUnit('UPersistentForm', @UPersistentForm.Register);
     27  RegisterUnit('UFindFile', @UFindFile.Register);
     28  RegisterUnit('UScaleDPI', @UScaleDPI.Register);
     29  RegisterUnit('UTheme', @UTheme.Register);
    2230end;
    2331

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

    r89 r122  
    1414msgstr ""
    1515
     16#: ujobprogressview.soperations
     17msgid "Operations:"
     18msgstr ""
     19
    1620#: ujobprogressview.spleasewait
    1721msgid "Please wait..."

  • trunk/Packages/Common/UApplicationInfo.pas

    r89 r122  
    66
    77uses
    8   SysUtils, Registry, Classes, Forms, URegistry;
     8  SysUtils, Classes, Forms, URegistry, Controls;
    99
    1010type
    … …  
    1414  TApplicationInfo = class(TComponent)
    1515  private
     16    FDescription: TCaption;
    1617    FIdentification: Byte;
     18    FLicense: string;
    1719    FVersionMajor: Byte;
    1820    FVersionMinor: Byte;
    … …  
    3234    constructor Create(AOwner: TComponent); 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: string 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;
    4954  end;
    5055
    … …  
    5257
    5358implementation
    54                        
     59
    5560procedure Register;
    5661begin
    57   RegisterComponents('Samples', [TApplicationInfo]);
     62  RegisterComponents('Common', [TApplicationInfo]);
    5863end;
    5964
    … …  
    7782end;
    7883
     84function TApplicationInfo.GetRegistryContext: TRegistryContext;
     85begin
     86  Result := TRegistryContext.Create(RegistryRoot, RegistryKey);
     87end;
     88
    7989end.

  • trunk/Packages/Common/UCommon.pas

    r114 r122  
    66
    77uses
    8   {$IFDEF Windows}Windows,{$ENDIF}
    9   Classes, SysUtils, StrUtils, Dialogs, Process, LCLIntf, LazFileUtils,
     8  {$ifdef Windows}Windows,{$endif}
     9  {$ifdef Linux}baseunix,{$endif}
     10  Classes, SysUtils, StrUtils, Dialogs, Process, LCLIntf,
    1011  FileUtil; //, ShFolder, ShellAPI;
    1112
    … …  
    2728    unfDNSDomainName = 11);
    2829
     30  TFilterMethodMethod = function (FileName: string): Boolean of object;
    2931var
    3032  ExceptionHandler: TExceptionEvent;
    … …  
    4850function LoggedOnUserNameEx(Format: TUserNameFormat): string;
    4951function SplitString(var Text: string; Count: Word): string;
     52function GetBitCount(Variable: QWord; MaxIndex: Integer): Integer;
    5053function GetBit(Variable: QWord; Index: Byte): Boolean;
     54procedure SetBit(var Variable: Int64; Index: Byte; State: Boolean); overload;
    5155procedure SetBit(var Variable: QWord; Index: Byte; State: Boolean); overload;
    5256procedure SetBit(var Variable: Cardinal; Index: Byte; State: Boolean); overload;
    … …  
    6064procedure OpenWebPage(URL: string);
    6165procedure OpenFileInShell(FileName: string);
    62 procedure ExecuteProgram(CommandLine: string);
     66procedure ExecuteProgram(Executable: string; Parameters: array of string);
    6367procedure FreeThenNil(var Obj);
     68function RemoveQuotes(Text: string): string;
     69function ComputerName: string;
     70function OccurenceOfChar(What: Char; Where: string): Integer;
     71function GetDirCount(Dir: string): Integer;
     72function MergeArray(A, B: array of string): TArrayOfString;
     73function LoadFileToStr(const FileName: TFileName): AnsiString;
     74procedure SearchFiles(AList: TStrings; Dir: string;
     75  FilterMethod: TFilterMethodMethod = nil);
     76function GetStringPart(var Text: string; Separator: string): string;
    6477
    6578
    … …  
    103116  Path := IncludeTrailingPathDelimiter(APath);
    104117
    105   Find := FindFirst(UTF8Decode(Path + AFileSpec), faAnyFile xor faDirectory, SearchRec);
     118  Find := FindFirst(Path + AFileSpec, faAnyFile xor faDirectory, SearchRec);
    106119  while Find = 0 do begin
    107     DeleteFileUTF8(Path + UTF8Encode(SearchRec.Name));
     120    DeleteFile(Path + SearchRec.Name);
    108121
    109122    Find := SysUtils.FindNext(SearchRec);
    … …  
    284297  L: LongWord;
    285298begin
    286 
    287299  L := MAX_USERNAME_LENGTH + 2;
    288300  SetLength(Result, L);
    … …  
    299311  end;
    300312end;
    301 
     313{$endif}
     314
     315function ComputerName: string;
     316{$ifdef mswindows}
     317const
     318 INFO_BUFFER_SIZE = 32767;
     319var
     320  Buffer : array[0..INFO_BUFFER_SIZE] of WideChar;
     321  Ret : DWORD;
     322begin
     323  Ret := INFO_BUFFER_SIZE;
     324  If (GetComputerNameW(@Buffer[0],Ret)) then begin
     325    Result := UTF8Encode(WideString(Buffer));
     326  end
     327  else begin
     328    Result := 'ERROR_NO_COMPUTERNAME_RETURNED';
     329  end;
     330end;
     331{$endif}
     332{$ifdef unix}
     333var
     334  Name: UtsName;
     335begin
     336  fpuname(Name);
     337  Result := Name.Nodename;
     338end;
     339{$endif}
     340
     341{$ifdef windows}
    302342function LoggedOnUserNameEx(Format: TUserNameFormat): string;
    303343const
    … …  
    336376end;
    337377
     378function GetBitCount(Variable: QWord; MaxIndex: Integer): Integer;
     379var
     380  I: Integer;
     381begin
     382  Result := 0;
     383  for I := 0 to MaxIndex - 1 do
     384    if ((Variable shr I) and 1) = 1 then Inc(Result);
     385end;
     386
    338387function GetBit(Variable:QWord;Index:Byte):Boolean;
    339388begin
    … …  
    341390end;
    342391
     392procedure SetBit(var Variable: Int64; Index: Byte; State: Boolean);
     393begin
     394  Variable := (Variable and ((1 shl Index) xor High(QWord))) or (Int64(State) shl Index);
     395end;
     396
    343397procedure SetBit(var Variable:QWord;Index:Byte;State:Boolean); overload;
    344398begin
    345   Variable := (Variable and ((1 shl Index) xor QWord($ffffffffffffffff))) or (QWord(State) shl Index);
     399  Variable := (Variable and ((1 shl Index) xor High(QWord))) or (QWord(State) shl Index);
    346400end;
    347401
    348402procedure SetBit(var Variable:Cardinal;Index:Byte;State:Boolean); overload;
    349403begin
    350   Variable := (Variable and ((1 shl Index) xor Cardinal($ffffffff))) or (Cardinal(State) shl Index);
     404  Variable := (Variable and ((1 shl Index) xor High(Cardinal))) or (Cardinal(State) shl Index);
    351405end;
    352406
    353407procedure SetBit(var Variable:Word;Index:Byte;State:Boolean); overload;
    354408begin
    355   Variable := (Variable and ((1 shl Index) xor Word($ffff))) or (Word(State) shl Index);
     409  Variable := (Variable and ((1 shl Index) xor High(Word))) or (Word(State) shl Index);
    356410end;
    357411
    … …  
    379433end;
    380434
    381 procedure ExecuteProgram(CommandLine: string);
     435procedure ExecuteProgram(Executable: string; Parameters: array of string);
    382436var
    383437  Process: TProcess;
     438  I: Integer;
    384439begin
    385440  try
    386441    Process := TProcess.Create(nil);
    387     Process.CommandLine := CommandLine;
     442    Process.Executable := Executable;
     443    for I := 0 to Length(Parameters) - 1 do
     444      Process.Parameters.Add(Parameters[I]);
    388445    Process.Options := [poNoConsole];
    389446    Process.Execute;
    … …  
    400457
    401458procedure OpenWebPage(URL: string);
    402 var
    403   Process: TProcess;
    404   Browser, Params: string;
    405459begin
    406460  OpenURL(URL);
    407   {try
    408     Process := TProcess.Create(nil);
    409     Browser := '';
    410     //FindDefaultBrowser(Browser, Params);
    411     //Process.Executable := Browser;
    412     //Process.Parameters.Add(Format(Params, [ApplicationInfo.HomePage]);
    413     Process.CommandLine := 'cmd.exe /c start ' + URL;
    414     Process.Options := [poNoConsole];
    415     Process.Execute;
     461end;
     462
     463procedure OpenFileInShell(FileName: string);
     464begin
     465  ExecuteProgram('cmd.exe', ['/c', 'start', FileName]);
     466end;
     467
     468function RemoveQuotes(Text: string): string;
     469begin
     470  Result := Text;
     471  if (Pos('"', Text) = 1) and (Text[Length(Text)] = '"') then
     472    Result := Copy(Text, 2, Length(Text) - 2);
     473end;
     474
     475function OccurenceOfChar(What: Char; Where: string): Integer;
     476var
     477  I: Integer;
     478begin
     479  Result := 0;
     480  for I := 1 to Length(Where) do
     481    if Where[I] = What then Inc(Result);
     482end;
     483
     484function GetDirCount(Dir: string): Integer;
     485begin
     486  Result := OccurenceOfChar(DirectorySeparator, Dir);
     487  if Copy(Dir, Length(Dir), 1) = DirectorySeparator then
     488    Dec(Result);
     489end;
     490
     491function MergeArray(A, B: array of string): TArrayOfString;
     492var
     493  I: Integer;
     494begin
     495  SetLength(Result, Length(A) + Length(B));
     496  for I := 0 to Length(A) - 1 do
     497    Result[I] := A[I];
     498  for I := 0 to Length(B) - 1 do
     499    Result[Length(A) + I] := B[I];
     500end;
     501
     502function LoadFileToStr(const FileName: TFileName): AnsiString;
     503var
     504  FileStream: TFileStream;
     505  Read: Integer;
     506begin
     507  Result := '';
     508  FileStream := TFileStream.Create(FileName, fmOpenRead);
     509  try
     510    if FileStream.Size > 0 then begin
     511      SetLength(Result, FileStream.Size);
     512      Read := FileStream.Read(Pointer(Result)^, FileStream.Size);
     513      SetLength(Result, Read);
     514    end;
    416515  finally
    417     Process.Free;
    418   end;}
    419 end;
    420 
    421 procedure OpenFileInShell(FileName: string);
    422 begin
    423   ExecuteProgram('cmd.exe /c start "' + FileName + '"');
    424 end;
     516    FileStream.Free;
     517  end;
     518end;
     519
     520function DefaultSearchFilter(const FileName: string): Boolean;
     521begin
     522  Result := True;
     523end;
     524
     525procedure SearchFiles(AList: TStrings; Dir: string;
     526  FilterMethod: TFilterMethodMethod = nil);
     527var
     528  SR: TSearchRec;
     529begin
     530  Dir := IncludeTrailingPathDelimiter(Dir);
     531  if FindFirst(Dir + '*', faAnyFile, SR) = 0 then
     532    try
     533      repeat
     534        if (SR.Name = '.') or (SR.Name = '..') or (Assigned(FilterMethod) and (not FilterMethod(SR.Name) or
     535          not FilterMethod(Copy(Dir, 3, Length(Dir)) + SR.Name))) then Continue;
     536        AList.Add(Dir + SR.Name);
     537        if (SR.Attr and faDirectory) <> 0 then
     538          SearchFiles(AList, Dir + SR.Name, FilterMethod);
     539      until FindNext(SR) <> 0;
     540    finally
     541      FindClose(SR);
     542    end;
     543end;
     544
     545function GetStringPart(var Text: string; Separator: string): string;
     546var
     547  P: Integer;
     548begin
     549  P := Pos(Separator, Text);
     550  if P > 0 then begin
     551    Result := Copy(Text, 1, P - 1);
     552    Delete(Text, 1, P - 1 + Length(Separator));
     553  end else begin
     554    Result := Text;
     555    Text := '';
     556  end;
     557  Result := Trim(Result);
     558  Text := Trim(Text);
     559end;
     560
     561
    425562
    426563initialization

  • trunk/Packages/Common/UDebugLog.pas

    r114 r122  
    66
    77uses
    8   Classes, SysUtils, FileUtil, SpecializedList, SyncObjs, LazFileUtils;
     8  Classes, SysUtils, FileUtil, SpecializedList, SyncObjs;
    99
    1010type
    … …  
    3131    Items: TListObject;
    3232    Lock: TCriticalSection;
    33     procedure Add(Group: string; Text: string);
     33    procedure Add(Text: string; Group: string = '');
    3434    procedure WriteToFile(Text: string);
    3535    constructor Create(AOwner: TComponent); override;
    … …  
    5252procedure Register;
    5353begin
    54   RegisterComponents('Samples', [TDebugLog]);
     54  RegisterComponents('Common', [TDebugLog]);
    5555end;
    5656
    … …  
    6969end;
    7070
    71 procedure TDebugLog.Add(Group: string; Text: string);
     71procedure TDebugLog.Add(Text: string; Group: string = '');
    7272var
    7373  NewItem: TDebugLogItem;
    … …  
    103103  try
    104104    if ExtractFileDir(FileName) <> '' then
    105       ForceDirectoriesUTF8(ExtractFileDir(FileName));
    106     if FileExistsUTF8(FileName) then LogFile := TFileStream.Create(UTF8Decode(FileName), fmOpenWrite)
    107       else LogFile := TFileStream.Create(UTF8Decode(FileName), fmCreate);
     105      ForceDirectories(ExtractFileDir(FileName));
     106    if FileExists(FileName) then LogFile := TFileStream.Create(FileName, fmOpenWrite)
     107      else LogFile := TFileStream.Create(FileName, fmCreate);
    108108    LogFile.Seek(0, soFromEnd);
    109109    Text := FormatDateTime('hh:nn:ss.zzz', Now) + ': ' + Text + LineEnding;

  • trunk/Packages/Common/UFindFile.pas

    r84 r122  
    2424
    2525uses
    26   SysUtils, Classes, Graphics, Controls, Forms, Dialogs, FileCtrl;
     26  SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
    2727
    2828type
    … …  
    5555  end;
    5656
     57const
     58{$IFDEF WINDOWS}
     59  FilterAll = '*.*';
     60{$ENDIF}
     61{$IFDEF LINUX}
     62  FilterAll = '*';
     63{$ENDIF}
     64
    5765procedure Register;
    5866
    … …  
    6472procedure Register;
    6573begin
    66   RegisterComponents('Samples', [TFindFile]);
     74  RegisterComponents('Common', [TFindFile]);
    6775end;
    6876
    … …  
    7179  inherited Create(AOwner);
    7280  Path := IncludeTrailingBackslash(UTF8Encode(GetCurrentDir));
    73   FileMask := '*.*';
     81  FileMask := FilterAll;
    7482  FileAttr := [ffaAnyFile];
    7583  s := TStringList.Create;
    … …  
    109117  Attr := 0;
    110118  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;
     119  if ffaHidden in FileAttr then Attr := Attr + 2; //faHidden; use constant to avoid platform warning
     120  if ffaSysFile in FileAttr then Attr := Attr + 4; //faSysFile; use constant to avoid platform warning
     121  // Deprecated: if ffaVolumeID in FileAttr then Attr := Attr + faVolumeID;
    114122  if ffaDirectory in FileAttr then Attr := Attr + faDirectory;
    115123  if ffaArchive in FileAttr then Attr := Attr + faArchive;
    116124  if ffaAnyFile in FileAttr then Attr := Attr + faAnyFile;
    117125
    118   if SysUtils.FindFirst(UTF8Decode(inPath + FileMask), Attr, Rec) = 0 then
     126  if SysUtils.FindFirst(inPath + FileMask, Attr, Rec) = 0 then
    119127  try
    120128    repeat
    121       s.Add(inPath + UTF8Encode(Rec.Name));
     129      s.Add(inPath + Rec.Name);
    122130    until SysUtils.FindNext(Rec) <> 0;
    123131  finally
    … …  
    127135  If not InSubFolders then Exit;
    128136
    129   if SysUtils.FindFirst(UTF8Decode(inPath + '*.*'), faDirectory, Rec) = 0 then
     137  if SysUtils.FindFirst(inPath + FilterAll, faDirectory, Rec) = 0 then
    130138  try
    131139    repeat
    132140      if ((Rec.Attr and faDirectory) > 0) and (Rec.Name <> '.')
    133141      and (Rec.Name <> '..') then
    134         FileSearch(IncludeTrailingBackslash(inPath + UTF8Encode(Rec.Name)));
     142        FileSearch(IncludeTrailingBackslash(inPath + Rec.Name));
    135143    until SysUtils.FindNext(Rec) <> 0;
    136144  finally

  • trunk/Packages/Common/UJobProgressView.lfm

    r89 r122  
    11object FormJobProgressView: TFormJobProgressView
    22  Left = 467
    3   Height = 246
     3  Height = 345
    44  Top = 252
    5   Width = 328
     5  Width = 539
    66  BorderIcons = [biSystemMenu]
    7   ClientHeight = 246
    8   ClientWidth = 328
    9   Font.Height = -11
    10   Font.Name = 'MS Sans Serif'
     7  ClientHeight = 345
     8  ClientWidth = 539
     9  DesignTimePPI = 120
    1110  OnClose = FormClose
    1211  OnCloseQuery = FormCloseQuery
    1312  OnCreate = FormCreate
    1413  OnDestroy = FormDestroy
     14  OnHide = FormHide
     15  OnShow = FormShow
    1516  Position = poScreenCenter
    16   LCLVersion = '1.1'
     17  LCLVersion = '1.8.2.0'
    1718  object PanelOperationsTitle: TPanel
    1819    Left = 0
    19     Height = 24
     20    Height = 32
    2021    Top = 0
    21     Width = 328
    22     Align = alTop
    23     BevelOuter = bvNone
    24     ClientHeight = 24
    25     ClientWidth = 328
     22    Width = 539
     23    Align = alTop
     24    BevelOuter = bvNone
     25    ClientHeight = 32
     26    ClientWidth = 539
    2627    FullRepaint = False
    2728    TabOrder = 0
    2829    object LabelOperation: TLabel
    2930      Left = 8
    30       Height = 14
     31      Height = 20
    3132      Top = 8
    32       Width = 67
     33      Width = 76
    3334      Caption = 'Operations:'
    34       Font.Height = -11
    35       Font.Name = 'MS Sans Serif'
    36       Font.Style = [fsBold]
    3735      ParentColor = False
    3836      ParentFont = False
    … …  
    4139  object PanelLog: TPanel
    4240    Left = 0
    43     Height = 122
    44     Top = 124
    45     Width = 328
     41    Height = 133
     42    Top = 212
     43    Width = 539
    4644    Align = alClient
    4745    BevelOuter = bvSpace
    48     ClientHeight = 122
    49     ClientWidth = 328
     46    ClientHeight = 133
     47    ClientWidth = 539
    5048    TabOrder = 1
    5149    object MemoLog: TMemo
    5250      Left = 8
    53       Height = 106
     51      Height = 117
    5452      Top = 8
    55       Width = 312
     53      Width = 523
    5654      Anchors = [akTop, akLeft, akRight, akBottom]
    5755      ReadOnly = True
    … …  
    6260  object PanelProgress: TPanel
    6361    Left = 0
    64     Height = 38
    65     Top = 50
    66     Width = 328
    67     Align = alTop
    68     BevelOuter = bvNone
    69     ClientHeight = 38
    70     ClientWidth = 328
     62    Height = 54
     63    Top = 106
     64    Width = 539
     65    Align = alTop
     66    BevelOuter = bvNone
     67    ClientHeight = 54
     68    ClientWidth = 539
    7169    TabOrder = 2
    7270    object ProgressBarPart: TProgressBar
    73       Left = 8
    74       Height = 17
    75       Top = 16
    76       Width = 312
     71      Left = 10
     72      Height = 24
     73      Top = 24
     74      Width = 523
    7775      Anchors = [akTop, akLeft, akRight]
    7876      TabOrder = 0
    … …  
    8078    object LabelEstimatedTimePart: TLabel
    8179      Left = 8
    82       Height = 14
     80      Height = 20
    8381      Top = -2
    84       Width = 72
     82      Width = 103
    8583      Caption = 'Estimated time:'
    8684      ParentColor = False
    … …  
    8987  object PanelOperations: TPanel
    9088    Left = 0
    91     Height = 26
    92     Top = 24
    93     Width = 328
    94     Align = alTop
    95     BevelOuter = bvNone
    96     ClientHeight = 26
    97     ClientWidth = 328
     89    Height = 42
     90    Top = 64
     91    Width = 539
     92    Align = alTop
     93    BevelOuter = bvNone
     94    ClientHeight = 42
     95    ClientWidth = 539
    9896    FullRepaint = False
    9997    TabOrder = 3
    10098    object ListViewJobs: TListView
    10199      Left = 8
    102       Height = 16
     100      Height = 32
    103101      Top = 5
    104       Width = 312
     102      Width = 523
    105103      Anchors = [akTop, akLeft, akRight, akBottom]
    106104      AutoWidthLastColumn = True
    … …  
    109107      Columns = <     
    110108        item
    111           Width = 312
     109          Width = 523
    112110        end>
    113111      OwnerData = True
    … …  
    122120  object PanelProgressTotal: TPanel
    123121    Left = 0
    124     Height = 36
    125     Top = 88
    126     Width = 328
    127     Align = alTop
    128     BevelOuter = bvNone
    129     ClientHeight = 36
    130     ClientWidth = 328
     122    Height = 52
     123    Top = 160
     124    Width = 539
     125    Align = alTop
     126    BevelOuter = bvNone
     127    ClientHeight = 52
     128    ClientWidth = 539
    131129    TabOrder = 4
    132130    object LabelEstimatedTimeTotal: TLabel
    133131      Left = 8
    134       Height = 14
     132      Height = 20
    135133      Top = 0
    136       Width = 98
     134      Width = 141
    137135      Caption = 'Total estimated time:'
    138136      ParentColor = False
    … …  
    140138    object ProgressBarTotal: TProgressBar
    141139      Left = 8
    142       Height = 16
    143       Top = 16
    144       Width = 312
     140      Height = 24
     141      Top = 24
     142      Width = 523
    145143      Anchors = [akTop, akLeft, akRight]
    146144      TabOrder = 0
     145    end
     146  end
     147  object PanelText: TPanel
     148    Left = 0
     149    Height = 32
     150    Top = 32
     151    Width = 539
     152    Align = alTop
     153    BevelOuter = bvNone
     154    ClientHeight = 32
     155    ClientWidth = 539
     156    TabOrder = 5
     157    object LabelText: TLabel
     158      Left = 8
     159      Height = 24
     160      Top = 8
     161      Width = 525
     162      Anchors = [akTop, akLeft, akRight]
     163      AutoSize = False
     164      ParentColor = False
    147165    end
    148166  end

  • trunk/Packages/Common/UJobProgressView.lrt

    r89 r122  
    1 TJOBPROGRESSVIEW.LABELOPERATION.CAPTION=Operations:
    2 TJOBPROGRESSVIEW.LABELESTIMATEDTIMEPART.CAPTION=Estimated time:
    3 TJOBPROGRESSVIEW.LABELESTIMATEDTIMETOTAL.CAPTION=Total estimated time:
     1TFORMJOBPROGRESSVIEW.LABELOPERATION.CAPTION=Operations:
     2TFORMJOBPROGRESSVIEW.LABELESTIMATEDTIMEPART.CAPTION=Estimated time:
     3TFORMJOBPROGRESSVIEW.LABELESTIMATEDTIMETOTAL.CAPTION=Total estimated time:

  • trunk/Packages/Common/UJobProgressView.pas

    r89 r122  
    77uses
    88  SysUtils, Variants, Classes, Graphics, Controls, Forms, Syncobjs,
    9   Dialogs, ComCtrls, StdCtrls, ExtCtrls, Contnrs, UThreading,
     9  Dialogs, ComCtrls, StdCtrls, ExtCtrls, Contnrs, UThreading, Math,
    1010  DateUtils;
    1111
    … …  
    1313  EstimatedTimeShowTreshold = 4;
    1414  EstimatedTimeShowTresholdTotal = 1;
    15   MemoLogHeight = 200;
    1615  UpdateInterval = 100; // ms
    1716
    … …  
    2423    FLock: TCriticalSection;
    2524    FOnChange: TNotifyEvent;
     25    FText: string;
    2626    FValue: Integer;
    2727    FMax: Integer;
    2828    procedure SetMax(const AValue: Integer);
     29    procedure SetText(AValue: string);
    2930    procedure SetValue(const AValue: Integer);
    3031  public
    … …  
    3536    property Value: Integer read FValue write SetValue;
    3637    property Max: Integer read FMax write SetMax;
     38    property Text: string read FText write SetText;
    3739    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    3840  end;
    … …  
    6971  end;
    7072
     73  TJobs = class(TObjectList)
     74  end;
     75
    7176  TJobThread = class(TListedThread)
    7277    procedure Execute; override;
    … …  
    8085  TFormJobProgressView = class(TForm)
    8186    ImageList1: TImageList;
     87    LabelText: TLabel;
    8288    Label2: TLabel;
    8389    LabelOperation: TLabel;
    … …  
    8692    ListViewJobs: TListView;
    8793    MemoLog: TMemo;
     94    PanelText: TPanel;
    8895    PanelProgressTotal: TPanel;
    8996    PanelOperationsTitle: TPanel;
    … …  
    94101    ProgressBarTotal: TProgressBar;
    95102    TimerUpdate: TTimer;
     103    procedure FormHide(Sender: TObject);
     104    procedure FormShow(Sender: TObject);
     105    procedure ReloadJobList;
    96106    procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
    97107    procedure FormDestroy(Sender: TObject);
    … …  
    100110    procedure FormCreate(Sender: TObject);
    101111    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
     112    procedure UpdateHeight;
    102113  public
    103114    JobProgressView: TJobProgressView;
    … …  
    111122    Finished: Boolean;
    112123    FOnJobFinish: TJobProgressViewMethod;
     124    FOnOwnerDraw: TNotifyEvent;
     125    FOwnerDraw: Boolean;
    113126    FShowDelay: Integer;
    114127    FTerminate: Boolean;
    … …  
    116129    TotalStartTime: TDateTime;
    117130    Log: TStringList;
    118     Form: TFormJobProgressView;
     131    FForm: TFormJobProgressView;
    119132    procedure SetTerminate(const AValue: Boolean);
    120133    procedure UpdateProgress;
    121     procedure ReloadJobList;
    122     procedure StartJobs;
    123     procedure UpdateHeight;
     134    procedure JobProgressChange(Sender: TObject);
    124135  public
    125     Jobs: TObjectList; // TListObject<TJob>
     136    Jobs: TJobs;
    126137    CurrentJob: TJob;
    127138    CurrentJobIndex: Integer;
    … …  
    129140    destructor Destroy; override;
    130141    procedure Clear;
    131     procedure AddJob(Title: string; Method: TJobProgressViewMethod;
    132       NoThreaded: Boolean = False; WaitFor: Boolean = False);
    133     procedure Start(AAutoClose: Boolean = True);
     142    function AddJob(Title: string; Method: TJobProgressViewMethod;
     143      NoThreaded: Boolean = False; WaitFor: Boolean = False): TJob;
     144    procedure Start;
    134145    procedure Stop;
    135146    procedure TermSleep(Delay: Integer);
     147    property Form: TFormJobProgressView read FForm;
    136148    property Terminate: Boolean read FTerminate write SetTerminate;
    137149  published
     150    property OwnerDraw: Boolean read FOwnerDraw write FOwnerDraw;
    138151    property ShowDelay: Integer read FShowDelay write FShowDelay;
    139152    property AutoClose: Boolean read FAutoClose write FAutoClose;
    140153    property OnJobFinish: TJobProgressViewMethod read FOnJobFinish
    141154      write FOnJobFinish;
     155    property OnOwnerDraw: TNotifyEvent read FOnOwnerDraw
     156      write FOnOwnerDraw;
    142157  end;
    143158
    … …  
    160175  STotalEstimatedTime = 'Total estimated time: %s';
    161176  SFinished = 'Finished';
     177  SOperations = 'Operations:';
    162178
    163179procedure Register;
    164180begin
    165   RegisterComponents('Samples', [TJobProgressView]);
    166 end;
     181  RegisterComponents('Common', [TJobProgressView]);
     182end;
     183
     184{ TJobThread }
    167185
    168186procedure TJobThread.Execute;
    … …  
    183201end;
    184202
    185 procedure TJobProgressView.AddJob(Title: string; Method: TJobProgressViewMethod;
    186   NoThreaded: Boolean = False; WaitFor: Boolean = False);
     203{ TFormJobProgressView }
     204
     205procedure TFormJobProgressView.UpdateHeight;
    187206var
    188   NewJob: TJob;
    189 begin
    190   NewJob := TJob.Create;
    191   NewJob.ProgressView := Self;
    192   NewJob.Title := Title;
    193   NewJob.Method := Method;
    194   NewJob.NoThreaded := NoThreaded;
    195   NewJob.WaitFor := WaitFor;
    196   NewJob.Progress.Max := 100;
    197   NewJob.Progress.Reset;
    198   Jobs.Add(NewJob);
     207  H: Integer;
     208  PanelOperationsVisible: Boolean;
     209  PanelOperationsHeight: Integer;
     210  PanelProgressVisible: Boolean;
     211  PanelProgressTotalVisible: Boolean;
     212  PanelLogVisible: Boolean;
     213  MemoLogHeight: Integer = 200;
     214  I: Integer;
     215  ItemRect: TRect;
     216  MaxH: Integer;
     217begin
     218    H := PanelOperationsTitle.Height;
     219    PanelOperationsVisible := JobProgressView.Jobs.Count > 0;
     220    if PanelOperationsVisible <> PanelOperations.Visible then
     221      PanelOperations.Visible := PanelOperationsVisible;
     222    if ListViewJobs.Items.Count > 0 then begin
     223      Maxh := 0;
     224      for I := 0 to ListViewJobs.Items.Count - 1 do
     225      begin
     226        ItemRect := ListViewJobs.Items[i].DisplayRect(drBounds);
     227        Maxh := Max(Maxh, ItemRect.Top + (ItemRect.Bottom - ItemRect.Top));
     228      end;
     229      PanelOperationsHeight := Scale96ToScreen(12) + Maxh;
     230    end else PanelOperationsHeight := Scale96ToScreen(8);
     231    if PanelOperationsHeight <> PanelOperations.Height then
     232      PanelOperations.Height := PanelOperationsHeight;
     233    if PanelOperationsVisible then
     234      H := H + PanelOperations.Height;
     235
     236    PanelProgressVisible := (JobProgressView.Jobs.Count > 0) and not JobProgressView.Finished;
     237    if PanelProgressVisible <> PanelProgress.Visible then
     238      PanelProgress.Visible := PanelProgressVisible;
     239    if PanelProgressVisible then
     240      H := H + PanelProgress.Height;
     241    PanelProgressTotalVisible := (JobProgressView.Jobs.Count > 1) and not JobProgressView.Finished;
     242    if PanelProgressTotalVisible <> PanelProgressTotal.Visible then
     243      PanelProgressTotal.Visible := PanelProgressTotalVisible;
     244    if PanelProgressTotalVisible then
     245      H := H + PanelProgressTotal.Height;
     246    Constraints.MinHeight := H;
     247    PanelLogVisible := MemoLog.Lines.Count > 0;
     248    if PanelLogVisible <> PanelLog.Visible then
     249      PanelLog.Visible := PanelLogVisible;
     250    if PanelLogVisible then
     251      H := H + Scale96ToScreen(MemoLogHeight);
     252    if PanelText.Visible then
     253      H := H + PanelText.Height;
     254    if Height <> H then begin
     255      Height := H;
     256      Top := (Screen.Height - H) div 2;
     257    end;
     258end;
     259
     260procedure TFormJobProgressView.TimerUpdateTimer(Sender: TObject);
     261var
     262  ProgressBarPartVisible: Boolean;
     263  ProgressBarTotalVisible: Boolean;
     264begin
     265  JobProgressView.UpdateProgress;
     266  if Visible and (not ProgressBarPart.Visible) and
     267  Assigned(JobProgressView.CurrentJob) and
     268  (JobProgressView.CurrentJob.Progress.Value > 0) then begin
     269    ProgressBarPartVisible := True;
     270    if ProgressBarPartVisible <> ProgressBarPart.Visible then
     271      ProgressBarPart.Visible := ProgressBarPartVisible;
     272    ProgressBarTotalVisible := True;
     273    if ProgressBarTotalVisible <> ProgressBarTotal.Visible then
     274      ProgressBarTotal.Visible := ProgressBarTotalVisible;
     275  end;
     276  if not Visible then begin
     277    TimerUpdate.Interval := UpdateInterval;
     278    if not JobProgressView.OwnerDraw then Show;
     279  end;
     280  if Assigned(JobProgressView.CurrentJob) then begin
     281    LabelText.Caption := JobProgressView.CurrentJob.Progress.Text;
     282    if LabelText.Caption <> '' then begin
     283      PanelText.Visible := True;
     284      UpdateHeight;
     285    end;
     286  end;
     287end;
     288
     289procedure TFormJobProgressView.FormDestroy(Sender:TObject);
     290begin
     291end;
     292
     293procedure TFormJobProgressView.ListViewJobsData(Sender: TObject; Item: TListItem);
     294begin
     295  if (Item.Index >= 0) and (Item.Index < JobProgressView.Jobs.Count) then
     296  with TJob(JobProgressView.Jobs[Item.Index]) do begin
     297    Item.Caption := Title;
     298    if Item.Index = JobProgressView.CurrentJobIndex then Item.ImageIndex := 1
     299      else if Finished then Item.ImageIndex := 0
     300      else Item.ImageIndex := 2;
     301    Item.Data := JobProgressView.Jobs[Item.Index];
     302  end;
     303end;
     304
     305procedure TFormJobProgressView.FormClose(Sender: TObject;
     306  var CloseAction: TCloseAction);
     307begin
     308end;
     309
     310procedure TFormJobProgressView.FormCreate(Sender: TObject);
     311begin
     312  Caption := SPleaseWait;
     313  try
     314    //Animate1.FileName := ExtractFileDir(UTF8Encode(Application.ExeName)) +
     315    //  DirectorySeparator + 'horse.avi';
     316    //Animate1.Active := True;
     317  except
     318
     319  end;
     320end;
     321
     322procedure TFormJobProgressView.ReloadJobList;
     323begin
     324  // Workaround for not showing first line
     325  //Form.ListViewJobs.Items.Count := Jobs.Count + 1;
     326  //Form.ListViewJobs.Refresh;
     327
     328  if ListViewJobs.Items.Count <> JobProgressView.Jobs.Count then
     329    ListViewJobs.Items.Count := JobProgressView.Jobs.Count;
     330  ListViewJobs.Refresh;
     331  Application.ProcessMessages;
     332  UpdateHeight;
     333end;
     334
     335procedure TFormJobProgressView.FormShow(Sender: TObject);
     336begin
     337  ReloadJobList;
     338end;
     339
     340procedure TFormJobProgressView.FormHide(Sender: TObject);
     341begin
     342  JobProgressView.Jobs.Clear;
     343  ReloadJobList;
     344end;
     345
     346procedure TFormJobProgressView.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
     347begin
     348  CanClose := JobProgressView.Finished;
     349  JobProgressView.Terminate := True;
     350  Caption := SPleaseWait + STerminate;
     351end;
     352
     353
     354{ TJobProgressView }
     355
     356function TJobProgressView.AddJob(Title: string; Method: TJobProgressViewMethod;
     357  NoThreaded: Boolean = False; WaitFor: Boolean = False): TJob;
     358begin
     359  Result := TJob.Create;
     360  Result.ProgressView := Self;
     361  Result.Title := Title;
     362  Result.Method := Method;
     363  Result.NoThreaded := NoThreaded;
     364  Result.WaitFor := WaitFor;
     365  Result.Progress.Max := 100;
     366  Result.Progress.Reset;
     367  Result.Progress.OnChange := JobProgressChange;
     368  Jobs.Add(Result);
    199369  //ReloadJobList;
    200370end;
    201371
    202 procedure TJobProgressView.Start(AAutoClose: Boolean = True);
    203 begin
    204   AutoClose := AAutoClose;
    205   StartJobs;
    206 end;
    207 
    208 procedure TJobProgressView.StartJobs;
     372procedure TJobProgressView.Start;
    209373var
    210374  I: Integer;
    … …  
    212376  Terminate := False;
    213377
    214   Form.BringToFront;
     378  if not OwnerDraw then Form.BringToFront;
    215379
    216380  Finished := False;
    … …  
    221385    Form.MemoLog.Clear;
    222386
     387    Form.PanelText.Visible := False;
    223388    Form.LabelEstimatedTimePart.Visible := False;
    224389    Form.LabelEstimatedTimeTotal.Visible := False;
    … …  
    244409      CurrentJobIndex := I;
    245410      CurrentJob := TJob(Jobs[I]);
     411      JobProgressChange(Self);
    246412      StartTime := Now;
    247413      Form.LabelEstimatedTimePart.Caption := Format(SEstimatedTime, ['']);
    … …  
    249415      Form.ProgressBarPart.Visible := False;
    250416      //Show;
    251       ReloadJobList;
     417      Form.ReloadJobList;
    252418      Application.ProcessMessages;
    253419      if NoThreaded then begin
    … …  
    287453    //if Visible then Hide;
    288454    Form.MemoLog.Lines.Assign(Log);
    289     if (Form.MemoLog.Lines.Count = 0) and AutoClose then begin
     455    if (Form.MemoLog.Lines.Count = 0) and FAutoClose then begin
    290456      Form.Hide;
    291457    end;
    292     Clear;
     458    if not Form.Visible then Clear;
    293459    Form.Caption := SFinished;
    294460    //LabelEstimatedTimePart.Visible := False;
    295461    Finished := True;
    296462    CurrentJobIndex := -1;
    297     ReloadJobList;
    298   end;
    299 end;
    300 
    301 procedure TJobProgressView.UpdateHeight;
    302 var
    303   H: Integer;
    304   PanelOperationsVisible: Boolean;
    305   PanelOperationsHeight: Integer;
    306   PanelProgressVisible: Boolean;
    307   PanelProgressTotalVisible: Boolean;
    308   PanelLogVisible: Boolean;
    309 begin
    310   with Form do begin
    311   H := PanelOperationsTitle.Height;
    312   PanelOperationsVisible := Jobs.Count > 0;
    313   if PanelOperationsVisible <> PanelOperations.Visible then
    314     PanelOperations.Visible := PanelOperationsVisible;
    315   PanelOperationsHeight := 8 + 18 * Jobs.Count;
    316   if PanelOperationsHeight <> PanelOperations.Height then
    317     PanelOperations.Height := PanelOperationsHeight;
    318   if PanelOperationsVisible then
    319     H := H + PanelOperations.Height;
    320 
    321   PanelProgressVisible := (Jobs.Count > 0) and not Finished;
    322   if PanelProgressVisible <> PanelProgress.Visible then
    323     PanelProgress.Visible := PanelProgressVisible;
    324   if PanelProgressVisible then
    325     H := H + PanelProgress.Height;
    326   PanelProgressTotalVisible := (Jobs.Count > 1) and not Finished;
    327   if PanelProgressTotalVisible <> PanelProgressTotal.Visible then
    328     PanelProgressTotal.Visible := PanelProgressTotalVisible;
    329   if PanelProgressTotalVisible then
    330     H := H + PanelProgressTotal.Height;
    331   Constraints.MinHeight := H;
    332   PanelLogVisible := MemoLog.Lines.Count > 0;
    333   if PanelLogVisible <> PanelLog.Visible then
    334     PanelLog.Visible := PanelLogVisible;
    335   if PanelLogVisible then
    336     H := H + MemoLogHeight;
    337   if Height <> H then Height := H;
    338   end;
    339 end;
    340 
    341 procedure TFormJobProgressView.TimerUpdateTimer(Sender: TObject);
    342 var
    343   ProgressBarPartVisible: Boolean;
    344   ProgressBarTotalVisible: Boolean;
    345 begin
    346   JobProgressView.UpdateProgress;
    347   if Visible and (not ProgressBarPart.Visible) and
    348   Assigned(JobProgressView.CurrentJob) and
    349   (JobProgressView.CurrentJob.Progress.Value > 0) then begin
    350     ProgressBarPartVisible := True;
    351     if ProgressBarPartVisible <> ProgressBarPart.Visible then
    352       ProgressBarPart.Visible := ProgressBarPartVisible;
    353     ProgressBarTotalVisible := True;
    354     if ProgressBarTotalVisible <> ProgressBarTotal.Visible then
    355       ProgressBarTotal.Visible := ProgressBarTotalVisible;
    356   end;
    357   if not Visible then begin
    358     TimerUpdate.Interval := UpdateInterval;
    359     Show;
    360   end;
    361 end;
    362 
    363 procedure TFormJobProgressView.FormDestroy(Sender:TObject);
    364 begin
    365 end;
    366 
    367 procedure TFormJobProgressView.ListViewJobsData(Sender: TObject; Item: TListItem);
    368 begin
    369   if (Item.Index >= 0) and (Item.Index < JobProgressView.Jobs.Count) then
    370   with TJob(JobProgressView.Jobs[Item.Index]) do begin
    371     Item.Caption := Title;
    372     if Item.Index = JobProgressView.CurrentJobIndex then Item.ImageIndex := 1
    373       else if Finished then Item.ImageIndex := 0
    374       else Item.ImageIndex := 2;
    375     Item.Data := JobProgressView.Jobs[Item.Index];
    376   end;
    377 end;
    378 
    379 procedure TFormJobProgressView.FormClose(Sender: TObject;
    380   var CloseAction: TCloseAction);
    381 begin
    382   ListViewJobs.Clear;
    383 end;
    384 
    385 procedure TFormJobProgressView.FormCreate(Sender: TObject);
    386 begin
    387   Caption := SPleaseWait;
    388   try
    389     //Animate1.FileName := ExtractFileDir(UTF8Encode(Application.ExeName)) +
    390     //  DirectorySeparator + 'horse.avi';
    391     //Animate1.Active := True;
    392   except
    393 
    394   end;
     463    Form.ReloadJobList;
     464  end;
     465end;
     466
     467procedure TJobProgressView.JobProgressChange(Sender: TObject);
     468begin
     469  if Assigned(FOnOwnerDraw) then
     470    FOnOwnerDraw(Self);
    395471end;
    396472
    … …  
    411487    Sleep(Quantum);
    412488  end;
    413 end;
    414 
    415 procedure TFormJobProgressView.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    416 begin
    417   CanClose := JobProgressView.Finished;
    418   JobProgressView.Terminate := True;
    419   Caption := SPleaseWait + STerminate;
    420489end;
    421490
    … …  
    475544end;
    476545
    477 procedure TJobProgressView.ReloadJobList;
    478 begin
    479   UpdateHeight;
    480   // Workaround for not showing first line
    481   Form.ListViewJobs.Items.Count := Jobs.Count + 1;
    482   Form.ListViewJobs.Refresh;
    483 
    484   if Form.ListViewJobs.Items.Count <> Jobs.Count then
    485     Form.ListViewJobs.Items.Count := Jobs.Count;
    486   Form.ListViewJobs.Refresh;
    487   //Application.ProcessMessages;
    488 end;
    489 
    490546constructor TJobProgressView.Create(TheOwner: TComponent);
    491547begin
    492548  inherited;
    493549  if not (csDesigning in ComponentState) then begin
    494     Form := TFormJobProgressView.Create(Self);
    495     Form.JobProgressView := Self;
    496   end;
    497   Jobs := TObjectList.Create;
     550    FForm := TFormJobProgressView.Create(Self);
     551    FForm.JobProgressView := Self;
     552  end;
     553  Jobs := TJobs.Create;
    498554  Log := TStringList.Create;
    499555  //PanelOperationsTitle.Height := 80;
    500   ShowDelay := 0; //1000; // ms
     556  AutoClose := True;
     557  ShowDelay := 0;
    501558end;
    502559
    … …  
    504561begin
    505562  Jobs.Clear;
     563  Log.Clear;
    506564  //ReloadJobList;
    507565end;
    … …  
    509567destructor TJobProgressView.Destroy;
    510568begin
    511   Log.Free;
    512   Jobs.Free;
    513   inherited Destroy;
    514 end;
     569  FreeAndNil(Log);
     570  FreeAndNil(Jobs);
     571  inherited;
     572end;
     573
     574{ TProgress }
    515575
    516576procedure TProgress.SetMax(const AValue: Integer);
    … …  
    519579    FLock.Acquire;
    520580    FMax := AValue;
     581    if FMax < 1 then FMax := 1;
    521582    if FValue >= FMax then FValue := FMax;
     583  finally
     584    FLock.Release;
     585  end;
     586end;
     587
     588procedure TProgress.SetText(AValue: string);
     589begin
     590  try
     591    FLock.Acquire;
     592    if FText = AValue then Exit;
     593    FText := AValue;
    522594  finally
    523595    FLock.Release;
    … …  
    547619end;
    548620
    549 { TProgress }
    550 
    551621procedure TProgress.Increment;
    552622begin
    … …  
    610680begin
    611681  Progress.Free;
    612   inherited Destroy;
     682  inherited;
    613683end;
    614684

  • trunk/Packages/Common/ULastOpenedList.pas

    r89 r122  
    66
    77uses
    8   Classes, SysUtils, Registry, URegistry, Menus;
     8  Classes, SysUtils, Registry, URegistry, Menus, XMLConf, DOM;
    99
    1010type
    … …  
    1818    procedure SetMaxCount(AValue: Integer);
    1919    procedure LimitMaxCount;
     20    procedure ItemsChange(Sender: TObject);
     21    procedure DoChange;
    2022  public
    2123    Items: TStringList;
    … …  
    2527    procedure LoadFromRegistry(Context: TRegistryContext);
    2628    procedure SaveToRegistry(Context: TRegistryContext);
     29    procedure LoadFromXMLConfig(XMLConfig: TXMLConfig; Path: string);
     30    procedure SaveToXMLConfig(XMLConfig: TXMLConfig; Path: string);
    2731    procedure AddItem(FileName: string);
    2832  published
    … …  
    3842procedure Register;
    3943begin
    40   RegisterComponents('Samples', [TLastOpenedList]);
     44  RegisterComponents('Common', [TLastOpenedList]);
    4145end;
    4246
    … …  
    5862end;
    5963
     64procedure TLastOpenedList.ItemsChange(Sender: TObject);
     65begin
     66  DoChange;
     67end;
     68
     69procedure TLastOpenedList.DoChange;
     70begin
     71  if Assigned(FOnChange) then
     72    FOnChange(Self);
     73end;
     74
    6075constructor TLastOpenedList.Create(AOwner: TComponent);
    6176begin
    6277  inherited;
    6378  Items := TStringList.Create;
     79  Items.OnChange := ItemsChange;
    6480  MaxCount := 10;
    6581end;
    … …  
    123139    OpenKey(Context.Key, True);
    124140    for I := 0 to Items.Count - 1 do
    125       WriteString('File' + IntToStr(I), UTF8Decode(Items[I]));
     141      WriteString('File' + IntToStr(I), Items[I]);
    126142  finally
    127143    Free;
     144  end;
     145end;
     146
     147procedure TLastOpenedList.LoadFromXMLConfig(XMLConfig: TXMLConfig; Path: string
     148  );
     149var
     150  I: Integer;
     151  Value: string;
     152  Count: Integer;
     153begin
     154  with XMLConfig do begin
     155    Count := GetValue(DOMString(Path + '/Count'), 0);
     156    if Count > MaxCount then Count := MaxCount;
     157    Items.Clear;
     158    for I := 0 to Count - 1 do begin
     159      Value := string(GetValue(DOMString(Path + '/File' + IntToStr(I)), ''));
     160      if Trim(Value) <> '' then Items.Add(Value);
     161    end;
     162    if Assigned(FOnChange) then
     163      FOnChange(Self);
     164  end;
     165end;
     166
     167procedure TLastOpenedList.SaveToXMLConfig(XMLConfig: TXMLConfig; Path: string);
     168var
     169  I: Integer;
     170begin
     171  with XMLConfig do begin
     172    SetValue(DOMString(Path + '/Count'), Items.Count);
     173    for I := 0 to Items.Count - 1 do
     174      SetValue(DOMString(Path + '/File' + IntToStr(I)), DOMString(Items[I]));
     175    Flush;
    128176  end;
    129177end;
    … …  
    134182  Items.Insert(0, FileName);
    135183  LimitMaxCount;
    136   if Assigned(FOnChange) then
    137     FOnChange(Self);
     184  DoChange;
    138185end;
    139186

  • trunk/Packages/Common/URegistry.pas

    r89 r122  
    99
    1010type
    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));
     11  TRegistryRoot = (rrKeyClassesRoot, rrKeyCurrentUser, rrKeyLocalMachine,
     12    rrKeyUsers, rrKeyPerformanceData, rrKeyCurrentConfig, rrKeyDynData);
     13
     14  { TRegistryContext }
    1815
    1916  TRegistryContext = record
    2017    RootKey: HKEY;
    2118    Key: string;
     19    class operator Equal(A, B: TRegistryContext): Boolean;
     20    function Create(RootKey: TRegistryRoot; Key: string): TRegistryContext; overload;
     21    function Create(RootKey: HKEY; Key: string): TRegistryContext; overload;
    2222  end;
    2323
    … …  
    2626  TRegistryEx = class(TRegistry)
    2727  private
     28    function GetCurrentContext: TRegistryContext;
     29    procedure SetCurrentContext(AValue: TRegistryContext);
    2830  public
    2931    function ReadBoolWithDefault(const Name: string;
    … …  
    3537    function DeleteKeyRecursive(const Key: string): Boolean;
    3638    function OpenKey(const Key: string; CanCreate: Boolean): Boolean;
     39    property CurrentContext: TRegistryContext read GetCurrentContext write SetCurrentContext;
    3740  end;
    3841
    39 function RegContext(RootKey: HKEY; Key: string): TRegistryContext;
    40 
     42const
     43  RegistryRootHKEY: array[TRegistryRoot] of HKEY = (HKEY_CLASSES_ROOT,
     44    HKEY_CURRENT_USER, HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_PERFORMANCE_DATA,
     45    HKEY_CURRENT_CONFIG, HKEY_DYN_DATA);
    4146
    4247implementation
    4348
    44 function RegContext(RootKey: HKEY; Key: string): TRegistryContext;
     49
     50{ TRegistryContext }
     51
     52class operator TRegistryContext.Equal(A, B: TRegistryContext): Boolean;
     53begin
     54  Result := (A.Key = B.Key) and (A.RootKey = B.RootKey);
     55end;
     56
     57function TRegistryContext.Create(RootKey: TRegistryRoot; Key: string): TRegistryContext;
     58begin
     59  Result.RootKey := RegistryRootHKEY[RootKey];
     60  Result.Key := Key;
     61end;
     62
     63function TRegistryContext.Create(RootKey: HKEY; Key: string): TRegistryContext;
    4564begin
    4665  Result.RootKey := RootKey;
    … …  
    106125end;
    107126
     127function TRegistryEx.GetCurrentContext: TRegistryContext;
     128begin
     129  Result.Key := CurrentPath;
     130  Result.RootKey := RootKey;
     131end;
     132
     133procedure TRegistryEx.SetCurrentContext(AValue: TRegistryContext);
     134begin
     135  RootKey := AValue.RootKey;
     136  OpenKey(AValue.Key, True);
     137end;
     138
    108139function TRegistryEx.ReadBoolWithDefault(const Name: string;
    109140  DefaultValue: Boolean): Boolean;

  • trunk/Packages/Common/UResetableThread.pas

    r89 r122  
    104104
    105105procedure TResetableThread.WaitForStart;
    106 var
    107   WaitResult: TWaitResult;
     106//var
     107//  WaitResult: TWaitResult;
    108108begin
    109109  //try
    … …  
    127127
    128128procedure TResetableThread.WaitForStop;
    129 var
    130   WaitState: TWaitResult;
     129//var
     130//  WaitState: TWaitResult;
    131131begin
    132132  try
    … …  
    156156  FThread.Name := 'ResetableThread';
    157157  FThread.Parent := Self;
    158   FThread.Resume;
     158  FThread.Start;
    159159end;
    160160

  • trunk/Packages/Common/UThreading.pas

    r89 r122  
    3030    Name: string;
    3131    procedure Execute; virtual; abstract;
    32     procedure Resume; virtual; abstract;
    33     procedure Suspend; virtual; abstract;
    3432    procedure Start; virtual; abstract;
    3533    procedure Terminate; virtual; abstract;
    … …  
    8179    procedure Sleep(Delay: Integer); override;
    8280    procedure Execute; override;
    83     procedure Resume; override;
    84     procedure Suspend; override;
    8581    procedure Start; override;
    8682    procedure Terminate; override;
    … …  
    134130    Thread.FreeOnTerminate := False;
    135131    Thread.Method := Method;
    136     Thread.Resume;
     132    Thread.Start;
    137133    while (Thread.State = ttsRunning) or (Thread.State = ttsReady) do begin
    138134      if MainThreadID = ThreadID then Application.ProcessMessages;
    … …  
    155151    Thread.Method := Method;
    156152    Thread.OnFinished := CallBack;
    157     Thread.Resume;
     153    Thread.Start;
    158154    //if Thread.State = ttsExceptionOccured then
    159155    //  raise Exception.Create(Thread.ExceptionMessage);
    … …  
    313309procedure TListedThread.Execute;
    314310begin
    315 end;
    316 
    317 procedure TListedThread.Resume;
    318 begin
    319   FThread.Resume;
    320 end;
    321 
    322 procedure TListedThread.Suspend;
    323 begin
    324   FThread.Suspend;
    325311end;
    326312

  • trunk/Packages/Common/UURI.pas

    r84 r122  
    8989function LeftCutString(var Source: string; out Output: string; Delimiter: string; Allowed: string = ''): Boolean;
    9090var
    91   I, J: Integer;
     91  I: Integer;
    9292  Matched: Boolean;
    9393begin
    … …  
    113113function RightCutString(var Source: string; out Output: string; Delimiter: string; Allowed: string = ''): Boolean;
    114114var
    115   I, J: Integer;
     115  I: Integer;
    116116  Matched: Boolean;
    117117begin
    … …  
    202202
    203203procedure TURI.SetAsString(Value: string);
    204 var
    205   HostAddr: string;
    206   HostPort: string;
    207204begin
    208205  LeftCutString(Value, Scheme, ':');
    … …  
    326323    Drive := Drive + DriveSeparator;
    327324  end else Drive := '';
    328   Directory.AsString := AValue;
     325  if (Drive <> '') and (AValue = '') then
     326    Directory.AsString := Directory.DirSeparator
     327    else Directory.AsString := AValue;
    329328end;
    330329

  • trunk/Packages/Common/UXMLUtils.pas

    r89 r122  
    77uses
    88  {$IFDEF WINDOWS}Windows,{$ENDIF}
    9   Classes, SysUtils, DateUtils;
     9  Classes, SysUtils, DateUtils, DOM;
    1010
    1111function XMLTimeToDateTime(XMLDateTime: string): TDateTime;
    12 function DateTimeToXMLTime(Value: TDateTime; ApplyLocalBias: Boolean = True): WideString;
     12function DateTimeToXMLTime(Value: TDateTime; ApplyLocalBias: Boolean = True): string;
     13procedure WriteInteger(Node: TDOMNode; Name: string; Value: Integer);
     14procedure WriteInt64(Node: TDOMNode; Name: string; Value: Int64);
     15procedure WriteBoolean(Node: TDOMNode; Name: string; Value: Boolean);
     16procedure WriteString(Node: TDOMNode; Name: string; Value: string);
     17procedure WriteDateTime(Node: TDOMNode; Name: string; Value: TDateTime);
     18function ReadInteger(Node: TDOMNode; Name: string; DefaultValue: Integer): Integer;
     19function ReadInt64(Node: TDOMNode; Name: string; DefaultValue: Int64): Int64;
     20function ReadBoolean(Node: TDOMNode; Name: string; DefaultValue: Boolean): Boolean;
     21function ReadString(Node: TDOMNode; Name: string; DefaultValue: string): string;
     22function ReadDateTime(Node: TDOMNode; Name: string; DefaultValue: TDateTime): TDateTime;
    1323
    1424
    … …  
    2030  TimeZoneInfo: TTimeZoneInformation;
    2131begin
     32  {$push}{$warn 5057 off}
    2233  case GetTimeZoneInformation(TimeZoneInfo) of
    23   TIME_ZONE_ID_STANDARD: Result := TimeZoneInfo.Bias + TimeZoneInfo.StandardBias;
    24   TIME_ZONE_ID_DAYLIGHT: Result := TimeZoneInfo.Bias + TimeZoneInfo.DaylightBias;
     34    TIME_ZONE_ID_STANDARD: Result := TimeZoneInfo.Bias + TimeZoneInfo.StandardBias;
     35    TIME_ZONE_ID_DAYLIGHT: Result := TimeZoneInfo.Bias + TimeZoneInfo.DaylightBias;
    2536  else
    2637    Result := 0;
    2738  end;
     39  {$pop}
    2840end;
    2941{$ELSE}
    … …  
    3547function LeftCutString(var Source: string; out Output: string; Delimiter: string; Allowed: string = ''): Boolean;
    3648var
    37   I, J: Integer;
     49  I: Integer;
    3850  Matched: Boolean;
    3951begin
    … …  
    6678  Minute: Integer;
    6779  Second: Integer;
     80  SecondFraction: Double;
    6881  Millisecond: Integer;
    6982begin
    … …  
    88101      if Pos('Z', XMLDateTime) > 0 then
    89102        LeftCutString(XMLDateTime, Part, 'Z');
    90       Millisecond := StrToInt(Part);
     103      SecondFraction := StrToFloat('0' + DefaultFormatSettings.DecimalSeparator + Part);
     104      Millisecond := Trunc(SecondFraction * 1000);
    91105    end else begin
    92106      if Pos('+', XMLDateTime) > 0 then
    … …  
    106120end;
    107121
    108 function DateTimeToXMLTime(Value: TDateTime; ApplyLocalBias: Boolean = True): WideString;
     122function DateTimeToXMLTime(Value: TDateTime; ApplyLocalBias: Boolean = True): string;
    109123const
    110124  Neg: array[Boolean] of string =  ('+', '-');
    … …  
    123137end;
    124138
     139procedure WriteInteger(Node: TDOMNode; Name: string; Value: Integer);
     140var
     141  NewNode: TDOMNode;
     142begin
     143  NewNode := Node.OwnerDocument.CreateElement(DOMString(Name));
     144  NewNode.TextContent := DOMString(IntToStr(Value));
     145  Node.AppendChild(NewNode);
     146end;
     147
     148procedure WriteInt64(Node: TDOMNode; Name: string; Value: Int64);
     149var
     150  NewNode: TDOMNode;
     151begin
     152  NewNode := Node.OwnerDocument.CreateElement(DOMString(Name));
     153  NewNode.TextContent := DOMString(IntToStr(Value));
     154  Node.AppendChild(NewNode);
     155end;
     156
     157procedure WriteBoolean(Node: TDOMNode; Name: string; Value: Boolean);
     158var
     159  NewNode: TDOMNode;
     160begin
     161  NewNode := Node.OwnerDocument.CreateElement(DOMString(Name));
     162  NewNode.TextContent := DOMString(BoolToStr(Value));
     163  Node.AppendChild(NewNode);
     164end;
     165
     166procedure WriteString(Node: TDOMNode; Name: string; Value: string);
     167var
     168  NewNode: TDOMNode;
     169begin
     170  NewNode := Node.OwnerDocument.CreateElement(DOMString(Name));
     171  NewNode.TextContent := DOMString(Value);
     172  Node.AppendChild(NewNode);
     173end;
     174
     175procedure WriteDateTime(Node: TDOMNode; Name: string; Value: TDateTime);
     176var
     177  NewNode: TDOMNode;
     178begin
     179  NewNode := Node.OwnerDocument.CreateElement(DOMString(Name));
     180  NewNode.TextContent := DOMString(DateTimeToXMLTime(Value));
     181  Node.AppendChild(NewNode);
     182end;
     183
     184function ReadInteger(Node: TDOMNode; Name: string; DefaultValue: Integer): Integer;
     185var
     186  NewNode: TDOMNode;
     187begin
     188  Result := DefaultValue;
     189  NewNode := Node.FindNode(DOMString(Name));
     190  if Assigned(NewNode) then
     191    Result := StrToInt(string(NewNode.TextContent));
     192end;
     193
     194function ReadInt64(Node: TDOMNode; Name: string; DefaultValue: Int64): Int64;
     195var
     196  NewNode: TDOMNode;
     197begin
     198  Result := DefaultValue;
     199  NewNode := Node.FindNode(DOMString(Name));
     200  if Assigned(NewNode) then
     201    Result := StrToInt64(string(NewNode.TextContent));
     202end;
     203
     204function ReadBoolean(Node: TDOMNode; Name: string; DefaultValue: Boolean): Boolean;
     205var
     206  NewNode: TDOMNode;
     207begin
     208  Result := DefaultValue;
     209  NewNode := Node.FindNode(DOMString(Name));
     210  if Assigned(NewNode) then
     211    Result := StrToBool(string(NewNode.TextContent));
     212end;
     213
     214function ReadString(Node: TDOMNode; Name: string; DefaultValue: string): string;
     215var
     216  NewNode: TDOMNode;
     217begin
     218  Result := DefaultValue;
     219  NewNode := Node.FindNode(DOMString(Name));
     220  if Assigned(NewNode) then
     221    Result := string(NewNode.TextContent);
     222end;
     223
     224function ReadDateTime(Node: TDOMNode; Name: string; DefaultValue: TDateTime
     225  ): TDateTime;
     226var
     227  NewNode: TDOMNode;
     228begin
     229  Result := DefaultValue;
     230  NewNode := Node.FindNode(DOMString(Name));
     231  if Assigned(NewNode) then
     232    Result := XMLTimeToDateTime(string(NewNode.TextContent));
     233end;
     234
    125235end.
    126236

  • trunk/Packages/CoolWeb/WebServer/UHTTPServer.pas

    r100 r122  
    232232    end else
    233233    with Response.Content do begin
    234       WriteLn(Format(SFileNotFound, [Request.Path.Implode('/', StrToStr)]));
     234      //WriteLn(Format(SFileNotFound, [Request.Path.Implode('/', StrToStr)]));
    235235      WriteString('<html><body>' + Format(SFileNotFound, [Request.Path.Implode('/', StrToStr)]) + '</body></html>');
    236236    end;
Note: See TracChangeset for help on using the changeset viewer.