Changeset 21 for trunk/Packages/Common


Ignore:
Timestamp:
May 8, 2019, 12:11:40 PM (5 years ago)
Author:
chronos
Message:
  • Fixed: Build under Lazarus 2.0.
  • Modified: Used .lrj files instead of .lrt files.
  • Removed: TemplateGenerics package.
Location:
trunk/Packages/Common
Files:
3 added
1 deleted
24 edited

Legend:

Unmodified
Added
Removed

  • trunk/Packages/Common/Common.lpk

    r15 r21  
    4040    <License Value="GNU/GPL"/>
    4141    <Version Minor="7"/>
    42     <Files Count="21">
     42    <Files Count="22">
    4343      <Item1>
    4444        <Filename Value="StopWatch.pas"/>
    … …  
    6060      <Item5>
    6161        <Filename Value="UPrefixMultiplier.pas"/>
     62        <HasRegisterProc Value="True"/>
    6263        <UnitName Value="UPrefixMultiplier"/>
    6364      </Item5>
    … …  
    134135        <UnitName Value="UTheme"/>
    135136      </Item21>
     137      <Item22>
     138        <Filename Value="UStringTable.pas"/>
     139        <UnitName Value="UStringTable"/>
     140      </Item22>
    136141    </Files>
    137142    <i18n>
    … …  
    140145      <EnableI18NForLFM Value="True"/>
    141146    </i18n>
    142     <RequiredPkgs Count="3">
     147    <RequiredPkgs Count="2">
    143148      <Item1>
    144149        <PackageName Value="LCL"/>
    145150      </Item1>
    146151      <Item2>
    147         <PackageName Value="TemplateGenerics"/>
    148       </Item2>
    149       <Item3>
    150152        <PackageName Value="FCL"/>
    151153        <MinVersion Major="1" Valid="True"/>
    152       </Item3>
     154      </Item2>
    153155    </RequiredPkgs>
    154156    <UsageOptions>

  • trunk/Packages/Common/Common.pas

    r15 r21  
    55unit Common;
    66
     7{$warn 5023 off : no warning about unused units}
    78interface
    89
    910uses
    10   StopWatch, UCommon, UDebugLog, UDelay, UPrefixMultiplier, UURI, UThreading,
    11   UMemory, UResetableThread, UPool, ULastOpenedList, URegistry,
    12   UJobProgressView, UXMLUtils, UApplicationInfo, USyncCounter, UListViewSort,
    13   UPersistentForm, UFindFile, UScaleDPI, UTheme, LazarusPackageIntf;
     11  StopWatch, UCommon, UDebugLog, UDelay, UPrefixMultiplier, UURI, UThreading,
     12  UMemory, UResetableThread, UPool, ULastOpenedList, URegistry,
     13  UJobProgressView, UXMLUtils, UApplicationInfo, USyncCounter, UListViewSort,
     14  UPersistentForm, UFindFile, UScaleDPI, UTheme, UStringTable,
     15  LazarusPackageIntf;
    1416
    1517implementation
    … …  
    1820begin
    1921  RegisterUnit('UDebugLog', @UDebugLog.Register);
     22  RegisterUnit('UPrefixMultiplier', @UPrefixMultiplier.Register);
    2023  RegisterUnit('ULastOpenedList', @ULastOpenedList.Register);
    2124  RegisterUnit('UJobProgressView', @UJobProgressView.Register);

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

    r1 r21  
    1010"Content-Type: text/plain; charset=UTF-8\n"
    1111"Content-Transfer-Encoding: 8bit\n"
    12 "X-Generator: Poedit 1.8.8\n"
     12"X-Generator: Poedit 2.2\n"
    1313
    1414#: ujobprogressview.sestimatedtime
    … …  
    2424msgstr "Dokončené"
    2525
    26 #: ujobprogressview.soperations
    27 msgid "Operations"
    28 msgstr "Operace"
    29 
    3026#: ujobprogressview.spleasewait
    3127msgid "Please wait..."

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

    r1 r21  
    1414msgstr ""
    1515
    16 #: ujobprogressview.soperations
    17 msgid "Operations"
    18 msgstr ""
    19 
    2016#: ujobprogressview.spleasewait
    2117msgid "Please wait..."

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

    r1 r21  
    33
    44#: uthreading.scurrentthreadnotfound
     5#, fuzzy,badformat
    56msgid "Current thread ID %d not found in virtual thread list."
    67msgstr "Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8"

  • trunk/Packages/Common/UApplicationInfo.pas

    r1 r21  
    66
    77uses
    8   SysUtils, Registry, Classes, Forms, URegistry;
     8  SysUtils, Classes, Forms, URegistry, Controls;
    99
    1010type
    … …  
    1414  TApplicationInfo = class(TComponent)
    1515  private
    16     FDescription: string;
     16    FDescription: TCaption;
    1717    FIdentification: Byte;
    1818    FLicense: string;
    … …  
    5757
    5858implementation
    59                        
     59
    6060procedure Register;
    6161begin

  • trunk/Packages/Common/UCommon.pas

    r15 r21  
    2828    unfDNSDomainName = 11);
    2929
    30   TFilterMethodMethod = function (FileName: string): Boolean of object;
     30  TFilterMethod = function (FileName: string): Boolean of object;
     31  TFileNameMethod = procedure (FileName: string) of object;
     32
    3133var
    3234  ExceptionHandler: TExceptionEvent;
    … …  
    7274function MergeArray(A, B: array of string): TArrayOfString;
    7375function LoadFileToStr(const FileName: TFileName): AnsiString;
     76procedure SaveStringToFile(S, FileName: string);
    7477procedure SearchFiles(AList: TStrings; Dir: string;
    75   FilterMethod: TFilterMethodMethod);
     78  FilterMethod: TFilterMethod = nil; FileNameMethod: TFileNameMethod = nil);
     79function GetStringPart(var Text: string; Separator: string): string;
     80function StripTags(const S: string): string;
     81function PosFromIndex(SubStr: string; Text: string;
     82  StartIndex: Integer): Integer;
     83function PosFromIndexReverse(SubStr: string; Text: string;
     84  StartIndex: Integer): Integer;
     85procedure CopyStringArray(Dest: TStringArray; Source: array of string);
    7686
    7787
    … …  
    101111  I: Integer;
    102112begin
     113  Result := '';
    103114  for I := 1 to Length(Source) do begin
    104115    Result := Result + LowerCase(IntToHex(Ord(Source[I]), 2));
    … …  
    522533end;
    523534
     535procedure SaveStringToFile(S, FileName: string);
     536var
     537  F: TextFile;
     538begin
     539  AssignFile(F, FileName);
     540  try
     541    ReWrite(F);
     542    Write(F, S);
     543  finally
     544    CloseFile(F);
     545  end;
     546end;
     547
    524548procedure SearchFiles(AList: TStrings; Dir: string;
    525   FilterMethod: TFilterMethodMethod);
     549  FilterMethod: TFilterMethod = nil; FileNameMethod: TFileNameMethod = nil);
    526550var
    527551  SR: TSearchRec;
    … …  
    531555    try
    532556      repeat
    533         if (SR.Name = '.') or (SR.Name = '..') or not FilterMethod(SR.Name) then Continue;
     557        if (SR.Name = '.') or (SR.Name = '..') or (Assigned(FilterMethod) and (not FilterMethod(SR.Name) or
     558          not FilterMethod(Copy(Dir, 3, Length(Dir)) + SR.Name))) then Continue;
     559        if Assigned(FileNameMethod) then
     560          FileNameMethod(Dir + SR.Name);
    534561        AList.Add(Dir + SR.Name);
    535562        if (SR.Attr and faDirectory) <> 0 then
    … …  
    541568end;
    542569
     570function GetStringPart(var Text: string; Separator: string): string;
     571var
     572  P: Integer;
     573begin
     574  P := Pos(Separator, Text);
     575  if P > 0 then begin
     576    Result := Copy(Text, 1, P - 1);
     577    Delete(Text, 1, P - 1 + Length(Separator));
     578  end else begin
     579    Result := Text;
     580    Text := '';
     581  end;
     582  Result := Trim(Result);
     583  Text := Trim(Text);
     584end;
     585
     586function StripTags(const S: string): string;
     587var
     588  Len: Integer;
     589
     590  function ReadUntil(const ReadFrom: Integer; const C: Char): Integer;
     591  var
     592    J: Integer;
     593  begin
     594    for J := ReadFrom to Len do
     595      if (S[j] = C) then
     596      begin
     597        Result := J;
     598        Exit;
     599      end;
     600    Result := Len + 1;
     601  end;
     602
     603var
     604  I, APos: Integer;
     605begin
     606  Len := Length(S);
     607  I := 0;
     608  Result := '';
     609  while (I <= Len) do begin
     610    Inc(I);
     611    APos := ReadUntil(I, '<');
     612    Result := Result + Copy(S, I, APos - i);
     613    I := ReadUntil(APos + 1, '>');
     614  end;
     615end;
     616
     617function PosFromIndex(SubStr: string; Text: string;
     618  StartIndex: Integer): Integer;
     619var
     620  I, MaxLen: SizeInt;
     621  Ptr: PAnsiChar;
     622begin
     623  Result := 0;
     624  if (StartIndex < 1) or (StartIndex > Length(Text) - Length(SubStr)) then Exit;
     625  if Length(SubStr) > 0 then begin
     626    MaxLen := Length(Text) - Length(SubStr) + 1;
     627    I := StartIndex;
     628    Ptr := @Text[StartIndex];
     629    while (I <= MaxLen) do begin
     630      if (SubStr[1] = Ptr^) and (CompareByte(Substr[1], Ptr^, Length(SubStr)) = 0) then begin
     631        Result := I;
     632        Exit;
     633      end;
     634      Inc(I);
     635      Inc(Ptr);
     636    end;
     637  end;
     638end;
     639
     640function PosFromIndexReverse(SubStr: string; Text: string;
     641  StartIndex: Integer): Integer;
     642var
     643  I: SizeInt;
     644  Ptr: PAnsiChar;
     645begin
     646  Result := 0;
     647  if (StartIndex < 1) or (StartIndex > Length(Text)) then Exit;
     648  if Length(SubStr) > 0 then begin
     649    I := StartIndex;
     650    Ptr := @Text[StartIndex];
     651    while (I > 0) do begin
     652      if (SubStr[1] = Ptr^) and (CompareByte(Substr[1], Ptr^, Length(SubStr)) = 0) then begin
     653        Result := I;
     654        Exit;
     655      end;
     656      Dec(I);
     657      Dec(Ptr);
     658    end;
     659  end;
     660end;
     661
     662procedure CopyStringArray(Dest: TStringArray; Source: array of string);
     663var
     664  I: Integer;
     665begin
     666  SetLength(Dest, Length(Source));
     667  for I := 0 to Length(Dest) - 1 do
     668    Dest[I] := Source[I];
     669end;
     670
    543671
    544672initialization

  • trunk/Packages/Common/UDebugLog.pas

    r1 r21  
    66
    77uses
    8   Classes, SysUtils, FileUtil, SpecializedList, SyncObjs;
     8  Classes, SysUtils, FileUtil, fgl, SyncObjs;
    99
    1010type
    … …  
    2929    procedure SetMaxCount(const AValue: Integer);
    3030  public
    31     Items: TListObject;
     31    Items: TFPGObjectList<TDebugLogItem>;
    3232    Lock: TCriticalSection;
    3333    procedure Add(Text: string; Group: string = '');
    … …  
    104104    if ExtractFileDir(FileName) <> '' then
    105105      ForceDirectories(ExtractFileDir(FileName));
    106     if FileExists(FileName) then LogFile := TFileStream.Create(UTF8Decode(FileName), fmOpenWrite)
    107       else LogFile := TFileStream.Create(UTF8Decode(FileName), fmCreate);
     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;
    … …  
    117117begin
    118118  inherited;
    119   Items := TListObject.Create;
     119  Items := TFPGObjectList<TDebugLogItem>.Create;
    120120  Lock := TCriticalSection.Create;
    121121  MaxCount := 100;

  • trunk/Packages/Common/UFindFile.pas

    r1 r21  
    2424
    2525uses
    26   SysUtils, Classes, Graphics, Controls, Forms, Dialogs, FileCtrl;
     26  SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
    2727
    2828type
    … …  
    117117  Attr := 0;
    118118  if ffaReadOnly in FileAttr then Attr := Attr + faReadOnly;
    119   if ffaHidden in FileAttr then Attr := Attr + faHidden;
    120   if ffaSysFile in FileAttr then Attr := Attr + faSysFile;
    121   if ffaVolumeID in FileAttr then Attr := Attr + faVolumeID;
     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;
    122122  if ffaDirectory in FileAttr then Attr := Attr + faDirectory;
    123123  if ffaArchive in FileAttr then Attr := Attr + faArchive;
    124124  if ffaAnyFile in FileAttr then Attr := Attr + faAnyFile;
    125125
    126   if SysUtils.FindFirst(UTF8Decode(inPath + FileMask), Attr, Rec) = 0 then
     126  if SysUtils.FindFirst(inPath + FileMask, Attr, Rec) = 0 then
    127127  try
    128128    repeat
    129       s.Add(inPath + UTF8Encode(Rec.Name));
     129      s.Add(inPath + Rec.Name);
    130130    until SysUtils.FindNext(Rec) <> 0;
    131131  finally
    … …  
    135135  If not InSubFolders then Exit;
    136136
    137   if SysUtils.FindFirst(UTF8Decode(inPath + FilterAll), faDirectory, Rec) = 0 then
     137  if SysUtils.FindFirst(inPath + FilterAll, faDirectory, Rec) = 0 then
    138138  try
    139139    repeat
    140140      if ((Rec.Attr and faDirectory) > 0) and (Rec.Name <> '.')
    141141      and (Rec.Name <> '..') then
    142         FileSearch(IncludeTrailingBackslash(inPath + UTF8Encode(Rec.Name)));
     142        FileSearch(IncludeTrailingBackslash(inPath + Rec.Name));
    143143    until SysUtils.FindNext(Rec) <> 0;
    144144  finally

  • trunk/Packages/Common/UJobProgressView.lfm

    r1 r21  
    11object FormJobProgressView: TFormJobProgressView
    2   Left = 656
    3   Height = 246
    4   Top = 354
    5   Width = 328
     2  Left = 467
     3  Height = 345
     4  Top = 252
     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.6.0.4'
     17  LCLVersion = '2.0.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 = 13
     31      Height = 20
    3132      Top = 8
    32       Width = 66
     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 = 13
     80      Height = 20
    8381      Top = -2
    84       Width = 71
     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 = 13
     132      Height = 20
    135133      Top = 0
    136       Width = 97
     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
    … …  
    223241    Interval = 100
    224242    OnTimer = TimerUpdateTimer
    225     left = 264
     243    left = 320
    226244    top = 8
    227245  end

  • trunk/Packages/Common/UJobProgressView.pas

    r1 r21  
    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;
    … …  
    118129    TotalStartTime: TDateTime;
    119130    Log: TStringList;
     131    FForm: TFormJobProgressView;
    120132    procedure SetTerminate(const AValue: Boolean);
    121133    procedure UpdateProgress;
    122     procedure ReloadJobList;
    123     procedure StartJobs;
    124     procedure UpdateHeight;
    125134    procedure JobProgressChange(Sender: TObject);
    126135  public
    127     Form: TFormJobProgressView;
    128     Jobs: TObjectList; // TListObject<TJob>
     136    Jobs: TJobs;
    129137    CurrentJob: TJob;
    130138    CurrentJobIndex: Integer;
    … …  
    132140    destructor Destroy; override;
    133141    procedure Clear;
    134     procedure AddJob(Title: string; Method: TJobProgressViewMethod;
    135       NoThreaded: Boolean = False; WaitFor: Boolean = False);
    136     procedure Start(AAutoClose: Boolean = True);
     142    function AddJob(Title: string; Method: TJobProgressViewMethod;
     143      NoThreaded: Boolean = False; WaitFor: Boolean = False): TJob;
     144    procedure Start;
    137145    procedure Stop;
    138146    procedure TermSleep(Delay: Integer);
     147    property Form: TFormJobProgressView read FForm;
    139148    property Terminate: Boolean read FTerminate write SetTerminate;
    140149  published
    … …  
    166175  STotalEstimatedTime = 'Total estimated time: %s';
    167176  SFinished = 'Finished';
    168   SOperations = 'Operations';
    169177
    170178procedure Register;
    … …  
    172180  RegisterComponents('Common', [TJobProgressView]);
    173181end;
     182
     183{ TJobThread }
    174184
    175185procedure TJobThread.Execute;
    … …  
    190200end;
    191201
    192 procedure TJobProgressView.AddJob(Title: string; Method: TJobProgressViewMethod;
    193   NoThreaded: Boolean = False; WaitFor: Boolean = False);
     202{ TFormJobProgressView }
     203
     204procedure TFormJobProgressView.UpdateHeight;
    194205var
    195   NewJob: TJob;
    196 begin
    197   NewJob := TJob.Create;
    198   NewJob.ProgressView := Self;
    199   NewJob.Title := Title;
    200   NewJob.Method := Method;
    201   NewJob.NoThreaded := NoThreaded;
    202   NewJob.WaitFor := WaitFor;
    203   NewJob.Progress.Max := 100;
    204   NewJob.Progress.Reset;
    205   NewJob.Progress.OnChange := JobProgressChange;
    206   Jobs.Add(NewJob);
     206  H: Integer;
     207  PanelOperationsVisible: Boolean;
     208  PanelOperationsHeight: Integer;
     209  PanelProgressVisible: Boolean;
     210  PanelProgressTotalVisible: Boolean;
     211  PanelLogVisible: Boolean;
     212  MemoLogHeight: Integer = 200;
     213  I: Integer;
     214  ItemRect: TRect;
     215  MaxH: Integer;
     216begin
     217    H := PanelOperationsTitle.Height;
     218    PanelOperationsVisible := JobProgressView.Jobs.Count > 0;
     219    if PanelOperationsVisible <> PanelOperations.Visible then
     220      PanelOperations.Visible := PanelOperationsVisible;
     221    if ListViewJobs.Items.Count > 0 then begin
     222      Maxh := 0;
     223      for I := 0 to ListViewJobs.Items.Count - 1 do
     224      begin
     225        ItemRect := ListViewJobs.Items[i].DisplayRect(drBounds);
     226        Maxh := Max(Maxh, ItemRect.Top + (ItemRect.Bottom - ItemRect.Top));
     227      end;
     228      PanelOperationsHeight := Scale96ToScreen(12) + Maxh;
     229    end else PanelOperationsHeight := Scale96ToScreen(8);
     230    if PanelOperationsHeight <> PanelOperations.Height then
     231      PanelOperations.Height := PanelOperationsHeight;
     232    if PanelOperationsVisible then
     233      H := H + PanelOperations.Height;
     234
     235    PanelProgressVisible := (JobProgressView.Jobs.Count > 0) and not JobProgressView.Finished;
     236    if PanelProgressVisible <> PanelProgress.Visible then
     237      PanelProgress.Visible := PanelProgressVisible;
     238    if PanelProgressVisible then
     239      H := H + PanelProgress.Height;
     240    PanelProgressTotalVisible := (JobProgressView.Jobs.Count > 1) and not JobProgressView.Finished;
     241    if PanelProgressTotalVisible <> PanelProgressTotal.Visible then
     242      PanelProgressTotal.Visible := PanelProgressTotalVisible;
     243    if PanelProgressTotalVisible then
     244      H := H + PanelProgressTotal.Height;
     245    Constraints.MinHeight := H;
     246    PanelLogVisible := MemoLog.Lines.Count > 0;
     247    if PanelLogVisible <> PanelLog.Visible then
     248      PanelLog.Visible := PanelLogVisible;
     249    if PanelLogVisible then
     250      H := H + Scale96ToScreen(MemoLogHeight);
     251    if PanelText.Visible then
     252      H := H + PanelText.Height;
     253    if Height <> H then begin
     254      Height := H;
     255      Top := (Screen.Height - H) div 2;
     256    end;
     257end;
     258
     259procedure TFormJobProgressView.TimerUpdateTimer(Sender: TObject);
     260var
     261  ProgressBarPartVisible: Boolean;
     262  ProgressBarTotalVisible: Boolean;
     263begin
     264  JobProgressView.UpdateProgress;
     265  if Visible and (not ProgressBarPart.Visible) and
     266  Assigned(JobProgressView.CurrentJob) and
     267  (JobProgressView.CurrentJob.Progress.Value > 0) then begin
     268    ProgressBarPartVisible := True;
     269    if ProgressBarPartVisible <> ProgressBarPart.Visible then
     270      ProgressBarPart.Visible := ProgressBarPartVisible;
     271    ProgressBarTotalVisible := True;
     272    if ProgressBarTotalVisible <> ProgressBarTotal.Visible then
     273      ProgressBarTotal.Visible := ProgressBarTotalVisible;
     274  end;
     275  if not Visible then begin
     276    TimerUpdate.Interval := UpdateInterval;
     277    if not JobProgressView.OwnerDraw then Show;
     278  end;
     279  if Assigned(JobProgressView.CurrentJob) then begin
     280    LabelText.Caption := JobProgressView.CurrentJob.Progress.Text;
     281    if LabelText.Caption <> '' then begin
     282      PanelText.Visible := True;
     283      UpdateHeight;
     284    end;
     285  end;
     286end;
     287
     288procedure TFormJobProgressView.FormDestroy(Sender:TObject);
     289begin
     290end;
     291
     292procedure TFormJobProgressView.ListViewJobsData(Sender: TObject; Item: TListItem);
     293begin
     294  if (Item.Index >= 0) and (Item.Index < JobProgressView.Jobs.Count) then
     295  with TJob(JobProgressView.Jobs[Item.Index]) do begin
     296    Item.Caption := Title;
     297    if Item.Index = JobProgressView.CurrentJobIndex then Item.ImageIndex := 1
     298      else if Finished then Item.ImageIndex := 0
     299      else Item.ImageIndex := 2;
     300    Item.Data := JobProgressView.Jobs[Item.Index];
     301  end;
     302end;
     303
     304procedure TFormJobProgressView.FormClose(Sender: TObject;
     305  var CloseAction: TCloseAction);
     306begin
     307end;
     308
     309procedure TFormJobProgressView.FormCreate(Sender: TObject);
     310begin
     311  Caption := SPleaseWait;
     312  try
     313    //Animate1.FileName := ExtractFileDir(UTF8Encode(Application.ExeName)) +
     314    //  DirectorySeparator + 'horse.avi';
     315    //Animate1.Active := True;
     316  except
     317
     318  end;
     319end;
     320
     321procedure TFormJobProgressView.ReloadJobList;
     322begin
     323  // Workaround for not showing first line
     324  //Form.ListViewJobs.Items.Count := Jobs.Count + 1;
     325  //Form.ListViewJobs.Refresh;
     326
     327  if ListViewJobs.Items.Count <> JobProgressView.Jobs.Count then
     328    ListViewJobs.Items.Count := JobProgressView.Jobs.Count;
     329  ListViewJobs.Refresh;
     330  Application.ProcessMessages;
     331  UpdateHeight;
     332end;
     333
     334procedure TFormJobProgressView.FormShow(Sender: TObject);
     335begin
     336  ReloadJobList;
     337end;
     338
     339procedure TFormJobProgressView.FormHide(Sender: TObject);
     340begin
     341  JobProgressView.Jobs.Clear;
     342  ReloadJobList;
     343end;
     344
     345procedure TFormJobProgressView.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
     346begin
     347  CanClose := JobProgressView.Finished;
     348  JobProgressView.Terminate := True;
     349  Caption := SPleaseWait + STerminate;
     350end;
     351
     352
     353{ TJobProgressView }
     354
     355function TJobProgressView.AddJob(Title: string; Method: TJobProgressViewMethod;
     356  NoThreaded: Boolean = False; WaitFor: Boolean = False): TJob;
     357begin
     358  Result := TJob.Create;
     359  Result.ProgressView := Self;
     360  Result.Title := Title;
     361  Result.Method := Method;
     362  Result.NoThreaded := NoThreaded;
     363  Result.WaitFor := WaitFor;
     364  Result.Progress.Max := 100;
     365  Result.Progress.Reset;
     366  Result.Progress.OnChange := JobProgressChange;
     367  Jobs.Add(Result);
    207368  //ReloadJobList;
    208369end;
    209370
    210 procedure TJobProgressView.Start(AAutoClose: Boolean = True);
    211 begin
    212   AutoClose := AAutoClose;
    213   StartJobs;
    214 end;
    215 
    216 procedure TJobProgressView.StartJobs;
     371procedure TJobProgressView.Start;
    217372var
    218373  I: Integer;
    … …  
    229384    Form.MemoLog.Clear;
    230385
     386    Form.PanelText.Visible := False;
    231387    Form.LabelEstimatedTimePart.Visible := False;
    232388    Form.LabelEstimatedTimeTotal.Visible := False;
    … …  
    258414      Form.ProgressBarPart.Visible := False;
    259415      //Show;
    260       ReloadJobList;
     416      Form.ReloadJobList;
    261417      Application.ProcessMessages;
    262418      if NoThreaded then begin
    … …  
    296452    //if Visible then Hide;
    297453    Form.MemoLog.Lines.Assign(Log);
    298     if (Form.MemoLog.Lines.Count = 0) and AutoClose then begin
     454    if (Form.MemoLog.Lines.Count = 0) and FAutoClose then begin
    299455      Form.Hide;
    300456    end;
    301     Clear;
     457    if not Form.Visible then Clear;
    302458    Form.Caption := SFinished;
    303459    //LabelEstimatedTimePart.Visible := False;
    304460    Finished := True;
    305461    CurrentJobIndex := -1;
    306     ReloadJobList;
    307   end;
    308 end;
    309 
    310 procedure TJobProgressView.UpdateHeight;
    311 var
    312   H: Integer;
    313   PanelOperationsVisible: Boolean;
    314   PanelOperationsHeight: Integer;
    315   PanelProgressVisible: Boolean;
    316   PanelProgressTotalVisible: Boolean;
    317   PanelLogVisible: Boolean;
    318 begin
    319   with Form do begin
    320   H := PanelOperationsTitle.Height;
    321   PanelOperationsVisible := Jobs.Count > 0;
    322   if PanelOperationsVisible <> PanelOperations.Visible then
    323     PanelOperations.Visible := PanelOperationsVisible;
    324   PanelOperationsHeight := 8 + 18 * Jobs.Count;
    325   if PanelOperationsHeight <> PanelOperations.Height then
    326     PanelOperations.Height := PanelOperationsHeight;
    327   if PanelOperationsVisible then
    328     H := H + PanelOperations.Height;
    329 
    330   PanelProgressVisible := (Jobs.Count > 0) and not Finished;
    331   if PanelProgressVisible <> PanelProgress.Visible then
    332     PanelProgress.Visible := PanelProgressVisible;
    333   if PanelProgressVisible then
    334     H := H + PanelProgress.Height;
    335   PanelProgressTotalVisible := (Jobs.Count > 1) and not Finished;
    336   if PanelProgressTotalVisible <> PanelProgressTotal.Visible then
    337     PanelProgressTotal.Visible := PanelProgressTotalVisible;
    338   if PanelProgressTotalVisible then
    339     H := H + PanelProgressTotal.Height;
    340   Constraints.MinHeight := H;
    341   PanelLogVisible := MemoLog.Lines.Count > 0;
    342   if PanelLogVisible <> PanelLog.Visible then
    343     PanelLog.Visible := PanelLogVisible;
    344   if PanelLogVisible then
    345     H := H + MemoLogHeight;
    346   if Height <> H then Height := H;
     462    Form.ReloadJobList;
    347463  end;
    348464end;
    … …  
    352468  if Assigned(FOnOwnerDraw) then
    353469    FOnOwnerDraw(Self);
    354 end;
    355 
    356 procedure TFormJobProgressView.TimerUpdateTimer(Sender: TObject);
    357 var
    358   ProgressBarPartVisible: Boolean;
    359   ProgressBarTotalVisible: Boolean;
    360 begin
    361   JobProgressView.UpdateProgress;
    362   if Visible and (not ProgressBarPart.Visible) and
    363   Assigned(JobProgressView.CurrentJob) and
    364   (JobProgressView.CurrentJob.Progress.Value > 0) then begin
    365     ProgressBarPartVisible := True;
    366     if ProgressBarPartVisible <> ProgressBarPart.Visible then
    367       ProgressBarPart.Visible := ProgressBarPartVisible;
    368     ProgressBarTotalVisible := True;
    369     if ProgressBarTotalVisible <> ProgressBarTotal.Visible then
    370       ProgressBarTotal.Visible := ProgressBarTotalVisible;
    371   end;
    372   if not Visible then begin
    373     TimerUpdate.Interval := UpdateInterval;
    374     if not JobProgressView.OwnerDraw then Show;
    375   end;
    376 end;
    377 
    378 procedure TFormJobProgressView.FormDestroy(Sender:TObject);
    379 begin
    380 end;
    381 
    382 procedure TFormJobProgressView.ListViewJobsData(Sender: TObject; Item: TListItem);
    383 begin
    384   if (Item.Index >= 0) and (Item.Index < JobProgressView.Jobs.Count) then
    385   with TJob(JobProgressView.Jobs[Item.Index]) do begin
    386     Item.Caption := Title;
    387     if Item.Index = JobProgressView.CurrentJobIndex then Item.ImageIndex := 1
    388       else if Finished then Item.ImageIndex := 0
    389       else Item.ImageIndex := 2;
    390     Item.Data := JobProgressView.Jobs[Item.Index];
    391   end;
    392 end;
    393 
    394 procedure TFormJobProgressView.FormClose(Sender: TObject;
    395   var CloseAction: TCloseAction);
    396 begin
    397   ListViewJobs.Clear;
    398 end;
    399 
    400 procedure TFormJobProgressView.FormCreate(Sender: TObject);
    401 begin
    402   Caption := SPleaseWait;
    403   try
    404     //Animate1.FileName := ExtractFileDir(UTF8Encode(Application.ExeName)) +
    405     //  DirectorySeparator + 'horse.avi';
    406     //Animate1.Active := True;
    407   except
    408 
    409   end;
    410470end;
    411471
    … …  
    426486    Sleep(Quantum);
    427487  end;
    428 end;
    429 
    430 procedure TFormJobProgressView.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    431 begin
    432   CanClose := JobProgressView.Finished;
    433   JobProgressView.Terminate := True;
    434   Caption := SPleaseWait + STerminate;
    435488end;
    436489
    … …  
    490543end;
    491544
    492 procedure TJobProgressView.ReloadJobList;
    493 begin
    494   UpdateHeight;
    495   // Workaround for not showing first line
    496   Form.ListViewJobs.Items.Count := Jobs.Count + 1;
    497   Form.ListViewJobs.Refresh;
    498 
    499   if Form.ListViewJobs.Items.Count <> Jobs.Count then
    500     Form.ListViewJobs.Items.Count := Jobs.Count;
    501   Form.ListViewJobs.Refresh;
    502   //Application.ProcessMessages;
    503 end;
    504 
    505545constructor TJobProgressView.Create(TheOwner: TComponent);
    506546begin
    507547  inherited;
    508548  if not (csDesigning in ComponentState) then begin
    509     Form := TFormJobProgressView.Create(Self);
    510     Form.JobProgressView := Self;
    511   end;
    512   Jobs := TObjectList.Create;
     549    FForm := TFormJobProgressView.Create(Self);
     550    FForm.JobProgressView := Self;
     551  end;
     552  Jobs := TJobs.Create;
    513553  Log := TStringList.Create;
    514554  //PanelOperationsTitle.Height := 80;
    515   ShowDelay := 0; //1000; // ms
     555  AutoClose := True;
     556  ShowDelay := 0;
    516557end;
    517558
    … …  
    519560begin
    520561  Jobs.Clear;
     562  Log.Clear;
    521563  //ReloadJobList;
    522564end;
    … …  
    528570  inherited;
    529571end;
     572
     573{ TProgress }
    530574
    531575procedure TProgress.SetMax(const AValue: Integer);
    … …  
    536580    if FMax < 1 then FMax := 1;
    537581    if FValue >= FMax then FValue := FMax;
     582  finally
     583    FLock.Release;
     584  end;
     585end;
     586
     587procedure TProgress.SetText(AValue: string);
     588begin
     589  try
     590    FLock.Acquire;
     591    if FText = AValue then Exit;
     592    FText := AValue;
    538593  finally
    539594    FLock.Release;
    … …  
    563618end;
    564619
    565 { TProgress }
    566 
    567620procedure TProgress.Increment;
    568621begin

  • trunk/Packages/Common/ULastOpenedList.pas

    r1 r21  
    66
    77uses
    8   Classes, SysUtils, Registry, URegistry, Menus, XMLConf;
     8  Classes, SysUtils, Registry, URegistry, Menus, XMLConf, DOM;
    99
    1010type
    … …  
    3030    procedure SaveToXMLConfig(XMLConfig: TXMLConfig; Path: string);
    3131    procedure AddItem(FileName: string);
     32    function GetFirstFileName: string;
    3233  published
    3334    property MaxCount: Integer read FMaxCount write SetMaxCount;
    … …  
    139140    OpenKey(Context.Key, True);
    140141    for I := 0 to Items.Count - 1 do
    141       WriteString('File' + IntToStr(I), UTF8Decode(Items[I]));
     142      WriteString('File' + IntToStr(I), Items[I]);
    142143  finally
    143144    Free;
    … …  
    153154begin
    154155  with XMLConfig do begin
    155     Count := GetValue(Path + '/Count', 0);
     156    Count := GetValue(DOMString(Path + '/Count'), 0);
    156157    if Count > MaxCount then Count := MaxCount;
    157158    Items.Clear;
    158159    for I := 0 to Count - 1 do begin
    159       Value := GetValue(Path + '/File' + IntToStr(I), '');
     160      Value := string(GetValue(DOMString(Path + '/File' + IntToStr(I)), ''));
    160161      if Trim(Value) <> '' then Items.Add(Value);
    161162    end;
    … …  
    170171begin
    171172  with XMLConfig do begin
    172     SetValue(Path + '/Count', Items.Count);
     173    SetValue(DOMString(Path + '/Count'), Items.Count);
    173174    for I := 0 to Items.Count - 1 do
    174       SetValue(Path + '/File' + IntToStr(I), Items[I]);
     175      SetValue(DOMString(Path + '/File' + IntToStr(I)), DOMString(Items[I]));
    175176    Flush;
    176177  end;
    … …  
    185186end;
    186187
     188function TLastOpenedList.GetFirstFileName: string;
     189begin
     190  if Items.Count > 0 then Result := Items[0]
     191    else Result := '';
     192end;
     193
    187194end.
    188195

  • trunk/Packages/Common/UListViewSort.pas

    r15 r21  
    99uses
    1010  {$IFDEF Windows}Windows, CommCtrl, {$ENDIF}Classes, Graphics, ComCtrls, SysUtils,
    11   Controls, DateUtils, Dialogs, SpecializedList, Forms, Grids, StdCtrls, ExtCtrls,
     11  Controls, DateUtils, Dialogs, fgl, Forms, Grids, StdCtrls, ExtCtrls,
    1212  LclIntf, LMessages, LclType, LResources;
    1313
    … …  
    5252    {$ENDIF}
    5353  public
    54     List: TListObject;
    55     Source: TListObject;
     54    List: TFPGObjectList<TObject>;
     55    Source: TFPGObjectList<TObject>;
    5656    constructor Create(AOwner: TComponent); override;
    5757    destructor Destroy; override;
    … …  
    9898  end;
    9999
     100  { TListViewEx }
     101
     102  TListViewEx = class(TWinControl)
     103  private
     104    FFilter: TListViewFilter;
     105    FListView: TListView;
     106    FListViewSort: TListViewSort;
     107    procedure ResizeHanlder;
     108  public
     109    constructor Create(TheOwner: TComponent); override;
     110    destructor Destroy; override;
     111  published
     112    property ListView: TListView read FListView write FListView;
     113    property ListViewSort: TListViewSort read FListViewSort write FListViewSort;
     114    property Filter: TListViewFilter read FFilter write FFilter;
     115    property Visible;
     116  end;
     117
    100118procedure Register;
    101119
    … …  
    105123procedure Register;
    106124begin
    107   RegisterComponents('Common', [TListViewSort, TListViewFilter]);
     125  RegisterComponents('Common', [TListViewSort, TListViewFilter, TListViewEx]);
     126end;
     127
     128{ TListViewEx }
     129
     130procedure TListViewEx.ResizeHanlder;
     131begin
     132end;
     133
     134constructor TListViewEx.Create(TheOwner: TComponent);
     135begin
     136  inherited Create(TheOwner);
     137  Filter := TListViewFilter.Create(Self);
     138  Filter.Parent := Self;
     139  Filter.Align := alBottom;
     140  ListView := TListView.Create(Self);
     141  ListView.Parent := Self;
     142  ListView.Align := alClient;
     143  ListViewSort := TListViewSort.Create(Self);
     144  ListViewSort.ListView := ListView;
     145end;
     146
     147destructor TListViewEx.Destroy;
     148begin
     149  inherited Destroy;
    108150end;
    109151
    … …  
    142184var
    143185  I: Integer;
     186  R: TRect;
    144187begin
    145188  with FStringGrid1 do begin
    146     Options := Options - [goEditing, goAlwaysShowEditor];
    147     //Columns.Clear;
    148189    while Columns.Count > ListView.Columns.Count do Columns.Delete(Columns.Count - 1);
    149190    while Columns.Count < ListView.Columns.Count do Columns.Add;
    150191    for I := 0 to ListView.Columns.Count - 1 do begin
    151192      Columns[I].Width := ListView.Columns[I].Width;
     193      if Selection.Left = I then begin
     194        R := CellRect(I, 0);
     195        Editor.Left := R.Left + 2;
     196        Editor.Width := R.Width - 4;
     197      end;
    152198    end;
    153     Options := Options + [goEditing, goAlwaysShowEditor];
    154199  end;
    155200end;
    … …  
    274319end;
    275320
     321var
     322  ListViewSortCompare: TCompareEvent;
     323
     324function ListViewCompare(const Item1, Item2: TObject): Integer;
     325begin
     326  Result := ListViewSortCompare(Item1, Item2);
     327end;
     328
    276329procedure TListViewSort.Sort(Compare: TCompareEvent);
    277330begin
     331  // TODO: Because TFLGObjectList compare handler is not class method,
     332  // it is necessary to use simple function compare handler with local variable
     333  ListViewSortCompare := Compare;
    278334  if (List.Count > 0) then
    279     List.Sort(Compare);
     335    List.Sort(ListViewCompare);
    280336end;
    281337
    … …  
    340396begin
    341397  inherited;
    342   List := TListObject.Create;
    343   List.OwnsObjects := False;
     398  List := TFPGObjectList<TObject>.Create;
     399  List.FreeObjects := False;
    344400end;
    345401
    … …  
    381437  ItemLeft := Item.Left;
    382438  ItemLeft := 23; // Windows 7 workaround
    383  
     439
    384440  Rect1.Left := ItemLeft - CheckWidth - BiasLeft + 1 + XBias;
    385441  //ShowMessage(IntToStr(Tp1.Y) + ', ' + IntToStr(BiasTop) + ', ' + IntToStr(XBias));
    … …  
    480536    FHeaderHandle := ListView_GetHeader(FListView.Handle);
    481537    for I := 0 to FListView.Columns.Count - 1 do begin
     538      {$push}{$warn 5057 off}
    482539      FillChar(Item, SizeOf(THDItem), 0);
     540      {$pop}
    483541      Item.Mask := HDI_FORMAT;
    484542      Header_GetItem(FHeaderHandle, I, Item);

  • trunk/Packages/Common/UMemory.pas

    r1 r21  
    2424    constructor Create;
    2525    destructor Destroy; override;
     26    procedure WriteMemory(Position: Integer; Memory: TMemory);
     27    procedure ReadMemory(Position: Integer; Memory: TMemory);
    2628    property Data: PByte read FData;
    2729    property Size: Integer read FSize write SetSize;
    … …  
    108110end;
    109111
     112procedure TMemory.WriteMemory(Position: Integer; Memory: TMemory);
     113begin
     114  Move(Memory.FData, PByte(PByte(@FData) + Position)^, Memory.Size);
     115end;
     116
     117procedure TMemory.ReadMemory(Position: Integer; Memory: TMemory);
     118begin
     119  Move(PByte(PByte(@FData) + Position)^, Memory.FData, Memory.Size);
     120end;
     121
    110122end.
    111123

  • trunk/Packages/Common/UPersistentForm.pas

    r1 r21  
    88
    99uses
    10   Classes, SysUtils, Forms, URegistry, LCLIntf, Registry, Controls, ComCtrls;
     10  Classes, SysUtils, Forms, URegistry, LCLIntf, Registry, Controls, ComCtrls,
     11  ExtCtrls;
    1112
    1213type
    … …  
    5657  I: Integer;
    5758  WinControl: TWinControl;
    58   Count: Integer;
    5959begin
    6060  if Control is TListView then begin
    … …  
    7272  end;
    7373
     74  if (Control is TPanel) then begin
     75    with Form, TRegistryEx.Create do
     76    try
     77      RootKey := RegistryContext.RootKey;
     78      OpenKey(RegistryContext.Key + '\Forms\' + Form.Name + '\' + Control.Name, True);
     79      if (TPanel(Control).Align = alRight) or (TPanel(Control).Align = alLeft) then begin
     80        if ValueExists('Width') then
     81          TPanel(Control).Width := ReadInteger('Width');
     82      end;
     83      if (TPanel(Control).Align = alTop) or (TPanel(Control).Align = alBottom) then begin
     84        if ValueExists('Height') then
     85          TPanel(Control).Height := ReadInteger('Height');
     86      end;
     87    finally
     88      Free;
     89    end;
     90  end;
     91
    7492  if Control is TWinControl then begin
    7593    WinControl := TWinControl(Control);
    … …  
    96114      for I := 0 to TListView(Control).Columns.Count - 1 do begin
    97115        WriteInteger('ColWidth' + IntToStr(I), TListView(Control).Columns[I].Width);
     116      end;
     117    finally
     118      Free;
     119    end;
     120  end;
     121
     122  if (Control is TPanel) then begin
     123    with Form, TRegistryEx.Create do
     124    try
     125      RootKey := RegistryContext.RootKey;
     126      OpenKey(RegistryContext.Key + '\Forms\' + Form.Name + '\' + Control.Name, True);
     127      if (TPanel(Control).Align = alRight) or (TPanel(Control).Align = alLeft) then begin
     128        WriteInteger('Width', TPanel(Control).Width);
     129      end;
     130      if (TPanel(Control).Align = alTop) or (TPanel(Control).Align = alBottom) then begin
     131        WriteInteger('Height', TPanel(Control).Height);
    98132      end;
    99133    finally
    … …  
    217251
    218252procedure TPersistentForm.Load(Form: TForm; DefaultMaximized: Boolean = False);
    219 var
    220   LoadDefaults: Boolean;
    221253begin
    222254  Self.Form := Form;
    … …  
    230262
    231263  if not EqualRect(FormNormalSize, FormRestoredSize) or
    232     (LoadDefaults and DefaultMaximized) then begin
     264    DefaultMaximized then begin
    233265    // Restore to maximized state
    234266    Form.WindowState := wsNormal;

  • trunk/Packages/Common/UPool.pas

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

  • trunk/Packages/Common/UPrefixMultiplier.pas

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

  • trunk/Packages/Common/URegistry.pas

    r1 r21  
    2929    procedure SetCurrentContext(AValue: TRegistryContext);
    3030  public
     31    function ReadChar(const Name: string): Char;
     32    procedure WriteChar(const Name: string; Value: Char);
    3133    function ReadBoolWithDefault(const Name: string;
    3234      DefaultValue: Boolean): Boolean;
    3335    function ReadIntegerWithDefault(const Name: string; DefaultValue: Integer): Integer;
    3436    function ReadStringWithDefault(const Name: string; DefaultValue: string): string;
     37    function ReadCharWithDefault(const Name: string; DefaultValue: Char): Char;
    3538    function ReadFloatWithDefault(const Name: string;
    3639      DefaultValue: Double): Double;
    … …  
    8992end;
    9093
     94function TRegistryEx.ReadCharWithDefault(const Name: string; DefaultValue: Char
     95  ): Char;
     96begin
     97  if ValueExists(Name) then Result := ReadChar(Name)
     98    else begin
     99      WriteChar(Name, DefaultValue);
     100      Result := DefaultValue;
     101    end;
     102end;
     103
    91104function TRegistryEx.ReadFloatWithDefault(const Name: string;
    92105  DefaultValue: Double): Double;
    … …  
    137150end;
    138151
     152function TRegistryEx.ReadChar(const Name: string): Char;
     153var
     154  S: string;
     155begin
     156  S := ReadString(Name);
     157  if Length(S) > 0 then Result := S[1]
     158    else Result := #0;
     159end;
     160
     161procedure TRegistryEx.WriteChar(const Name: string; Value: Char);
     162begin
     163  WriteString(Name, Value);
     164end;
     165
    139166function TRegistryEx.ReadBoolWithDefault(const Name: string;
    140167  DefaultValue: Boolean): Boolean;

  • trunk/Packages/Common/UResetableThread.pas

    r1 r21  
    156156  FThread.Name := 'ResetableThread';
    157157  FThread.Parent := Self;
    158   FThread.Resume;
     158  FThread.Start;
    159159end;
    160160

  • trunk/Packages/Common/UScaleDPI.pas

    r1 r21  
    215215  I: Integer;
    216216begin
     217  ImgList.BeginUpdate;
    217218  NewWidth := ScaleX(ImgList.Width, FromDPI.X);
    218219  NewHeight := ScaleY(ImgList.Height, FromDPI.Y);
    … …  
    248249    Temp[i].Free;
    249250  end;
     251  ImgList.EndUpdate;
    250252end;
    251253
    … …  
    287289  //OldAutoSize: Boolean;
    288290begin
     291  //if not (Control is TCustomPage) then
     292  // Resize childs first
     293  if Control is TWinControl then begin
     294    WinControl := TWinControl(Control);
     295    if WinControl.ControlCount > 0 then begin
     296      for I := 0 to WinControl.ControlCount - 1 do begin
     297        if WinControl.Controls[I] is TControl then begin
     298          ScaleControl(WinControl.Controls[I], FromDPI);
     299        end;
     300      end;
     301    end;
     302  end;
     303
    289304  //if Control is TMemo then Exit;
    290305  //if Control is TForm then
    … …  
    338353  end;
    339354
    340   //if not (Control is TCustomPage) then
    341   if Control is TWinControl then begin
    342     WinControl := TWinControl(Control);
    343     if WinControl.ControlCount > 0 then begin
    344       for I := 0 to WinControl.ControlCount - 1 do begin
    345         if WinControl.Controls[I] is TControl then begin
    346           ScaleControl(WinControl.Controls[I], FromDPI);
    347         end;
    348       end;
    349     end;
    350   end;
    351355  //if Control is TForm then
    352356  //  Control.EnableAutoSizing;

  • trunk/Packages/Common/UTheme.pas

    r15 r21  
    132132  I: Integer;
    133133begin
    134   for I := 0 to Component.ComponentCount - 1 do
    135     ApplyTheme(Component.Components[I]);
     134  if Component is TWinControl then begin
     135    for I := 0 to TWinControl(Component).ControlCount - 1 do
     136      ApplyTheme(TWinControl(Component).Controls[I]);
     137  end;
    136138
    137139  if Component is TControl then begin
    … …  
    139141    if (Control is TEdit) or (Control is TSpinEdit) or (Control is TComboBox) and
    140142    (Control is TMemo) or (Control is TListView) or (Control is TCustomDrawGrid) or
    141     (Control is TCheckBox) then begin
     143    (Control is TCheckBox) or (Control is TPageControl) or (Control is TRadioButton) then begin
    142144      Control.Color := FTheme.ColorWindow;
    143145      Control.Font.Color := FTheme.ColorWindowText;
    … …  
    150152      (Control as TCustomDrawGrid).Editor.Color := FTheme.ColorWindow;
    151153      (Control as TCustomDrawGrid).Editor.Font.Color := FTheme.ColorWindowText;
     154    end;
     155
     156    if Control is TPageControl then begin
     157      for I := 0 to TPageControl(Component).PageCount - 1 do
     158        ApplyTheme(TPageControl(Component).Pages[I]);
     159    end;
     160
     161    if Control is TCoolBar then begin
     162      (Control as TCoolBar).Themed := False;
    152163    end;
    153164  end;

  • trunk/Packages/Common/UThreading.pas

    r1 r21  
    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

    r1 r21  
    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, ':');

  • trunk/Packages/Common/UXMLUtils.pas

    r1 r21  
    77uses
    88  {$IFDEF WINDOWS}Windows,{$ENDIF}
    9   Classes, SysUtils, DateUtils, XMLRead, XMLWrite, DOM;
     9  Classes, SysUtils, DateUtils, DOM, xmlread;
    1010
    1111function XMLTimeToDateTime(XMLDateTime: string): TDateTime;
    12 function DateTimeToXMLTime(Value: TDateTime; ApplyLocalBias: Boolean = True): WideString;
     12function DateTimeToXMLTime(Value: TDateTime; ApplyLocalBias: Boolean = True): string;
    1313procedure WriteInteger(Node: TDOMNode; Name: string; Value: Integer);
    1414procedure WriteInt64(Node: TDOMNode; Name: string; Value: Int64);
    … …  
    2121function ReadString(Node: TDOMNode; Name: string; DefaultValue: string): string;
    2222function ReadDateTime(Node: TDOMNode; Name: string; DefaultValue: TDateTime): TDateTime;
     23procedure ReadXMLFileParser(out Doc: TXMLDocument; FileName: string);
    2324
    2425
    2526implementation
     27
     28procedure ReadXMLFileParser(out Doc: TXMLDocument; FileName: string);
     29var
     30  Parser: TDOMParser;
     31  Src: TXMLInputSource;
     32  InFile: TFileStream;
     33begin
     34  try
     35    InFile := TFileStream.Create(FileName, fmOpenRead);
     36    Src := TXMLInputSource.Create(InFile);
     37    Parser := TDOMParser.Create;
     38    Parser.Options.PreserveWhitespace := True;
     39    Parser.Parse(Src, Doc);
     40  finally
     41    Src.Free;
     42    Parser.Free;
     43    InFile.Free;
     44  end;
     45end;
    2646
    2747function GetTimeZoneBias: Integer;
    … …  
    3050  TimeZoneInfo: TTimeZoneInformation;
    3151begin
     52  {$push}{$warn 5057 off}
    3253  case GetTimeZoneInformation(TimeZoneInfo) of
    33   TIME_ZONE_ID_STANDARD: Result := TimeZoneInfo.Bias + TimeZoneInfo.StandardBias;
    34   TIME_ZONE_ID_DAYLIGHT: Result := TimeZoneInfo.Bias + TimeZoneInfo.DaylightBias;
     54    TIME_ZONE_ID_STANDARD: Result := TimeZoneInfo.Bias + TimeZoneInfo.StandardBias;
     55    TIME_ZONE_ID_DAYLIGHT: Result := TimeZoneInfo.Bias + TimeZoneInfo.DaylightBias;
    3556  else
    3657    Result := 0;
    3758  end;
     59  {$pop}
    3860end;
    3961{$ELSE}
    … …  
    4567function LeftCutString(var Source: string; out Output: string; Delimiter: string; Allowed: string = ''): Boolean;
    4668var
    47   I, J: Integer;
     69  I: Integer;
    4870  Matched: Boolean;
    4971begin
    … …  
    99121      if Pos('Z', XMLDateTime) > 0 then
    100122        LeftCutString(XMLDateTime, Part, 'Z');
    101       SecondFraction := StrToFloat('0' + DecimalSeparator + Part);
     123      SecondFraction := StrToFloat('0' + DefaultFormatSettings.DecimalSeparator + Part);
    102124      Millisecond := Trunc(SecondFraction * 1000);
    103125    end else begin
    … …  
    118140end;
    119141
    120 function DateTimeToXMLTime(Value: TDateTime; ApplyLocalBias: Boolean = True): WideString;
     142function DateTimeToXMLTime(Value: TDateTime; ApplyLocalBias: Boolean = True): string;
    121143const
    122144  Neg: array[Boolean] of string =  ('+', '-');
    … …  
    139161  NewNode: TDOMNode;
    140162begin
    141   NewNode := Node.OwnerDocument.CreateElement(Name);
    142   NewNode.TextContent := IntToStr(Value);
     163  NewNode := Node.OwnerDocument.CreateElement(DOMString(Name));
     164  NewNode.TextContent := DOMString(IntToStr(Value));
    143165  Node.AppendChild(NewNode);
    144166end;
    … …  
    148170  NewNode: TDOMNode;
    149171begin
    150   NewNode := Node.OwnerDocument.CreateElement(Name);
    151   NewNode.TextContent := IntToStr(Value);
     172  NewNode := Node.OwnerDocument.CreateElement(DOMString(Name));
     173  NewNode.TextContent := DOMString(IntToStr(Value));
    152174  Node.AppendChild(NewNode);
    153175end;
    … …  
    157179  NewNode: TDOMNode;
    158180begin
    159   NewNode := Node.OwnerDocument.CreateElement(Name);
    160   NewNode.TextContent := BoolToStr(Value);
     181  NewNode := Node.OwnerDocument.CreateElement(DOMString(Name));
     182  NewNode.TextContent := DOMString(BoolToStr(Value));
    161183  Node.AppendChild(NewNode);
    162184end;
    … …  
    166188  NewNode: TDOMNode;
    167189begin
    168   NewNode := Node.OwnerDocument.CreateElement(Name);
    169   NewNode.TextContent := Value;
     190  NewNode := Node.OwnerDocument.CreateElement(DOMString(Name));
     191  NewNode.TextContent := DOMString(Value);
    170192  Node.AppendChild(NewNode);
    171193end;
    … …  
    175197  NewNode: TDOMNode;
    176198begin
    177   NewNode := Node.OwnerDocument.CreateElement(Name);
    178   NewNode.TextContent := DateTimeToXMLTime(Value);
     199  NewNode := Node.OwnerDocument.CreateElement(DOMString(Name));
     200  NewNode.TextContent := DOMString(DateTimeToXMLTime(Value));
    179201  Node.AppendChild(NewNode);
    180202end;
    … …  
    185207begin
    186208  Result := DefaultValue;
    187   NewNode := Node.FindNode(Name);
    188   if Assigned(NewNode) then
    189     Result := StrToInt(NewNode.TextContent);
     209  NewNode := Node.FindNode(DOMString(Name));
     210  if Assigned(NewNode) then
     211    Result := StrToInt(string(NewNode.TextContent));
    190212end;
    191213
    … …  
    195217begin
    196218  Result := DefaultValue;
    197   NewNode := Node.FindNode(Name);
    198   if Assigned(NewNode) then
    199     Result := StrToInt64(NewNode.TextContent);
     219  NewNode := Node.FindNode(DOMString(Name));
     220  if Assigned(NewNode) then
     221    Result := StrToInt64(string(NewNode.TextContent));
    200222end;
    201223
    … …  
    205227begin
    206228  Result := DefaultValue;
    207   NewNode := Node.FindNode(Name);
    208   if Assigned(NewNode) then
    209     Result := StrToBool(NewNode.TextContent);
     229  NewNode := Node.FindNode(DOMString(Name));
     230  if Assigned(NewNode) then
     231    Result := StrToBool(string(NewNode.TextContent));
    210232end;
    211233
    … …  
    215237begin
    216238  Result := DefaultValue;
    217   NewNode := Node.FindNode(Name);
    218   if Assigned(NewNode) then
    219     Result := NewNode.TextContent;
     239  NewNode := Node.FindNode(DOMString(Name));
     240  if Assigned(NewNode) then
     241    Result := string(NewNode.TextContent);
    220242end;
    221243
    … …  
    226248begin
    227249  Result := DefaultValue;
    228   NewNode := Node.FindNode(Name);
    229   if Assigned(NewNode) then
    230     Result := XMLTimeToDateTime(NewNode.TextContent);
     250  NewNode := Node.FindNode(DOMString(Name));
     251  if Assigned(NewNode) then
     252    Result := XMLTimeToDateTime(string(NewNode.TextContent));
    231253end;
    232254
Note: See TracChangeset for help on using the changeset viewer.