Changeset 131
- Timestamp:
- Mar 18, 2022, 1:37:03 PM (3 years ago)
- Location:
- trunk/Packages/Common
- Files:
-
- 20 added
- 20 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/Packages/Common/Common.lpk
r122 r131 1 1 <?xml version="1.0" encoding="UTF-8"?> 2 2 <CONFIG> 3 <Package Version=" 4">3 <Package Version="5"> 4 4 <PathDelim Value="\"/> 5 5 <Name Value="Common"/> … … 33 33 <Other> 34 34 <CompilerMessages> 35 <IgnoredMessages idx 5024="True"/>35 <IgnoredMessages idx6058="True" idx5024="True" idx3124="True" idx3123="True"/> 36 36 </CompilerMessages> 37 37 </Other> 38 38 </CompilerOptions> 39 <Description Value="Various libraries"/> 40 <License Value="GNU/GPL"/> 41 <Version Minor="7"/> 42 <Files Count="22"> 39 <Description Value="Common package with various useful units. 40 41 Source: https://svn.zdechov.net/PascalClassLibrary/Common/"/> 42 <License Value="Copy left."/> 43 <Version Minor="9"/> 44 <Files Count="29"> 43 45 <Item1> 44 46 <Filename Value="StopWatch.pas"/> … … 60 62 <Item5> 61 63 <Filename Value="UPrefixMultiplier.pas"/> 64 <HasRegisterProc Value="True"/> 62 65 <UnitName Value="UPrefixMultiplier"/> 63 66 </Item5> … … 138 141 <UnitName Value="UStringTable"/> 139 142 </Item22> 143 <Item23> 144 <Filename Value="UMetaCanvas.pas"/> 145 <UnitName Value="UMetaCanvas"/> 146 </Item23> 147 <Item24> 148 <Filename Value="UGeometric.pas"/> 149 <UnitName Value="UGeometric"/> 150 </Item24> 151 <Item25> 152 <Filename Value="UTranslator.pas"/> 153 <HasRegisterProc Value="True"/> 154 <UnitName Value="UTranslator"/> 155 </Item25> 156 <Item26> 157 <Filename Value="ULanguages.pas"/> 158 <UnitName Value="ULanguages"/> 159 </Item26> 160 <Item27> 161 <Filename Value="UFormAbout.pas"/> 162 <UnitName Value="UFormAbout"/> 163 </Item27> 164 <Item28> 165 <Filename Value="UAboutDialog.pas"/> 166 <HasRegisterProc Value="True"/> 167 <UnitName Value="UAboutDialog"/> 168 </Item28> 169 <Item29> 170 <Filename Value="UPixelPointer.pas"/> 171 <UnitName Value="UPixelPointer"/> 172 </Item29> 140 173 </Files> 174 <CompatibilityMode Value="True"/> 141 175 <i18n> 142 176 <EnableI18N Value="True"/> … … 144 178 <EnableI18NForLFM Value="True"/> 145 179 </i18n> 146 <RequiredPkgs Count=" 3">180 <RequiredPkgs Count="2"> 147 181 <Item1> 148 182 <PackageName Value="LCL"/> 149 183 </Item1> 150 184 <Item2> 151 <PackageName Value="TemplateGenerics"/>152 </Item2>153 <Item3>154 185 <PackageName Value="FCL"/> 155 186 <MinVersion Major="1" Valid="True"/> 156 </Item 3>187 </Item2> 157 188 </RequiredPkgs> 158 189 <UsageOptions> -
trunk/Packages/Common/Common.pas
r122 r131 12 12 UMemory, UResetableThread, UPool, ULastOpenedList, URegistry, 13 13 UJobProgressView, UXMLUtils, UApplicationInfo, USyncCounter, UListViewSort, 14 UPersistentForm, UFindFile, UScaleDPI, UTheme, UStringTable, 15 LazarusPackageIntf; 14 UPersistentForm, UFindFile, UScaleDPI, UTheme, UStringTable, UMetaCanvas, 15 UGeometric, UTranslator, ULanguages, UFormAbout, UAboutDialog, 16 UPixelPointer, LazarusPackageIntf; 16 17 17 18 implementation … … 20 21 begin 21 22 RegisterUnit('UDebugLog', @UDebugLog.Register); 23 RegisterUnit('UPrefixMultiplier', @UPrefixMultiplier.Register); 22 24 RegisterUnit('ULastOpenedList', @ULastOpenedList.Register); 23 25 RegisterUnit('UJobProgressView', @UJobProgressView.Register); … … 28 30 RegisterUnit('UScaleDPI', @UScaleDPI.Register); 29 31 RegisterUnit('UTheme', @UTheme.Register); 32 RegisterUnit('UTranslator', @UTranslator.Register); 33 RegisterUnit('UAboutDialog', @UAboutDialog.Register); 30 34 end; 31 35 -
trunk/Packages/Common/Languages/UJobProgressView.pot
r130 r131 15 15 msgstr "" 16 16 17 #: ujobprogressview.soperations18 msgid "Operations:"19 msgstr ""20 21 17 #: ujobprogressview.spleasewait 22 18 msgid "Please wait..." -
trunk/Packages/Common/UApplicationInfo.pas
r122 r131 6 6 7 7 uses 8 SysUtils, Classes, Forms, URegistry, Controls ;8 SysUtils, Classes, Forms, URegistry, Controls, Graphics, LCLType; 9 9 10 10 type … … 14 14 TApplicationInfo = class(TComponent) 15 15 private 16 FDescription: TCaption; 16 FDescription: TTranslateString; 17 FIcon: TBitmap; 17 18 FIdentification: Byte; 18 19 FLicense: string; … … 33 34 public 34 35 constructor Create(AOwner: TComponent); override; 36 destructor Destroy; override; 35 37 property Version: string read GetVersion; 36 38 function GetRegistryContext: TRegistryContext; … … 47 49 property EmailContact: string read FEmailContact write FEmailContact; 48 50 property AppName: string read FAppName write FAppName; 49 property Description: string read FDescription write FDescription;51 property Description: TTranslateString read FDescription write FDescription; 50 52 property ReleaseDate: TDateTime read FReleaseDate write FReleaseDate; 51 53 property RegistryKey: string read FRegistryKey write FRegistryKey; 52 54 property RegistryRoot: TRegistryRoot read FRegistryRoot write FRegistryRoot; 53 55 property License: string read FLicense write FLicense; 56 property Icon: TBitmap read FIcon write FIcon; 54 57 end; 55 58 … … 74 77 constructor TApplicationInfo.Create(AOwner: TComponent); 75 78 begin 76 inherited Create(AOwner);79 inherited; 77 80 FVersionMajor := 1; 78 81 FIdentification := 1; … … 80 83 FRegistryKey := '\Software\' + FAppName; 81 84 FRegistryRoot := rrKeyCurrentUser; 85 FIcon := TBitmap.Create; 86 end; 87 88 destructor TApplicationInfo.Destroy; 89 begin 90 FreeAndNil(FIcon); 91 inherited; 82 92 end; 83 93 -
trunk/Packages/Common/UCommon.pas
r122 r131 6 6 7 7 uses 8 {$ ifdef Windows}Windows,{$endif}9 {$ ifdef Linux}baseunix,{$endif}10 Classes, SysUtils, StrUtils, Dialogs, Process, LCLIntf, 8 {$IFDEF WINDOWS}Windows,{$ENDIF} 9 {$IFDEF UNIX}baseunix,{$ENDIF} 10 Classes, SysUtils, StrUtils, Dialogs, Process, LCLIntf, Graphics, 11 11 FileUtil; //, ShFolder, ShellAPI; 12 12 13 13 type 14 14 TArrayOfByte = array of Byte; 15 TArrayOfString = array of string;16 15 TExceptionEvent = procedure(Sender: TObject; E: Exception) of object; 17 16 … … 28 27 unfDNSDomainName = 11); 29 28 30 TFilterMethodMethod = function (FileName: string): Boolean of object; 29 TFilterMethod = function (FileName: string): Boolean of object; 30 TFileNameMethod = procedure (FileName: string) of object; 31 31 32 var 32 33 ExceptionHandler: TExceptionEvent; 33 34 DLLHandle1: HModule; 34 35 35 {$IFDEF Windows} 36 const 37 clLightBlue = TColor($FF8080); 38 clLightGreen = TColor($80FF80); 39 clLightRed = TColor($8080FF); 40 41 {$IFDEF WINDOWS} 36 42 GetUserNameEx: procedure (NameFormat: DWORD; 37 43 lpNameBuffer: LPSTR; nSize: PULONG); stdcall; 38 44 {$ENDIF} 39 45 40 function IntToBin(Data: Int64; Count: Byte): string;46 function AddLeadingZeroes(const aNumber, Length : integer) : string; 41 47 function BinToInt(BinStr: string): Int64; 42 function TryHexToInt(Data: string; var Value: Integer): Boolean;43 function TryBinToInt(Data: string; var Value: Integer): Boolean;44 48 function BinToHexString(Source: AnsiString): string; 45 49 //function DelTree(DirName : string): Boolean; … … 47 51 function BCDToInt(Value: Byte): Byte; 48 52 function CompareByteArray(Data1, Data2: TArrayOfByte): Boolean; 53 procedure CopyStringArray(Dest: TStringArray; Source: array of string); 54 function CombinePaths(Path1, Path2: string): string; 55 function ComputerName: string; 56 procedure DeleteFiles(APath, AFileSpec: string); 57 function Explode(Separator: Char; Data: string): TStringArray; 58 procedure ExecuteProgram(Executable: string; Parameters: array of string); 59 procedure FileDialogUpdateFilterFileType(FileDialog: TOpenDialog); 60 procedure FreeThenNil(var Obj); 61 function GetDirCount(Dir: string): Integer; 49 62 function GetUserName: string; 50 function LoggedOnUserNameEx(Format: TUserNameFormat): string;51 function SplitString(var Text: string; Count: Word): string;52 63 function GetBitCount(Variable: QWord; MaxIndex: Integer): Integer; 53 64 function GetBit(Variable: QWord; Index: Byte): Boolean; 65 function GetStringPart(var Text: string; Separator: string): string; 66 function GenerateNewName(OldName: string): string; 67 function GetFileFilterItemExt(Filter: string; Index: Integer): string; 68 function IntToBin(Data: Int64; Count: Byte): string; 69 function LastPos(const SubStr: String; const S: String): Integer; 70 function LoadFileToStr(const FileName: TFileName): AnsiString; 71 function LoggedOnUserNameEx(Format: TUserNameFormat): string; 72 function MergeArray(A, B: array of string): TStringArray; 73 function OccurenceOfChar(What: Char; Where: string): Integer; 74 procedure OpenWebPage(URL: string); 75 procedure OpenEmail(Email: string); 76 procedure OpenFileInShell(FileName: string); 77 function PosFromIndex(SubStr: string; Text: string; 78 StartIndex: Integer): Integer; 79 function PosFromIndexReverse(SubStr: string; Text: string; 80 StartIndex: Integer): Integer; 81 function RemoveQuotes(Text: string): string; 82 procedure SaveStringToFile(S, FileName: string); 54 83 procedure SetBit(var Variable: Int64; Index: Byte; State: Boolean); overload; 55 84 procedure SetBit(var Variable: QWord; Index: Byte; State: Boolean); overload; 56 85 procedure SetBit(var Variable: Cardinal; Index: Byte; State: Boolean); overload; 57 86 procedure SetBit(var Variable: Word; Index: Byte; State: Boolean); overload; 58 function AddLeadingZeroes(const aNumber, Length : integer) : string;59 function LastPos(const SubStr: String; const S: String): Integer;60 function GenerateNewName(OldName: string): string;61 function GetFileFilterItemExt(Filter: string; Index: Integer): string;62 procedure FileDialogUpdateFilterFileType(FileDialog: TOpenDialog);63 procedure DeleteFiles(APath, AFileSpec: string);64 procedure OpenWebPage(URL: string);65 procedure OpenFileInShell(FileName: string);66 procedure ExecuteProgram(Executable: string; Parameters: array of string);67 procedure FreeThenNil(var Obj);68 function RemoveQuotes(Text: string): string;69 function ComputerName: string;70 function OccurenceOfChar(What: Char; Where: string): Integer;71 function GetDirCount(Dir: string): Integer;72 function MergeArray(A, B: array of string): TArrayOfString;73 function LoadFileToStr(const FileName: TFileName): AnsiString;74 87 procedure SearchFiles(AList: TStrings; Dir: string; 75 FilterMethod: TFilterMethodMethod = nil); 76 function GetStringPart(var Text: string; Separator: string): string; 88 FilterMethod: TFilterMethod = nil; FileNameMethod: TFileNameMethod = nil); 89 function SplitString(var Text: string; Count: Word): string; 90 function StripTags(const S: string): string; 91 function TryHexToInt(Data: string; out Value: Integer): Boolean; 92 function TryBinToInt(Data: string; out Value: Integer): Boolean; 93 procedure SortStrings(Strings: TStrings); 77 94 78 95 … … 102 119 I: Integer; 103 120 begin 121 Result := ''; 104 122 for I := 1 to Length(Source) do begin 105 123 Result := Result + LowerCase(IntToHex(Ord(Source[I]), 2)); … … 234 252 end; 235 253 236 function TryHexToInt(Data: string; varValue: Integer): Boolean;254 function TryHexToInt(Data: string; out Value: Integer): Boolean; 237 255 var 238 256 I: Integer; … … 250 268 end; 251 269 252 function TryBinToInt(Data: string; varValue: Integer): Boolean;270 function TryBinToInt(Data: string; out Value: Integer): Boolean; 253 271 var 254 272 I: Integer; … … 278 296 end; 279 297 280 function Explode(Separator: char; Data: string): TArrayOfString; 281 begin 282 SetLength(Result, 0); 283 while Pos(Separator, Data) > 0 do begin 298 function Explode(Separator: Char; Data: string): TStringArray; 299 var 300 Index: Integer; 301 begin 302 Result := Default(TStringArray); 303 repeat 304 Index := Pos(Separator, Data); 305 if Index > 0 then begin 306 SetLength(Result, Length(Result) + 1); 307 Result[High(Result)] := Copy(Data, 1, Index - 1); 308 Delete(Data, 1, Index); 309 end else Break; 310 until False; 311 if Data <> '' then begin 284 312 SetLength(Result, Length(Result) + 1); 285 Result[High(Result)] := Copy(Data, 1, Pos(Separator, Data) - 1); 286 Delete(Data, 1, Pos(Separator, Data)); 287 end; 288 SetLength(Result, Length(Result) + 1); 289 Result[High(Result)] := Data; 290 end; 291 292 {$IFDEF Windows} 313 Result[High(Result)] := Data; 314 end; 315 end; 316 317 {$IFDEF WINDOWS} 293 318 function GetUserName: string; 294 319 const … … 298 323 begin 299 324 L := MAX_USERNAME_LENGTH + 2; 325 Result := Default(string); 300 326 SetLength(Result, L); 301 327 if Windows.GetUserName(PChar(Result), L) and (L > 0) then begin … … 311 337 end; 312 338 end; 313 {$ endif}339 {$ENDIF} 314 340 315 341 function ComputerName: string; 316 {$ ifdef mswindows}342 {$IFDEF WINDOWS} 317 343 const 318 344 INFO_BUFFER_SIZE = 32767; … … 329 355 end; 330 356 end; 331 {$ endif}332 {$ ifdef unix}357 {$ENDIF} 358 {$IFDEF UNIX} 333 359 var 334 360 Name: UtsName; 335 361 begin 362 Name := Default(UtsName); 336 363 fpuname(Name); 337 364 Result := Name.Nodename; 338 365 end; 339 {$ endif}340 341 {$ ifdef windows}366 {$ENDIF} 367 368 {$IFDEF WINDOWS} 342 369 function LoggedOnUserNameEx(Format: TUserNameFormat): string; 343 370 const … … 417 444 procedure LoadLibraries; 418 445 begin 419 {$IFDEF W indows}446 {$IFDEF WINDOWS} 420 447 DLLHandle1 := LoadLibrary('secur32.dll'); 421 448 if DLLHandle1 <> 0 then … … 428 455 procedure FreeLibraries; 429 456 begin 430 {$IFDEF W indows}457 {$IFDEF WINDOWS} 431 458 if DLLHandle1 <> 0 then FreeLibrary(DLLHandle1); 432 459 {$ENDIF} … … 461 488 end; 462 489 490 procedure OpenEmail(Email: string); 491 begin 492 OpenURL('mailto:' + Email); 493 end; 494 463 495 procedure OpenFileInShell(FileName: string); 464 496 begin … … 489 521 end; 490 522 491 function MergeArray(A, B: array of string): TArrayOfString; 492 var 493 I: Integer; 494 begin 523 function MergeArray(A, B: array of string): TStringArray; 524 var 525 I: Integer; 526 begin 527 Result := Default(TStringArray); 495 528 SetLength(Result, Length(A) + Length(B)); 496 529 for I := 0 to Length(A) - 1 do … … 523 556 end; 524 557 558 procedure SaveStringToFile(S, FileName: string); 559 var 560 F: TextFile; 561 begin 562 AssignFile(F, FileName); 563 try 564 ReWrite(F); 565 Write(F, S); 566 finally 567 CloseFile(F); 568 end; 569 end; 570 525 571 procedure SearchFiles(AList: TStrings; Dir: string; 526 FilterMethod: TFilterMethod Method = nil);572 FilterMethod: TFilterMethod = nil; FileNameMethod: TFileNameMethod = nil); 527 573 var 528 574 SR: TSearchRec; … … 534 580 if (SR.Name = '.') or (SR.Name = '..') or (Assigned(FilterMethod) and (not FilterMethod(SR.Name) or 535 581 not FilterMethod(Copy(Dir, 3, Length(Dir)) + SR.Name))) then Continue; 582 if Assigned(FileNameMethod) then 583 FileNameMethod(Dir + SR.Name); 536 584 AList.Add(Dir + SR.Name); 537 585 if (SR.Attr and faDirectory) <> 0 then … … 559 607 end; 560 608 609 function StripTags(const S: string): string; 610 var 611 Len: Integer; 612 613 function ReadUntil(const ReadFrom: Integer; const C: Char): Integer; 614 var 615 J: Integer; 616 begin 617 for J := ReadFrom to Len do 618 if (S[j] = C) then 619 begin 620 Result := J; 621 Exit; 622 end; 623 Result := Len + 1; 624 end; 625 626 var 627 I, APos: Integer; 628 begin 629 Len := Length(S); 630 I := 0; 631 Result := ''; 632 while (I <= Len) do begin 633 Inc(I); 634 APos := ReadUntil(I, '<'); 635 Result := Result + Copy(S, I, APos - i); 636 I := ReadUntil(APos + 1, '>'); 637 end; 638 end; 639 640 function PosFromIndex(SubStr: string; Text: string; 641 StartIndex: Integer): Integer; 642 var 643 I, MaxLen: SizeInt; 644 Ptr: PAnsiChar; 645 begin 646 Result := 0; 647 if (StartIndex < 1) or (StartIndex > Length(Text) - Length(SubStr)) then Exit; 648 if Length(SubStr) > 0 then begin 649 MaxLen := Length(Text) - Length(SubStr) + 1; 650 I := StartIndex; 651 Ptr := @Text[StartIndex]; 652 while (I <= MaxLen) do begin 653 if (SubStr[1] = Ptr^) and (CompareByte(Substr[1], Ptr^, Length(SubStr)) = 0) then begin 654 Result := I; 655 Exit; 656 end; 657 Inc(I); 658 Inc(Ptr); 659 end; 660 end; 661 end; 662 663 function PosFromIndexReverse(SubStr: string; Text: string; 664 StartIndex: Integer): Integer; 665 var 666 I: SizeInt; 667 Ptr: PAnsiChar; 668 begin 669 Result := 0; 670 if (StartIndex < 1) or (StartIndex > Length(Text)) then Exit; 671 if Length(SubStr) > 0 then begin 672 I := StartIndex; 673 Ptr := @Text[StartIndex]; 674 while (I > 0) do begin 675 if (SubStr[1] = Ptr^) and (CompareByte(Substr[1], Ptr^, Length(SubStr)) = 0) then begin 676 Result := I; 677 Exit; 678 end; 679 Dec(I); 680 Dec(Ptr); 681 end; 682 end; 683 end; 684 685 procedure CopyStringArray(Dest: TStringArray; Source: array of string); 686 var 687 I: Integer; 688 begin 689 SetLength(Dest, Length(Source)); 690 for I := 0 to Length(Dest) - 1 do 691 Dest[I] := Source[I]; 692 end; 693 694 function CombinePaths(Path1, Path2: string): string; 695 begin 696 Result := Path1; 697 if Result <> '' then Result := Result + DirectorySeparator + Path2 698 else Result := Path2; 699 end; 700 701 procedure SortStrings(Strings: TStrings); 702 var 703 Tmp: TStringList; 704 begin 705 Strings.BeginUpdate; 706 try 707 if Strings is TStringList then begin 708 TStringList(Strings).Sort; 709 end else begin 710 Tmp := TStringList.Create; 711 try 712 Tmp.Assign(Strings); 713 Tmp.Sort; 714 Strings.Assign(Tmp); 715 finally 716 Tmp.Free; 717 end; 718 end; 719 finally 720 Strings.EndUpdate; 721 end; 722 end; 561 723 562 724 -
trunk/Packages/Common/UDebugLog.pas
r122 r131 6 6 7 7 uses 8 Classes, SysUtils, FileUtil, SpecializedList, SyncObjs;8 Classes, SysUtils, FileUtil, fgl, SyncObjs; 9 9 10 10 type … … 29 29 procedure SetMaxCount(const AValue: Integer); 30 30 public 31 Items: T ListObject;31 Items: TFPGObjectList<TDebugLogItem>; 32 32 Lock: TCriticalSection; 33 33 procedure Add(Text: string; Group: string = ''); … … 117 117 begin 118 118 inherited; 119 Items := T ListObject.Create;119 Items := TFPGObjectList<TDebugLogItem>.Create; 120 120 Lock := TCriticalSection.Create; 121 121 MaxCount := 100; -
trunk/Packages/Common/UFindFile.pas
r122 r131 59 59 FilterAll = '*.*'; 60 60 {$ENDIF} 61 {$IFDEF LINUX}61 {$IFDEF UNIX} 62 62 FilterAll = '*'; 63 63 {$ENDIF} -
trunk/Packages/Common/UJobProgressView.lfm
r122 r131 1 1 object FormJobProgressView: TFormJobProgressView 2 2 Left = 467 3 Height = 3453 Height = 414 4 4 Top = 252 5 Width = 5395 Width = 647 6 6 BorderIcons = [biSystemMenu] 7 ClientHeight = 3458 ClientWidth = 5399 DesignTimePPI = 1 207 ClientHeight = 414 8 ClientWidth = 647 9 DesignTimePPI = 144 10 10 OnClose = FormClose 11 11 OnCloseQuery = FormCloseQuery 12 12 OnCreate = FormCreate 13 OnDestroy = FormDestroy14 13 OnHide = FormHide 15 14 OnShow = FormShow 16 15 Position = poScreenCenter 17 LCLVersion = ' 1.8.2.0'16 LCLVersion = '2.2.0.4' 18 17 object PanelOperationsTitle: TPanel 19 18 Left = 0 20 Height = 3 219 Height = 38 21 20 Top = 0 22 Width = 53921 Width = 647 23 22 Align = alTop 24 23 BevelOuter = bvNone 25 ClientHeight = 3 226 ClientWidth = 53924 ClientHeight = 38 25 ClientWidth = 647 27 26 FullRepaint = False 28 27 TabOrder = 0 29 28 object LabelOperation: TLabel 30 Left = 831 Height = 2 032 Top = 833 Width = 7629 Left = 10 30 Height = 26 31 Top = 10 32 Width = 99 34 33 Caption = 'Operations:' 35 ParentColor = False36 34 ParentFont = False 37 35 end … … 39 37 object PanelLog: TPanel 40 38 Left = 0 41 Height = 1 3342 Top = 2 1243 Width = 53939 Height = 161 40 Top = 253 41 Width = 647 44 42 Align = alClient 45 43 BevelOuter = bvSpace 46 ClientHeight = 1 3347 ClientWidth = 53944 ClientHeight = 161 45 ClientWidth = 647 48 46 TabOrder = 1 49 47 object MemoLog: TMemo 50 Left = 851 Height = 1 1752 Top = 853 Width = 52348 Left = 10 49 Height = 141 50 Top = 10 51 Width = 627 54 52 Anchors = [akTop, akLeft, akRight, akBottom] 55 53 ReadOnly = True … … 60 58 object PanelProgress: TPanel 61 59 Left = 0 62 Height = 5463 Top = 1 0664 Width = 53960 Height = 65 61 Top = 126 62 Width = 647 65 63 Align = alTop 66 64 BevelOuter = bvNone 67 ClientHeight = 5468 ClientWidth = 53965 ClientHeight = 65 66 ClientWidth = 647 69 67 TabOrder = 2 70 68 object ProgressBarPart: TProgressBar 71 Left = 1 072 Height = 2 473 Top = 2 474 Width = 52369 Left = 12 70 Height = 29 71 Top = 29 72 Width = 628 75 73 Anchors = [akTop, akLeft, akRight] 76 74 TabOrder = 0 77 75 end 78 76 object LabelEstimatedTimePart: TLabel 79 Left = 880 Height = 2 077 Left = 10 78 Height = 26 81 79 Top = -2 82 Width = 1 0380 Width = 132 83 81 Caption = 'Estimated time:' 84 ParentColor = False85 82 end 86 83 end 87 84 object PanelOperations: TPanel 88 85 Left = 0 89 Height = 4290 Top = 6491 Width = 53986 Height = 50 87 Top = 76 88 Width = 647 92 89 Align = alTop 93 90 BevelOuter = bvNone 94 ClientHeight = 4295 ClientWidth = 53991 ClientHeight = 50 92 ClientWidth = 647 96 93 FullRepaint = False 97 94 TabOrder = 3 98 95 object ListViewJobs: TListView 99 Left = 8100 Height = 3 2101 Top = 5102 Width = 52396 Left = 10 97 Height = 38 98 Top = 6 99 Width = 627 103 100 Anchors = [akTop, akLeft, akRight, akBottom] 104 101 AutoWidthLastColumn = True … … 107 104 Columns = < 108 105 item 109 Width = 523106 Width = 614 110 107 end> 111 108 OwnerData = True … … 120 117 object PanelProgressTotal: TPanel 121 118 Left = 0 122 Height = 52123 Top = 1 60124 Width = 539119 Height = 62 120 Top = 191 121 Width = 647 125 122 Align = alTop 126 123 BevelOuter = bvNone 127 ClientHeight = 52128 ClientWidth = 539124 ClientHeight = 62 125 ClientWidth = 647 129 126 TabOrder = 4 130 127 object LabelEstimatedTimeTotal: TLabel 131 Left = 8132 Height = 2 0128 Left = 10 129 Height = 26 133 130 Top = 0 134 Width = 1 41131 Width = 178 135 132 Caption = 'Total estimated time:' 136 ParentColor = False137 133 end 138 134 object ProgressBarTotal: TProgressBar 139 Left = 8140 Height = 2 4141 Top = 2 4142 Width = 523135 Left = 10 136 Height = 29 137 Top = 29 138 Width = 627 143 139 Anchors = [akTop, akLeft, akRight] 144 140 TabOrder = 0 … … 147 143 object PanelText: TPanel 148 144 Left = 0 149 Height = 3 2150 Top = 3 2151 Width = 539145 Height = 38 146 Top = 38 147 Width = 647 152 148 Align = alTop 153 149 BevelOuter = bvNone 154 ClientHeight = 3 2155 ClientWidth = 539150 ClientHeight = 38 151 ClientWidth = 647 156 152 TabOrder = 5 157 153 object LabelText: TLabel 158 Left = 8159 Height = 2 4160 Top = 8161 Width = 525154 Left = 10 155 Height = 29 156 Top = 10 157 Width = 630 162 158 Anchors = [akTop, akLeft, akRight] 163 159 AutoSize = False 164 ParentColor = False165 160 end 166 161 end 167 162 object ImageList1: TImageList 168 BkColor = clForeground 169 left = 200 170 top = 8 163 Left = 240 164 Top = 10 171 165 Bitmap = { 172 4C69020000001000000010000000FF00FF00FF00FF00FF00FF00FF00FF00FF00 173 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 174 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 175 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 176 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 177 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 178 FF00000000FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 179 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF000000 180 00FF000000FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 181 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF0000 182 00FF000000FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 183 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF0000 184 00FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 185 FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FF0000 186 00FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FFFF00FF00FF00 187 FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FF000000FFFF00 188 FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FFFF00 189 FF00FF00FF00FF00FF00000000FF000000FF000000FF000000FFFF00FF00FF00 190 FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FF0000 191 00FFFF00FF00000000FF000000FF000000FF000000FFFF00FF00FF00FF00FF00 192 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF0000 193 00FF000000FF000000FF000000FF000000FFFF00FF00FF00FF00FF00FF00FF00 194 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF0000 195 00FF000000FF000000FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00 196 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF000000 197 00FF000000FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 198 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 199 FF00000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 200 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 201 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 202 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 203 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 204 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 205 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 206 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 207 FF00FF00FF00FF00FF00FF00FF00000000FFFF00FF00FF00FF00FF00FF00FF00 208 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 209 FF00FF00FF00FF00FF00FF00FF00000000FF000000FFFF00FF00FF00FF00FF00 210 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 211 FF00FF00FF00FF00FF00FF00FF00000000FF000084FF000000FFFF00FF00FF00 212 FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FF0000 213 00FF000000FF000000FF000000FF000000FF0000FFFF000084FF000000FFFF00 214 FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF0000FFFF0000FFFF0000 215 FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF000084FF0000 216 00FFFF00FF00FF00FF00FF00FF00FF00FF00000000FF0000FFFF0000FFFF0000 217 FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000 218 84FF000000FFFF00FF00FF00FF00FF00FF00000000FF0000FFFF0000FFFF0000 219 FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000 220 FFFF000084FF000000FFFF00FF00FF00FF00000000FF0000FFFF0000FFFF0000 221 FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000 222 84FF000000FFFF00FF00FF00FF00FF00FF00000000FF0000FFFF0000FFFF0000 223 FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF000084FF0000 224 00FFFF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FF0000 225 00FF000000FF000000FF000000FF000000FF0000FFFF000084FF000000FFFF00 226 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 227 FF00FF00FF00FF00FF00FF00FF00000000FF000084FF000000FFFF00FF00FF00 228 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 229 FF00FF00FF00FF00FF00FF00FF00000000FF000000FFFF00FF00FF00FF00FF00 230 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 231 FF00FF00FF00FF00FF00FF00FF00000000FFFF00FF00FF00FF00FF00FF00FF00 232 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 233 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 234 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 235 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 236 FF00FF00FF00FF00FF00FF00FF00 166 4C7A0200000010000000100000006A0000000000000078DAE593490E00100C45 167 7B78F72E5684A63A1142C382BE4F0708F89C955117F4B016BE67B5FC6E96DB97 168 B0D4B9F4CD949F36DED1DF922B0F1BD11FAB5AFC68DE5C44D40220A9FA779EC8 169 6A349FD5A435E43CADA1E3678D73F773F1DBF3EFADFFEEFEBBF97F6696BE9D36 237 170 } 238 171 end … … 241 174 Interval = 100 242 175 OnTimer = TimerUpdateTimer 243 left = 264244 top = 8176 Left = 384 177 Top = 10 245 178 end 246 179 end -
trunk/Packages/Common/UJobProgressView.pas
r122 r131 7 7 uses 8 8 SysUtils, Variants, Classes, Graphics, Controls, Forms, Syncobjs, 9 Dialogs, ComCtrls, StdCtrls, ExtCtrls, Contnrs, UThreading, Math,9 Dialogs, ComCtrls, StdCtrls, ExtCtrls, fgl, UThreading, Math, 10 10 DateUtils; 11 11 … … 71 71 end; 72 72 73 TJobs = class(T ObjectList)73 TJobs = class(TFPGObjectList<TJob>) 74 74 end; 75 75 … … 105 105 procedure ReloadJobList; 106 106 procedure FormClose(Sender: TObject; var CloseAction: TCloseAction); 107 procedure FormDestroy(Sender: TObject);108 107 procedure ListViewJobsData(Sender: TObject; Item: TListItem); 109 108 procedure TimerUpdateTimer(Sender: TObject); … … 175 174 STotalEstimatedTime = 'Total estimated time: %s'; 176 175 SFinished = 'Finished'; 177 SOperations = 'Operations:';178 176 179 177 procedure Register; … … 287 285 end; 288 286 289 procedure TFormJobProgressView.FormDestroy(Sender:TObject);290 begin291 end;292 293 287 procedure TFormJobProgressView.ListViewJobsData(Sender: TObject; Item: TListItem); 294 288 begin 295 289 if (Item.Index >= 0) and (Item.Index < JobProgressView.Jobs.Count) then 296 with TJob(JobProgressView.Jobs[Item.Index])do begin290 with JobProgressView.Jobs[Item.Index] do begin 297 291 Item.Caption := Title; 298 292 if Item.Index = JobProgressView.CurrentJobIndex then Item.ImageIndex := 1 … … 406 400 I := 0; 407 401 while I < Jobs.Count do 408 with TJob(Jobs[I])do begin402 with Jobs[I] do begin 409 403 CurrentJobIndex := I; 410 CurrentJob := TJob(Jobs[I]);404 CurrentJob := Jobs[I]; 411 405 JobProgressChange(Self); 412 406 StartTime := Now; … … 421 415 Method(CurrentJob); 422 416 end else begin 417 Thread := TJobThread.Create(True); 423 418 try 424 Thread := TJobThread.Create(True);425 419 with Thread do begin 426 420 FreeOnTerminate := False; … … 495 489 if AValue = FTerminate then Exit; 496 490 for I := 0 to Jobs.Count - 1 do 497 TJob(Jobs[I]).Terminate := AValue;491 Jobs[I].Terminate := AValue; 498 492 FTerminate := AValue; 499 493 end; … … 621 615 procedure TProgress.Increment; 622 616 begin 623 try624 FLock.Acquire;617 FLock.Acquire; 618 try 625 619 Value := Value + 1; 626 620 finally … … 631 625 procedure TProgress.Reset; 632 626 begin 633 try634 FLock.Acquire;627 FLock.Acquire; 628 try 635 629 FValue := 0; 636 630 finally … … 679 673 destructor TJob.Destroy; 680 674 begin 681 Progress.Free;675 FreeAndNil(Progress); 682 676 inherited; 683 677 end; -
trunk/Packages/Common/ULastOpenedList.pas
r122 r131 30 30 procedure SaveToXMLConfig(XMLConfig: TXMLConfig; Path: string); 31 31 procedure AddItem(FileName: string); 32 function GetFirstFileName: string; 32 33 published 33 34 property MaxCount: Integer read FMaxCount write SetMaxCount; … … 83 84 destructor TLastOpenedList.Destroy; 84 85 begin 85 Items.Free;86 FreeAndNil(Items); 86 87 inherited; 87 88 end; … … 93 94 begin 94 95 if Assigned(MenuItem) then begin 95 MenuItem.Clear; 96 while MenuItem.Count > Items.Count do 97 MenuItem.Delete(MenuItem.Count - 1); 98 while MenuItem.Count < Items.Count do begin 99 NewMenuItem := TMenuItem.Create(MenuItem); 100 MenuItem.Add(NewMenuItem); 101 end; 96 102 for I := 0 to Items.Count - 1 do begin 97 NewMenuItem := TMenuItem.Create(MenuItem); 98 NewMenuItem.Caption := Items[I]; 99 NewMenuItem.OnClick := ClickAction; 100 MenuItem.Add(NewMenuItem); 103 MenuItem.Items[I].Caption := Items[I]; 104 MenuItem.Items[I].OnClick := ClickAction; 101 105 end; 102 106 end; … … 185 189 end; 186 190 191 function TLastOpenedList.GetFirstFileName: string; 192 begin 193 if Items.Count > 0 then Result := Items[0] 194 else Result := ''; 195 end; 196 187 197 end. 188 198 -
trunk/Packages/Common/UListViewSort.pas
r122 r131 1 1 unit UListViewSort; 2 2 3 // Date: 201 0-11-033 // Date: 2019-05-17 4 4 5 5 {$mode delphi} … … 8 8 9 9 uses 10 {$IFDEF Windows}Windows, CommCtrl, {$ENDIF}Classes, Graphics, ComCtrls, SysUtils,11 Controls, DateUtils, Dialogs, SpecializedList, Forms, Grids, StdCtrls, ExtCtrls,12 LclIntf, L Messages, LclType, LResources;10 {$IFDEF Windows}Windows, CommCtrl, LMessages, {$ENDIF}Classes, Graphics, ComCtrls, SysUtils, 11 Controls, DateUtils, Dialogs, fgl, Forms, Grids, StdCtrls, ExtCtrls, 12 LclIntf, LclType, LResources; 13 13 14 14 type … … 52 52 {$ENDIF} 53 53 public 54 List: T ListObject;55 Source: T ListObject;54 List: TFPGObjectList<TObject>; 55 Source: TFPGObjectList<TObject>; 56 56 constructor Create(AOwner: TComponent); override; 57 57 destructor Destroy; override; … … 81 81 FOnChange: TNotifyEvent; 82 82 FStringGrid1: TStringGrid; 83 procedure DoOnChange; 83 84 procedure GridDoOnKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); 84 85 procedure GridDoOnResize(Sender: TObject); … … 90 91 function TextEnteredColumn(Index: Integer): Boolean; 91 92 function GetColValue(Index: Integer): string; 93 procedure Reset; 92 94 property StringGrid: TStringGrid read FStringGrid1 write FStringGrid1; 93 95 published … … 98 100 end; 99 101 102 { TListViewEx } 103 104 TListViewEx = class(TWinControl) 105 private 106 FFilter: TListViewFilter; 107 FListView: TListView; 108 FListViewSort: TListViewSort; 109 procedure ResizeHanlder; 110 public 111 constructor Create(TheOwner: TComponent); override; 112 destructor Destroy; override; 113 published 114 property ListView: TListView read FListView write FListView; 115 property ListViewSort: TListViewSort read FListViewSort write FListViewSort; 116 property Filter: TListViewFilter read FFilter write FFilter; 117 property Visible; 118 end; 119 100 120 procedure Register; 101 121 … … 105 125 procedure Register; 106 126 begin 107 RegisterComponents('Common', [TListViewSort, TListViewFilter]); 127 RegisterComponents('Common', [TListViewSort, TListViewFilter, TListViewEx]); 128 end; 129 130 { TListViewEx } 131 132 procedure TListViewEx.ResizeHanlder; 133 begin 134 end; 135 136 constructor TListViewEx.Create(TheOwner: TComponent); 137 begin 138 inherited Create(TheOwner); 139 Filter := TListViewFilter.Create(Self); 140 Filter.Parent := Self; 141 Filter.Align := alBottom; 142 ListView := TListView.Create(Self); 143 ListView.Parent := Self; 144 ListView.Align := alClient; 145 ListViewSort := TListViewSort.Create(Self); 146 ListViewSort.ListView := ListView; 147 end; 148 149 destructor TListViewEx.Destroy; 150 begin 151 inherited Destroy; 108 152 end; 109 153 110 154 { TListViewFilter } 155 156 procedure TListViewFilter.DoOnChange; 157 begin 158 if Assigned(FOnChange) then FOnChange(Self); 159 end; 111 160 112 161 procedure TListViewFilter.GridDoOnKeyUp(Sender: TObject; var Key: Word; 113 162 Shift: TShiftState); 114 163 begin 115 if Assigned(FOnChange) then 116 FOnChange(Self); 164 DoOnChange; 117 165 end; 118 166 … … 187 235 end; 188 236 237 procedure TListViewFilter.Reset; 238 var 239 I: Integer; 240 begin 241 with StringGrid do 242 for I := 0 to ColCount - 1 do 243 Cells[I, 0] := ''; 244 DoOnChange; 245 end; 246 189 247 { TListViewSort } 190 248 … … 277 335 end; 278 336 337 var 338 ListViewSortCompare: TCompareEvent; 339 340 function ListViewCompare(const Item1, Item2: TObject): Integer; 341 begin 342 Result := ListViewSortCompare(Item1, Item2); 343 end; 344 279 345 procedure TListViewSort.Sort(Compare: TCompareEvent); 280 346 begin 347 // TODO: Because TFLGObjectList compare handler is not class method, 348 // it is necessary to use simple function compare handler with local variable 349 ListViewSortCompare := Compare; 281 350 if (List.Count > 0) then 282 List.Sort( Compare);351 List.Sort(ListViewCompare); 283 352 end; 284 353 … … 343 412 begin 344 413 inherited; 345 List := T ListObject.Create;346 List. OwnsObjects := False;414 List := TFPGObjectList<TObject>.Create; 415 List.FreeObjects := False; 347 416 end; 348 417 -
trunk/Packages/Common/UMemory.pas
r89 r131 112 112 procedure TMemory.WriteMemory(Position: Integer; Memory: TMemory); 113 113 begin 114 Move(Memory.FData, PByte( @FData+ Position)^, Memory.Size);114 Move(Memory.FData, PByte(PByte(@FData) + Position)^, Memory.Size); 115 115 end; 116 116 117 117 procedure TMemory.ReadMemory(Position: Integer; Memory: TMemory); 118 118 begin 119 Move(PByte( @FData+ Position)^, Memory.FData, Memory.Size);119 Move(PByte(PByte(@FData) + Position)^, Memory.FData, Memory.Size); 120 120 end; 121 121 -
trunk/Packages/Common/UPersistentForm.pas
r122 r131 3 3 {$mode delphi} 4 4 5 // Date: 20 15-04-185 // Date: 2020-11-26 6 6 7 7 interface … … 9 9 uses 10 10 Classes, SysUtils, Forms, URegistry, LCLIntf, Registry, Controls, ComCtrls, 11 ExtCtrls ;11 ExtCtrls, LCLType; 12 12 13 13 type … … 26 26 FormRestoredSize: TRect; 27 27 FormWindowState: TWindowState; 28 FormFullScreen: Boolean; 28 29 Form: TForm; 29 30 procedure LoadFromRegistry(RegistryContext: TRegistryContext); … … 31 32 function CheckEntireVisible(Rect: TRect): TRect; 32 33 function CheckPartVisible(Rect: TRect; Part: Integer): TRect; 33 procedure Load(Form: TForm; DefaultMaximized: Boolean = False); 34 procedure Load(Form: TForm; DefaultMaximized: Boolean = False; 35 DefaultFullScreen: Boolean = False); 34 36 procedure Save(Form: TForm); 35 37 constructor Create(AOwner: TComponent); override; 38 procedure SetFullScreen(State: Boolean); 36 39 property RegistryContext: TRegistryContext read FRegistryContext 37 40 write FRegistryContext; … … 43 46 procedure Register; 44 47 48 45 49 implementation 46 47 50 48 51 procedure Register; … … 169 172 + FormRestoredSize.Top; 170 173 // Other state 171 FormWindowState := TWindowState(ReadIntegerWithDefault('WindowState', Integer(wsNormal))); 174 FormWindowState := TWindowState(ReadIntegerWithDefault('WindowState', Integer(FormWindowState))); 175 FormFullScreen := ReadBoolWithDefault('FullScreen', FormFullScreen); 172 176 finally 173 177 Free; … … 193 197 // Other state 194 198 WriteInteger('WindowState', Integer(FormWindowState)); 199 WriteBool('FullScreen', FormFullScreen); 195 200 finally 196 201 Free; … … 250 255 end; 251 256 252 procedure TPersistentForm.Load(Form: TForm; DefaultMaximized: Boolean = False); 257 procedure TPersistentForm.Load(Form: TForm; DefaultMaximized: Boolean = False; 258 DefaultFullScreen: Boolean = False); 253 259 begin 254 260 Self.Form := Form; … … 258 264 FormRestoredSize := Bounds((Screen.Width - Form.Width) div 2, 259 265 (Screen.Height - Form.Height) div 2, Form.Width, Form.Height); 266 FormWindowState := Form.WindowState; 267 FormFullScreen := DefaultFullScreen; 260 268 261 269 LoadFromRegistry(RegistryContext); … … 277 285 Form.BoundsRect := FormNormalSize; 278 286 end; 287 if FormFullScreen then SetFullScreen(True); 279 288 LoadControl(Form); 280 289 end; … … 284 293 Self.Form := Form; 285 294 FormNormalSize := Bounds(Form.Left, Form.Top, Form.Width, Form.Height); 286 FormRestoredSize := Bounds(Form.RestoredLeft, Form.RestoredTop, Form.RestoredWidth, 287 Form.RestoredHeight); 295 if not FormFullScreen then 296 FormRestoredSize := Bounds(Form.RestoredLeft, Form.RestoredTop, Form.RestoredWidth, 297 Form.RestoredHeight); 288 298 FormWindowState := Form.WindowState; 289 299 SaveToRegistry(RegistryContext); … … 300 310 end; 301 311 312 procedure TPersistentForm.SetFullScreen(State: Boolean); 313 begin 314 if State then begin 315 FormFullScreen := True; 316 FormNormalSize := Form.BoundsRect; 317 FormRestoredSize := Bounds(Form.RestoredLeft, Form.RestoredTop, Form.RestoredWidth, 318 Form.RestoredHeight); 319 FormWindowState := Form.WindowState; 320 ShowWindow(Form.Handle, SW_SHOWFULLSCREEN); 321 {$IFDEF WINDOWS} 322 Form.BorderStyle := bsNone; 323 {$ENDIF} 324 end else begin 325 FormFullScreen := False; 326 {$IFDEF WINDOWS} 327 Form.BorderStyle := bsSizeable; 328 {$ENDIF} 329 ShowWindow(Form.Handle, SW_SHOWNORMAL); 330 if FormWindowState = wsNormal then begin 331 Form.BoundsRect := FormNormalSize; 332 end else 333 if FormWindowState = wsMaximized then begin 334 Form.BoundsRect := FormRestoredSize; 335 Form.WindowState := wsMaximized; 336 end; 337 end; 338 end; 339 302 340 end. 303 341 -
trunk/Packages/Common/UPool.pas
r84 r131 6 6 7 7 uses 8 Classes, SysUtils, syncobjs, SpecializedList, UThreading;8 Classes, SysUtils, syncobjs, fgl, UThreading; 9 9 10 10 type … … 22 22 function NewItemObject: TObject; virtual; 23 23 public 24 Items: T ListObject;25 FreeItems: T ListObject;24 Items: TFPGObjectList<TObject>; 25 FreeItems: TFPGObjectList<TObject>; 26 26 function Acquire: TObject; virtual; 27 27 procedure Release(Item: TObject); virtual; … … 185 185 begin 186 186 inherited; 187 Items := T ListObject.Create;188 FreeItems := T ListObject.Create;189 FreeItems. OwnsObjects := False;187 Items := TFPGObjectList<TObject>.Create; 188 FreeItems := TFPGObjectList<TObject>.Create; 189 FreeItems.FreeObjects := False; 190 190 FReleaseEvent := TEvent.Create(nil, False, False, ''); 191 191 end; -
trunk/Packages/Common/UPrefixMultiplier.pas
r84 r131 21 21 { TPrefixMultiplier } 22 22 23 TPrefixMultiplier = class 23 TPrefixMultiplier = class(TComponent) 24 24 private 25 function TruncateDigits(Value: Double;Digits:Integer=3):Double;25 function TruncateDigits(Value: Double; Digits: Integer = 3): Double; 26 26 public 27 27 function Add(Value: Double; PrefixMultipliers: TPrefixMultiplierDef; … … 72 72 ); 73 73 74 procedure Register; 75 76 74 77 implementation 78 79 procedure Register; 80 begin 81 RegisterComponents('Common', [TPrefixMultiplier]); 82 end; 75 83 76 84 { TPrefixMultiplier } … … 92 100 end; 93 101 94 function TPrefixMultiplier.Add(Value: Double;PrefixMultipliers:TPrefixMultiplierDef95 ; UnitText:string;Digits:Integer):string;102 function TPrefixMultiplier.Add(Value: Double; PrefixMultipliers: TPrefixMultiplierDef 103 ; UnitText:string; Digits: Integer): string; 96 104 var 97 105 I: Integer; -
trunk/Packages/Common/URegistry.pas
r123 r131 1 1 unit URegistry; 2 2 3 {$MODE Delphi}3 {$MODE delphi} 4 4 5 5 interface … … 17 17 RootKey: HKEY; 18 18 Key: string; 19 class operator Equal(A, B: TRegistryContext): Boolean;20 19 class function Create(RootKey: TRegistryRoot; Key: string): TRegistryContext; static; overload; 21 20 class function Create(RootKey: HKEY; Key: string): TRegistryContext; static; overload; 21 class operator Equal(A, B: TRegistryContext): Boolean; 22 22 end; 23 23 … … 29 29 procedure SetCurrentContext(AValue: TRegistryContext); 30 30 public 31 function ReadChar(const Name: string): Char; 32 procedure WriteChar(const Name: string; Value: Char); 31 33 function ReadBoolWithDefault(const Name: string; 32 34 DefaultValue: Boolean): Boolean; 33 35 function ReadIntegerWithDefault(const Name: string; DefaultValue: Integer): Integer; 34 36 function ReadStringWithDefault(const Name: string; DefaultValue: string): string; 37 function ReadCharWithDefault(const Name: string; DefaultValue: Char): Char; 35 38 function ReadFloatWithDefault(const Name: string; 36 39 DefaultValue: Double): Double; … … 89 92 end; 90 93 94 function TRegistryEx.ReadCharWithDefault(const Name: string; DefaultValue: Char 95 ): Char; 96 begin 97 if ValueExists(Name) then Result := ReadChar(Name) 98 else begin 99 WriteChar(Name, DefaultValue); 100 Result := DefaultValue; 101 end; 102 end; 103 91 104 function TRegistryEx.ReadFloatWithDefault(const Name: string; 92 105 DefaultValue: Double): Double; … … 119 132 function TRegistryEx.OpenKey(const Key: string; CanCreate: Boolean): Boolean; 120 133 begin 121 {$IFDEF Linux}122 CloseKey;134 {$IFDEF UNIX} 135 //CloseKey; 123 136 {$ENDIF} 124 137 Result := inherited OpenKey(Key, CanCreate); … … 127 140 function TRegistryEx.GetCurrentContext: TRegistryContext; 128 141 begin 129 Result.Key := CurrentPath;142 Result.Key := String(CurrentPath); 130 143 Result.RootKey := RootKey; 131 144 end; … … 135 148 RootKey := AValue.RootKey; 136 149 OpenKey(AValue.Key, True); 150 end; 151 152 function TRegistryEx.ReadChar(const Name: string): Char; 153 var 154 S: string; 155 begin 156 S := ReadString(Name); 157 if Length(S) > 0 then Result := S[1] 158 else Result := #0; 159 end; 160 161 procedure TRegistryEx.WriteChar(const Name: string; Value: Char); 162 begin 163 WriteString(Name, Value); 137 164 end; 138 165 -
trunk/Packages/Common/UScaleDPI.pas
r122 r131 8 8 9 9 uses 10 Classes, Forms, Graphics, Controls, ComCtrls, LCLType, SysUtils, StdCtrls, 11 Contnrs; 10 Classes, Forms, Graphics, Controls, ComCtrls, LCLType, SysUtils, fgl; 12 11 13 12 type 13 TControlDimensions = class; 14 14 15 15 { TControlDimension } … … 18 18 BoundsRect: TRect; 19 19 FontHeight: Integer; 20 Controls: T ObjectList; // TList<TControlDimension>20 Controls: TControlDimensions; 21 21 // Class specifics 22 22 ButtonSize: TPoint; // TToolBar … … 26 26 constructor Create; 27 27 destructor Destroy; override; 28 end; 29 30 TControlDimensions = class(TFPGObjectList<TControlDimension>) 28 31 end; 29 32 … … 73 76 constructor TControlDimension.Create; 74 77 begin 75 Controls := T ObjectList.Create;78 Controls := TControlDimensions.Create; 76 79 end; 77 80 … … 79 82 begin 80 83 FreeAndNil(Controls); 81 inherited Destroy;84 inherited; 82 85 end; 83 86 … … 212 215 TempBmp: TBitmap; 213 216 Temp: array of TBitmap; 214 NewWidth, NewHeight: integer; 217 NewWidth: Integer; 218 NewHeight: Integer; 215 219 I: Integer; 216 220 begin 217 221 ImgList.BeginUpdate; 218 NewWidth := ScaleX(ImgList.Width, FromDPI.X); 219 NewHeight := ScaleY(ImgList.Height, FromDPI.Y); 220 221 SetLength(Temp, ImgList.Count); 222 for I := 0 to ImgList.Count - 1 do 223 begin 224 TempBmp := TBitmap.Create; 225 TempBmp.PixelFormat := pf32bit; 226 ImgList.GetBitmap(I, TempBmp); 227 Temp[I] := TBitmap.Create; 228 Temp[I].SetSize(NewWidth, NewHeight); 229 Temp[I].PixelFormat := pf32bit; 230 Temp[I].TransparentColor := TempBmp.TransparentColor; 231 //Temp[I].TransparentMode := TempBmp.TransparentMode; 232 Temp[I].Transparent := True; 233 Temp[I].Canvas.Brush.Style := bsSolid; 234 Temp[I].Canvas.Brush.Color := Temp[I].TransparentColor; 235 Temp[I].Canvas.FillRect(0, 0, Temp[I].Width, Temp[I].Height); 236 237 if (Temp[I].Width = 0) or (Temp[I].Height = 0) then Continue; 238 Temp[I].Canvas.StretchDraw(Rect(0, 0, Temp[I].Width, Temp[I].Height), TempBmp); 239 TempBmp.Free; 240 end; 241 242 ImgList.Clear; 243 ImgList.Width := NewWidth; 244 ImgList.Height := NewHeight; 245 246 for I := 0 to High(Temp) do 247 begin 248 ImgList.Add(Temp[I], nil); 249 Temp[i].Free; 250 end; 251 ImgList.EndUpdate; 222 try 223 NewWidth := ScaleX(ImgList.Width, FromDPI.X); 224 NewHeight := ScaleY(ImgList.Height, FromDPI.Y); 225 226 Temp := nil; 227 SetLength(Temp, ImgList.Count); 228 for I := 0 to ImgList.Count - 1 do 229 begin 230 TempBmp := TBitmap.Create; 231 try 232 TempBmp.PixelFormat := pf32bit; 233 ImgList.GetBitmap(I, TempBmp); 234 Temp[I] := TBitmap.Create; 235 Temp[I].SetSize(NewWidth, NewHeight); 236 {$IFDEF UNIX} 237 Temp[I].PixelFormat := pf24bit; 238 {$ELSE} 239 Temp[I].PixelFormat := pf32bit; 240 {$ENDIF} 241 Temp[I].TransparentColor := TempBmp.TransparentColor; 242 //Temp[I].TransparentMode := TempBmp.TransparentMode; 243 Temp[I].Transparent := True; 244 Temp[I].Canvas.Brush.Style := bsSolid; 245 Temp[I].Canvas.Brush.Color := Temp[I].TransparentColor; 246 Temp[I].Canvas.FillRect(0, 0, Temp[I].Width, Temp[I].Height); 247 248 if (Temp[I].Width = 0) or (Temp[I].Height = 0) then Continue; 249 Temp[I].Canvas.StretchDraw(Rect(0, 0, Temp[I].Width, Temp[I].Height), TempBmp); 250 finally 251 TempBmp.Free; 252 end; 253 end; 254 255 ImgList.Clear; 256 ImgList.Width := NewWidth; 257 ImgList.Height := NewHeight; 258 259 for I := 0 to High(Temp) do 260 begin 261 ImgList.Add(Temp[I], nil); 262 Temp[i].Free; 263 end; 264 finally 265 ImgList.EndUpdate; 266 end; 252 267 end; 253 268 … … 289 304 //OldAutoSize: Boolean; 290 305 begin 306 //if not (Control is TCustomPage) then 307 // Resize childs first 308 if Control is TWinControl then begin 309 WinControl := TWinControl(Control); 310 if WinControl.ControlCount > 0 then begin 311 for I := 0 to WinControl.ControlCount - 1 do begin 312 if WinControl.Controls[I] is TControl then begin 313 ScaleControl(WinControl.Controls[I], FromDPI); 314 end; 315 end; 316 end; 317 end; 318 291 319 //if Control is TMemo then Exit; 292 320 //if Control is TForm then … … 314 342 with TCoolBar(Control) do begin 315 343 BeginUpdate; 316 for I := 0 to Bands.Count - 1 do 317 with Bands[I] do begin 318 MinWidth := ScaleX(MinWidth, FromDPI.X); 319 MinHeight := ScaleY(MinHeight, FromDPI.Y); 320 // Workaround to bad band width auto sizing 321 //Width := ScaleX(Width, FromDPI.X); 322 Width := ScaleX(Control.Width + 28, FromDPI.X); 323 //Control.Invalidate; 344 try 345 for I := 0 to Bands.Count - 1 do 346 with Bands[I] do begin 347 MinWidth := ScaleX(MinWidth, FromDPI.X); 348 MinHeight := ScaleY(MinHeight, FromDPI.Y); 349 // Workaround to bad band width auto sizing 350 //Width := ScaleX(Width, FromDPI.X); 351 Width := ScaleX(Control.Width + 28, FromDPI.X); 352 //Control.Invalidate; 353 end; 354 // Workaround for bad autosizing of coolbar 355 if AutoSize then begin 356 AutoSize := False; 357 Height := ScaleY(Height, FromDPI.Y); 358 AutoSize := True; 324 359 end; 325 // Workaround for bad autosizing of coolbar 326 if AutoSize then begin 327 AutoSize := False; 328 Height := ScaleY(Height, FromDPI.Y); 329 AutoSize := True; 330 end; 331 EndUpdate; 360 finally 361 EndUpdate; 362 end; 332 363 end; 333 364 … … 340 371 end; 341 372 342 //if not (Control is TCustomPage) then343 if Control is TWinControl then begin344 WinControl := TWinControl(Control);345 if WinControl.ControlCount > 0 then begin346 for I := 0 to WinControl.ControlCount - 1 do begin347 if WinControl.Controls[I] is TControl then begin348 ScaleControl(WinControl.Controls[I], FromDPI);349 end;350 end;351 end;352 end;353 373 //if Control is TForm then 354 374 // Control.EnableAutoSizing; -
trunk/Packages/Common/UTheme.pas
r122 r131 5 5 uses 6 6 Classes, SysUtils, Graphics, ComCtrls, Controls, ExtCtrls, Menus, StdCtrls, 7 Spin, Forms, Contnrs, Grids;7 Spin, Forms, fgl, Grids; 8 8 9 9 type … … 19 19 { TThemes } 20 20 21 TThemes = class(T ObjectList)21 TThemes = class(TFPGObjectList<TTheme>) 22 22 function AddNew(Name: string): TTheme; 23 23 function FindByName(Name: string): TTheme; … … 41 41 property Theme: TTheme read FTheme write SetTheme; 42 42 end; 43 44 const 45 ThemeNameSystem = 'System'; 46 ThemeNameLight = 'Light'; 47 ThemeNameDark = 'Dark'; 43 48 44 49 procedure Register; … … 74 79 procedure TThemes.LoadToStrings(Strings: TStrings); 75 80 var 76 Theme: TTheme;81 I: Integer; 77 82 begin 78 Strings.Clear; 79 for Theme in Self do 80 Strings.AddObject(Theme.Name, Theme); 83 Strings.BeginUpdate; 84 try 85 while Strings.Count < Count do Strings.Add(''); 86 while Strings.Count > Count do Strings.Delete(Strings.Count - 1); 87 for I := 0 to Count - 1 do begin 88 Strings[I] := Items[I].Name; 89 Strings.Objects[I] := Items[I]; 90 end; 91 finally 92 Strings.EndUpdate; 93 end; 81 94 end; 82 95 … … 97 110 inherited; 98 111 Themes := TThemes.Create; 99 with Themes.AddNew( 'System') do begin112 with Themes.AddNew(ThemeNameSystem) do begin 100 113 ColorWindow := clWindow; 101 114 ColorWindowText := clWindowText; … … 105 118 end; 106 119 Theme := TTheme(Themes.First); 107 with Themes.AddNew( 'Dark') do begin120 with Themes.AddNew(ThemeNameDark) do begin 108 121 ColorWindow := RGBToColor($20, $20, $20); 109 122 ColorWindowText := clWhite; … … 112 125 ColorControlSelected := RGBToColor(96, 125, 155); 113 126 end; 114 with Themes.AddNew( 'Light') do begin127 with Themes.AddNew(ThemeNameLight) do begin 115 128 ColorWindow := clWhite; 116 129 ColorWindowText := clBlack; … … 123 136 destructor TThemeManager.Destroy; 124 137 begin 125 Themes.Free;126 inherited Destroy;138 FreeAndNil(Themes); 139 inherited; 127 140 end; 128 141 … … 167 180 procedure TThemeManager.UseTheme(Form: TForm); 168 181 begin 169 if not Used and (FTheme.Name = 'System') then Exit;182 if not Used and (FTheme.Name = ThemeNameSystem) then Exit; 170 183 ApplyTheme(Form); 171 184 Used := True; -
trunk/Packages/Common/UThreading.pas
r122 r131 6 6 7 7 uses 8 Classes, SysUtils, Forms, Contnrs, SyncObjs;8 Classes, SysUtils, Forms, fgl, SyncObjs; 9 9 10 10 type … … 22 22 function GetSuspended: Boolean; virtual; abstract; 23 23 function GetTerminated: Boolean; virtual; abstract; 24 function GetThreadId: Integer; virtual; abstract;24 function GetThreadId: TThreadID; virtual; abstract; 25 25 procedure SetFreeOnTerminate(const AValue: Boolean); virtual; abstract; 26 26 procedure SetPriority(const AValue: TThreadPriority); virtual; abstract; … … 42 42 property Terminated: Boolean read GetTerminated write SetTerminated; 43 43 property Finished: Boolean read GetFinished; 44 property ThreadId: Integerread GetThreadId;44 property ThreadId: TThreadID read GetThreadId; 45 45 end; 46 46 … … 68 68 function GetSuspended: Boolean; override; 69 69 function GetTerminated: Boolean; override; 70 function GetThreadId: Integer; override;70 function GetThreadId: TThreadID; override; 71 71 procedure SetFreeOnTerminate(const AValue: Boolean); override; 72 72 procedure SetPriority(const AValue: TThreadPriority); override; … … 102 102 { TThreadList } 103 103 104 TThreadList = class(T ObjectList)105 function FindById(Id: Integer): TVirtualThread;104 TThreadList = class(TFPGObjectList<TVirtualThread>) 105 function FindById(Id: TThreadID): TVirtualThread; 106 106 constructor Create; virtual; 107 107 end; … … 164 164 if MainThreadID = ThreadID then Method 165 165 else begin 166 Thread := ThreadList.FindById(ThreadID); 166 try 167 ThreadListLock.Acquire; 168 Thread := ThreadList.FindById(ThreadID); 169 finally 170 ThreadListLock.Release; 171 end; 167 172 if Assigned(Thread) then begin 168 173 Thread.Synchronize(Method); … … 173 178 { TThreadList } 174 179 175 function TThreadList.FindById(Id: Integer): TVirtualThread;180 function TThreadList.FindById(Id: TThreadID): TVirtualThread; 176 181 var 177 182 I: Integer; 178 183 begin 179 184 I := 0; 180 while (I < ThreadList.Count) and (T VirtualThread(ThreadList[I]).ThreadID <> Id) do185 while (I < ThreadList.Count) and (ThreadList[I].ThreadID <> Id) do 181 186 Inc(I); 182 if I < ThreadList.Count then Result := T VirtualThread(ThreadList[I])187 if I < ThreadList.Count then Result := ThreadList[I] 183 188 else Result := nil; 184 189 end; … … 233 238 end; 234 239 235 function TListedThread.GetThreadId: Integer;240 function TListedThread.GetThreadId: TThreadID; 236 241 begin 237 242 Result := FThread.ThreadID; … … 356 361 ThreadListLock := TCriticalSection.Create; 357 362 ThreadList := TThreadList.Create; 358 ThreadList. OwnsObjects := False;363 ThreadList.FreeObjects := False; 359 364 360 365 finalization -
trunk/Packages/Common/UXMLUtils.pas
r122 r131 7 7 uses 8 8 {$IFDEF WINDOWS}Windows,{$ENDIF} 9 Classes, SysUtils, DateUtils, DOM ;9 Classes, SysUtils, DateUtils, DOM, xmlread; 10 10 11 11 function XMLTimeToDateTime(XMLDateTime: string): TDateTime; … … 21 21 function ReadString(Node: TDOMNode; Name: string; DefaultValue: string): string; 22 22 function ReadDateTime(Node: TDOMNode; Name: string; DefaultValue: TDateTime): TDateTime; 23 procedure ReadXMLFileParser(out Doc: TXMLDocument; FileName: string); 23 24 24 25 25 26 implementation 27 28 procedure ReadXMLFileParser(out Doc: TXMLDocument; FileName: string); 29 var 30 Parser: TDOMParser; 31 Src: TXMLInputSource; 32 InFile: TFileStream; 33 begin 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; 45 end; 26 46 27 47 function GetTimeZoneBias: Integer;
Note:
See TracChangeset
for help on using the changeset viewer.