Changeset 15 for trunk/Packages/Common
- Timestamp:
- Mar 22, 2018, 8:31:19 PM (7 years ago)
- Location:
- trunk/Packages/Common
- Files:
-
- 16 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/Packages/Common/Common.lpk
r10 r15 4 4 <PathDelim Value="\"/> 5 5 <Name Value="Common"/> 6 <Type Value="RunAndDesignTime"/> 6 7 <AddToProjectUsesSection Value="True"/> 7 8 <Author Value="Chronos (robie@centrum.cz)"/> … … 10 11 <PathDelim Value="\"/> 11 12 <SearchPaths> 12 <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS) "/>13 <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)-$(BuildMode)"/> 13 14 </SearchPaths> 15 <Parsing> 16 <SyntaxOptions> 17 <SyntaxMode Value="Delphi"/> 18 <CStyleOperator Value="False"/> 19 <AllowLabel Value="False"/> 20 <CPPInline Value="False"/> 21 </SyntaxOptions> 22 </Parsing> 23 <CodeGeneration> 24 <Optimizations> 25 <OptimizationLevel Value="0"/> 26 </Optimizations> 27 </CodeGeneration> 28 <Linking> 29 <Debugging> 30 <GenerateDebugInfo Value="False"/> 31 </Debugging> 32 </Linking> 33 <Other> 34 <CompilerMessages> 35 <IgnoredMessages idx5024="True"/> 36 </CompilerMessages> 37 </Other> 14 38 </CompilerOptions> 15 39 <Description Value="Various libraries"/> 16 40 <License Value="GNU/GPL"/> 17 41 <Version Minor="7"/> 18 <Files Count="2 0">42 <Files Count="21"> 19 43 <Item1> 20 44 <Filename Value="StopWatch.pas"/> … … 105 129 <UnitName Value="UScaleDPI"/> 106 130 </Item20> 131 <Item21> 132 <Filename Value="UTheme.pas"/> 133 <HasRegisterProc Value="True"/> 134 <UnitName Value="UTheme"/> 135 </Item21> 107 136 </Files> 108 137 <i18n> 109 138 <EnableI18N Value="True"/> 110 139 <OutDir Value="Languages"/> 140 <EnableI18NForLFM Value="True"/> 111 141 </i18n> 112 <Type Value="RunAndDesignTime"/> 113 <RequiredPkgs Count="2"> 142 <RequiredPkgs Count="3"> 114 143 <Item1> 115 <PackageName Value=" TemplateGenerics"/>144 <PackageName Value="LCL"/> 116 145 </Item1> 117 146 <Item2> 147 <PackageName Value="TemplateGenerics"/> 148 </Item2> 149 <Item3> 118 150 <PackageName Value="FCL"/> 119 151 <MinVersion Major="1" Valid="True"/> 120 </Item 2>152 </Item3> 121 153 </RequiredPkgs> 122 154 <UsageOptions> -
trunk/Packages/Common/Common.pas
r10 r15 8 8 9 9 uses 10 StopWatch, UCommon, UDebugLog, UDelay, UPrefixMultiplier, UURI, UThreading, 11 UMemory, UResetableThread, UPool, ULastOpenedList, URegistry, 12 UJobProgressView, UXMLUtils, UApplicationInfo, USyncCounter, UListViewSort, 13 UPersistentForm, UFindFile, UScaleDPI, LazarusPackageIntf;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; 14 14 15 15 implementation … … 25 25 RegisterUnit('UFindFile', @UFindFile.Register); 26 26 RegisterUnit('UScaleDPI', @UScaleDPI.Register); 27 RegisterUnit('UTheme', @UTheme.Register); 27 28 end; 28 29 -
trunk/Packages/Common/Languages/UJobProgressView.po
r14 r15 14 14 msgstr "" 15 15 16 #: ujobprogressview.soperations 17 msgid "Operations" 18 msgstr "" 19 16 20 #: ujobprogressview.spleasewait 17 21 msgid "Please wait..." -
trunk/Packages/Common/UApplicationInfo.pas
r10 r15 14 14 TApplicationInfo = class(TComponent) 15 15 private 16 FDescription: string; 16 17 FIdentification: Byte; 17 18 FLicense: string; … … 33 34 constructor Create(AOwner: TComponent); override; 34 35 property Version: string read GetVersion; 36 function GetRegistryContext: TRegistryContext; 35 37 published 36 38 property Identification: Byte read FIdentification write FIdentification; … … 45 47 property EmailContact: string read FEmailContact write FEmailContact; 46 48 property AppName: string read FAppName write FAppName; 49 property Description: string read FDescription write FDescription; 47 50 property ReleaseDate: TDateTime read FReleaseDate write FReleaseDate; 48 51 property RegistryKey: string read FRegistryKey write FRegistryKey; … … 79 82 end; 80 83 84 function TApplicationInfo.GetRegistryContext: TRegistryContext; 85 begin 86 Result := TRegistryContext.Create(RegistryRoot, RegistryKey); 87 end; 88 81 89 end. -
trunk/Packages/Common/UCommon.pas
r10 r15 6 6 7 7 uses 8 {$IFDEF Windows}Windows,{$ENDIF} 8 {$ifdef Windows}Windows,{$endif} 9 {$ifdef Linux}baseunix,{$endif} 9 10 Classes, SysUtils, StrUtils, Dialogs, Process, LCLIntf, 10 11 FileUtil; //, ShFolder, ShellAPI; … … 62 63 procedure OpenWebPage(URL: string); 63 64 procedure OpenFileInShell(FileName: string); 64 procedure ExecuteProgram( CommandLine:string);65 procedure ExecuteProgram(Executable: string; Parameters: array of string); 65 66 procedure FreeThenNil(var Obj); 67 function RemoveQuotes(Text: string): string; 68 function ComputerName: string; 69 function OccurenceOfChar(What: Char; Where: string): Integer; 70 function GetDirCount(Dir: string): Integer; 71 function MergeArray(A, B: array of string): TArrayOfString; 72 function LoadFileToStr(const FileName: TFileName): AnsiString; 66 73 67 74 … … 105 112 Path := IncludeTrailingPathDelimiter(APath); 106 113 107 Find := FindFirst( UTF8Decode(Path + AFileSpec), faAnyFile xor faDirectory, SearchRec);114 Find := FindFirst(Path + AFileSpec, faAnyFile xor faDirectory, SearchRec); 108 115 while Find = 0 do begin 109 DeleteFile UTF8(Path + UTF8Encode(SearchRec.Name));116 DeleteFile(Path + SearchRec.Name); 110 117 111 118 Find := SysUtils.FindNext(SearchRec); … … 286 293 L: LongWord; 287 294 begin 288 289 295 L := MAX_USERNAME_LENGTH + 2; 290 296 SetLength(Result, L); … … 301 307 end; 302 308 end; 303 309 {$endif} 310 311 function ComputerName: string; 312 {$ifdef mswindows} 313 const 314 INFO_BUFFER_SIZE = 32767; 315 var 316 Buffer : array[0..INFO_BUFFER_SIZE] of WideChar; 317 Ret : DWORD; 318 begin 319 Ret := INFO_BUFFER_SIZE; 320 If (GetComputerNameW(@Buffer[0],Ret)) then begin 321 Result := UTF8Encode(WideString(Buffer)); 322 end 323 else begin 324 Result := 'ERROR_NO_COMPUTERNAME_RETURNED'; 325 end; 326 end; 327 {$endif} 328 {$ifdef unix} 329 var 330 Name: UtsName; 331 begin 332 fpuname(Name); 333 Result := Name.Nodename; 334 end; 335 {$endif} 336 337 {$ifdef windows} 304 338 function LoggedOnUserNameEx(Format: TUserNameFormat): string; 305 339 const … … 395 429 end; 396 430 397 procedure ExecuteProgram( CommandLine:string);431 procedure ExecuteProgram(Executable: string; Parameters: array of string); 398 432 var 399 433 Process: TProcess; 434 I: Integer; 400 435 begin 401 436 try 402 437 Process := TProcess.Create(nil); 403 Process.CommandLine := CommandLine; 438 Process.Executable := Executable; 439 for I := 0 to Length(Parameters) - 1 do 440 Process.Parameters.Add(Parameters[I]); 404 441 Process.Options := [poNoConsole]; 405 442 Process.Execute; … … 416 453 417 454 procedure OpenWebPage(URL: string); 418 var419 Process: TProcess;420 Browser, Params: string;421 455 begin 422 456 OpenURL(URL); 423 {try 424 Process := TProcess.Create(nil); 425 Browser := ''; 426 //FindDefaultBrowser(Browser, Params); 427 //Process.Executable := Browser; 428 //Process.Parameters.Add(Format(Params, [ApplicationInfo.HomePage]); 429 Process.CommandLine := 'cmd.exe /c start ' + URL; 430 Process.Options := [poNoConsole]; 431 Process.Execute; 457 end; 458 459 procedure OpenFileInShell(FileName: string); 460 begin 461 ExecuteProgram('cmd.exe', ['/c', 'start', FileName]); 462 end; 463 464 function RemoveQuotes(Text: string): string; 465 begin 466 Result := Text; 467 if (Pos('"', Text) = 1) and (Text[Length(Text)] = '"') then 468 Result := Copy(Text, 2, Length(Text) - 2); 469 end; 470 471 function OccurenceOfChar(What: Char; Where: string): Integer; 472 var 473 I: Integer; 474 begin 475 Result := 0; 476 for I := 1 to Length(Where) do 477 if Where[I] = What then Inc(Result); 478 end; 479 480 function GetDirCount(Dir: string): Integer; 481 begin 482 Result := OccurenceOfChar(DirectorySeparator, Dir); 483 if Copy(Dir, Length(Dir), 1) = DirectorySeparator then 484 Dec(Result); 485 end; 486 487 function MergeArray(A, B: array of string): TArrayOfString; 488 var 489 I: Integer; 490 begin 491 SetLength(Result, Length(A) + Length(B)); 492 for I := 0 to Length(A) - 1 do 493 Result[I] := A[I]; 494 for I := 0 to Length(B) - 1 do 495 Result[Length(A) + I] := B[I]; 496 end; 497 498 function LoadFileToStr(const FileName: TFileName): AnsiString; 499 var 500 FileStream: TFileStream; 501 Read: Integer; 502 begin 503 Result := ''; 504 FileStream := TFileStream.Create(FileName, fmOpenRead); 505 try 506 if FileStream.Size > 0 then begin 507 SetLength(Result, FileStream.Size); 508 Read := FileStream.Read(Pointer(Result)^, FileStream.Size); 509 SetLength(Result, Read); 510 end; 432 511 finally 433 Process.Free; 434 end;} 435 end; 436 437 procedure OpenFileInShell(FileName: string); 438 begin 439 ExecuteProgram('cmd.exe /c start "' + FileName + '"'); 440 end; 512 FileStream.Free; 513 end; 514 end; 515 516 441 517 442 518 initialization -
trunk/Packages/Common/UDebugLog.pas
r10 r15 103 103 try 104 104 if ExtractFileDir(FileName) <> '' then 105 ForceDirectories UTF8(ExtractFileDir(FileName));106 if FileExists UTF8(FileName) then LogFile := TFileStream.Create(UTF8Decode(FileName), fmOpenWrite)105 ForceDirectories(ExtractFileDir(FileName)); 106 if FileExists(FileName) then LogFile := TFileStream.Create(UTF8Decode(FileName), fmOpenWrite) 107 107 else LogFile := TFileStream.Create(UTF8Decode(FileName), fmCreate); 108 108 LogFile.Seek(0, soFromEnd); -
trunk/Packages/Common/UFindFile.pas
r10 r15 55 55 end; 56 56 57 const 58 {$IFDEF WINDOWS} 59 FilterAll = '*.*'; 60 {$ENDIF} 61 {$IFDEF LINUX} 62 FilterAll = '*'; 63 {$ENDIF} 64 57 65 procedure Register; 58 66 … … 71 79 inherited Create(AOwner); 72 80 Path := IncludeTrailingBackslash(UTF8Encode(GetCurrentDir)); 73 FileMask := '*.*';81 FileMask := FilterAll; 74 82 FileAttr := [ffaAnyFile]; 75 83 s := TStringList.Create; … … 127 135 If not InSubFolders then Exit; 128 136 129 if SysUtils.FindFirst(UTF8Decode(inPath + '*.*'), faDirectory, Rec) = 0 then137 if SysUtils.FindFirst(UTF8Decode(inPath + FilterAll), faDirectory, Rec) = 0 then 130 138 try 131 139 repeat -
trunk/Packages/Common/UJobProgressView.lfm
r10 r15 14 14 OnDestroy = FormDestroy 15 15 Position = poScreenCenter 16 LCLVersion = '1. 1'16 LCLVersion = '1.6.0.4' 17 17 object PanelOperationsTitle: TPanel 18 18 Left = 0 -
trunk/Packages/Common/UJobProgressView.lrt
r10 r15 1 T JOBPROGRESSVIEW.LABELOPERATION.CAPTION=Operations:2 T JOBPROGRESSVIEW.LABELESTIMATEDTIMEPART.CAPTION=Estimated time:3 T JOBPROGRESSVIEW.LABELESTIMATEDTIMETOTAL.CAPTION=Total estimated time:1 TFORMJOBPROGRESSVIEW.LABELOPERATION.CAPTION=Operations: 2 TFORMJOBPROGRESSVIEW.LABELESTIMATEDTIMEPART.CAPTION=Estimated time: 3 TFORMJOBPROGRESSVIEW.LABELESTIMATEDTIMETOTAL.CAPTION=Total estimated time: -
trunk/Packages/Common/UJobProgressView.pas
r10 r15 166 166 STotalEstimatedTime = 'Total estimated time: %s'; 167 167 SFinished = 'Finished'; 168 SOperations = 'Operations'; 168 169 169 170 procedure Register; -
trunk/Packages/Common/UListViewSort.pas
r10 r15 9 9 uses 10 10 {$IFDEF Windows}Windows, CommCtrl, {$ENDIF}Classes, Graphics, ComCtrls, SysUtils, 11 Controls, DateUtils, Dialogs, SpecializedList, Forms, Grids, StdCtrls, ExtCtrls; 11 Controls, DateUtils, Dialogs, SpecializedList, Forms, Grids, StdCtrls, ExtCtrls, 12 LclIntf, LMessages, LclType, LResources; 12 13 13 14 type … … 18 19 TCompareEvent = function (Item1, Item2: TObject): Integer of object; 19 20 TListFilterEvent = procedure (ListViewSort: TListViewSort) of object; 21 22 { TListViewSort } 20 23 21 24 TListViewSort = class(TComponent) … … 28 31 FColumn: Integer; 29 32 FOrder: TSortOrder; 33 FOldListViewWindowProc: TWndMethod; 34 FOnColumnWidthChanged: TNotifyEvent; 35 procedure DoColumnBeginResize(const AColIndex: Integer); 36 procedure DoColumnResized(const AColIndex: Integer); 37 procedure DoColumnResizing(const AColIndex, AWidth: Integer); 30 38 procedure SetListView(const Value: TListView); 31 39 procedure ColumnClick(Sender: TObject; Column: TListColumn); … … 40 48 procedure SetColumn(const Value: Integer); 41 49 procedure SetOrder(const Value: TSortOrder); 50 {$IFDEF WINDOWS} 51 procedure NewListViewWindowProc(var AMsg: TMessage); 52 {$ENDIF} 42 53 public 43 54 List: TListObject; … … 58 69 property OnCustomDraw: TLVCustomDrawItemEvent read FOnCustomDraw 59 70 write FOnCustomDraw; 71 property OnColumnWidthChanged: TNotifyEvent read FOnColumnWidthChanged 72 write FOnColumnWidthChanged; 60 73 property Column: Integer read FColumn write SetColumn; 61 74 property Order: TSortOrder read FOrder write SetOrder; … … 68 81 FOnChange: TNotifyEvent; 69 82 FStringGrid1: TStringGrid; 70 procedure DoOnKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); 83 procedure GridDoOnKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); 84 procedure GridDoOnResize(Sender: TObject); 71 85 public 72 86 constructor Create(AOwner: TComponent); override; 73 87 procedure UpdateFromListView(ListView: TListView); 74 88 function TextEntered: Boolean; 89 function TextEnteredCount: Integer; 90 function TextEnteredColumn(Index: Integer): Boolean; 75 91 function GetColValue(Index: Integer): string; 76 92 property StringGrid: TStringGrid read FStringGrid1 write FStringGrid1; … … 79 95 property Align; 80 96 property Anchors; 97 property BorderSpacing; 81 98 end; 82 99 … … 93 110 { TListViewFilter } 94 111 95 procedure TListViewFilter. DoOnKeyUp(Sender: TObject; var Key: Word;112 procedure TListViewFilter.GridDoOnKeyUp(Sender: TObject; var Key: Word; 96 113 Shift: TShiftState); 97 114 begin 98 115 if Assigned(FOnChange) then 99 116 FOnChange(Self); 117 end; 118 119 procedure TListViewFilter.GridDoOnResize(Sender: TObject); 120 begin 121 FStringGrid1.DefaultRowHeight := FStringGrid1.Height; 100 122 end; 101 123 … … 113 135 FStringGrid1.Options := [goFixedHorzLine, goFixedVertLine, goVertLine, 114 136 goHorzLine, goRangeSelect, goEditing, goAlwaysShowEditor, goSmoothScroll]; 115 FStringGrid1.OnKeyUp := DoOnKeyUp; 137 FStringGrid1.OnKeyUp := GridDoOnKeyUp; 138 FStringGrid1.OnResize := GridDoOnResize; 116 139 end; 117 140 … … 119 142 var 120 143 I: Integer; 121 NewColumn: TGridColumn;122 144 begin 123 145 with FStringGrid1 do begin 124 Columns.Clear; 146 Options := Options - [goEditing, goAlwaysShowEditor]; 147 //Columns.Clear; 125 148 while Columns.Count > ListView.Columns.Count do Columns.Delete(Columns.Count - 1); 126 while Columns.Count < ListView.Columns.Count do NewColumn :=Columns.Add;149 while Columns.Count < ListView.Columns.Count do Columns.Add; 127 150 for I := 0 to ListView.Columns.Count - 1 do begin 128 151 Columns[I].Width := ListView.Columns[I].Width; 129 152 end; 153 Options := Options + [goEditing, goAlwaysShowEditor]; 130 154 end; 131 155 end; 132 156 133 157 function TListViewFilter.TextEntered: Boolean; 158 begin 159 Result := TextEnteredCount > 0; 160 end; 161 162 function TListViewFilter.TextEnteredCount: Integer; 134 163 var 135 164 I: Integer; 136 165 begin 137 Result := False;166 Result := 0; 138 167 for I := 0 to FStringGrid1.ColCount - 1 do begin 139 168 if FStringGrid1.Cells[I, 0] <> '' then begin 140 Result := True; 141 Break; 169 Inc(Result); 142 170 end; 143 171 end; 172 end; 173 174 function TListViewFilter.TextEnteredColumn(Index: Integer): Boolean; 175 begin 176 Result := FStringGrid1.Cells[Index, 0] <> ''; 144 177 end; 145 178 … … 153 186 { TListViewSort } 154 187 188 {$IFDEF WINDOWS} 189 procedure TListViewSort.NewListViewWindowProc(var AMsg: TMessage); 190 var 191 vColWidth: Integer; 192 vMsgNotify: TLMNotify absolute AMsg; 193 Code: Integer; 194 begin 195 // call the old WindowProc of ListView 196 FOldListViewWindowProc(AMsg); 197 198 // Currently we care only with WM_NOTIFY message 199 if AMsg.Msg = WM_NOTIFY then 200 begin 201 Code := NMHDR(PHDNotify(vMsgNotify.NMHdr)^.Hdr).Code; 202 case Code of 203 HDN_ENDTRACKA, HDN_ENDTRACKW: 204 DoColumnResized(PHDNotify(vMsgNotify.NMHdr)^.Item); 205 206 HDN_BEGINTRACKA, HDN_BEGINTRACKW: 207 DoColumnBeginResize(PHDNotify(vMsgNotify.NMHdr)^.Item); 208 209 HDN_TRACKA, HDN_TRACKW: 210 begin 211 vColWidth := -1; 212 if (PHDNotify(vMsgNotify.NMHdr)^.PItem<>nil) 213 and (PHDNotify(vMsgNotify.NMHdr)^.PItem^.Mask and HDI_WIDTH <> 0) 214 then 215 vColWidth := PHDNotify(vMsgNotify.NMHdr)^.PItem^.cxy; 216 217 DoColumnResizing(PHDNotify(vMsgNotify.NMHdr)^.Item, vColWidth); 218 end; 219 end; 220 end; 221 end; 222 {$ENDIF} 223 224 procedure TListViewSort.DoColumnBeginResize(const AColIndex: Integer); 225 begin 226 end; 227 228 procedure TListViewSort.DoColumnResizing(const AColIndex, AWidth: Integer); 229 begin 230 end; 231 232 procedure TListViewSort.DoColumnResized(const AColIndex: Integer); 233 begin 234 if Assigned(FOnColumnWidthChanged) then 235 FOnColumnWidthChanged(Self); 236 end; 155 237 156 238 procedure TListViewSort.ColumnClick(Sender: TObject; Column: TListColumn); … … 179 261 procedure TListViewSort.SetListView(const Value: TListView); 180 262 begin 263 if FListView = Value then Exit; 264 if Assigned(FListView) then 265 ListView.WindowProc := FOldListViewWindowProc; 181 266 FListView := Value; 182 267 FListView.OnColumnClick := ColumnClick; 183 268 FListView.OnCustomDrawItem := ListViewCustomDrawItem; 184 269 FListView.OnClick := ListViewClick; 270 FOldListViewWindowProc := FListView.WindowProc; 271 {$IFDEF WINDOWS} 272 FListView.WindowProc := NewListViewWindowProc; 273 {$ENDIF} 185 274 end; 186 275 … … 199 288 if ListView.Items.Count <> List.Count then 200 289 ListView.Items.Count := List.Count; 201 if Assigned(FOnCompareItem) then Sort(FOnCompareItem);290 if Assigned(FOnCompareItem) and (Order <> soNone) then Sort(FOnCompareItem); 202 291 //ListView.Items[-1]; // Workaround for not show first row if selected 203 292 ListView.Refresh; … … 266 355 TP1: TPoint; 267 356 XBias, YBias: Integer; 268 OldColor: TColor; 357 PenColor: TColor; 358 BrushColor: TColor; 269 359 BiasTop, BiasLeft: Integer; 270 360 Rect1: TRect; … … 278 368 Item.Left := 0; 279 369 GetCheckBias(XBias, YBias, BiasTop, BiasLeft, ListView); 280 OldColor := ListView.Canvas.Pen.Color; 370 PenColor := ListView.Canvas.Pen.Color; 371 BrushColor := ListView.Canvas.Brush.Color; 281 372 //TP1 := Item.GetPosition; 282 373 lRect := Item.DisplayRect(drBounds); // Windows 7 workaround … … 321 412 end; 322 413 //ListView.Canvas.Brush.Color := ListView.Color; 323 ListView.Canvas.Brush.Color := clWindow;324 ListView.Canvas.Pen.Color := OldColor;414 ListView.Canvas.Brush.Color := BrushColor; 415 ListView.Canvas.Pen.Color := PenColor; 325 416 end; 326 417 -
trunk/Packages/Common/UMemory.pas
r10 r15 24 24 constructor Create; 25 25 destructor Destroy; override; 26 procedure WriteMemory(Position: Integer; Memory: TMemory); 27 procedure ReadMemory(Position: Integer; Memory: TMemory); 26 28 property Data: PByte read FData; 27 29 property Size: Integer read FSize write SetSize; … … 108 110 end; 109 111 112 procedure TMemory.WriteMemory(Position: Integer; Memory: TMemory); 113 begin 114 Move(Memory.FData, PByte(@FData + Position)^, Memory.Size); 115 end; 116 117 procedure TMemory.ReadMemory(Position: Integer; Memory: TMemory); 118 begin 119 Move(PByte(@FData + Position)^, Memory.FData, Memory.Size); 120 end; 121 110 122 end. 111 123 -
trunk/Packages/Common/UPersistentForm.pas
r10 r15 3 3 {$mode delphi} 4 4 5 // Date: 201 0-06-015 // Date: 2015-04-18 6 6 7 7 interface 8 8 9 9 uses 10 Classes, SysUtils, Forms, URegistry, LCLIntf, Registry ;10 Classes, SysUtils, Forms, URegistry, LCLIntf, Registry, Controls, ComCtrls; 11 11 12 12 type … … 19 19 FMinVisiblePart: Integer; 20 20 FRegistryContext: TRegistryContext; 21 procedure LoadControl(Control: TControl); 22 procedure SaveControl(Control: TControl); 21 23 public 24 FormNormalSize: TRect; 25 FormRestoredSize: TRect; 26 FormWindowState: TWindowState; 27 Form: TForm; 28 procedure LoadFromRegistry(RegistryContext: TRegistryContext); 29 procedure SaveToRegistry(RegistryContext: TRegistryContext); 22 30 function CheckEntireVisible(Rect: TRect): TRect; 23 31 function CheckPartVisible(Rect: TRect; Part: Integer): TRect; … … 44 52 { TPersistentForm } 45 53 54 procedure TPersistentForm.LoadControl(Control: TControl); 55 var 56 I: Integer; 57 WinControl: TWinControl; 58 Count: Integer; 59 begin 60 if Control is TListView then begin 61 with Form, TRegistryEx.Create do 62 try 63 RootKey := RegistryContext.RootKey; 64 OpenKey(RegistryContext.Key + '\Forms\' + Form.Name + '\' + Control.Name, True); 65 for I := 0 to TListView(Control).Columns.Count - 1 do begin 66 if ValueExists('ColWidth' + IntToStr(I)) then 67 TListView(Control).Columns[I].Width := ReadInteger('ColWidth' + IntToStr(I)); 68 end; 69 finally 70 Free; 71 end; 72 end; 73 74 if Control is TWinControl then begin 75 WinControl := TWinControl(Control); 76 if WinControl.ControlCount > 0 then begin 77 for I := 0 to WinControl.ControlCount - 1 do begin 78 if WinControl.Controls[I] is TControl then begin 79 LoadControl(WinControl.Controls[I]); 80 end; 81 end; 82 end; 83 end; 84 end; 85 86 procedure TPersistentForm.SaveControl(Control: TControl); 87 var 88 I: Integer; 89 WinControl: TWinControl; 90 begin 91 if Control is TListView then begin 92 with Form, TRegistryEx.Create do 93 try 94 RootKey := RegistryContext.RootKey; 95 OpenKey(RegistryContext.Key + '\Forms\' + Form.Name + '\' + Control.Name, True); 96 for I := 0 to TListView(Control).Columns.Count - 1 do begin 97 WriteInteger('ColWidth' + IntToStr(I), TListView(Control).Columns[I].Width); 98 end; 99 finally 100 Free; 101 end; 102 end; 103 104 if Control is TWinControl then begin 105 WinControl := TWinControl(Control); 106 if WinControl.ControlCount > 0 then begin 107 for I := 0 to WinControl.ControlCount - 1 do begin 108 if WinControl.Controls[I] is TControl then begin 109 SaveControl(WinControl.Controls[I]); 110 end; 111 end; 112 end; 113 end; 114 end; 115 116 procedure TPersistentForm.LoadFromRegistry(RegistryContext: TRegistryContext); 117 begin 118 with TRegistryEx.Create do 119 try 120 RootKey := RegistryContext.RootKey; 121 OpenKey(RegistryContext.Key + '\Forms\' + Form.Name, True); 122 // Normal size 123 FormNormalSize.Left := ReadIntegerWithDefault('NormalLeft', FormNormalSize.Left); 124 FormNormalSize.Top := ReadIntegerWithDefault('NormalTop', FormNormalSize.Top); 125 FormNormalSize.Right := ReadIntegerWithDefault('NormalWidth', FormNormalSize.Right - FormNormalSize.Left) 126 + FormNormalSize.Left; 127 FormNormalSize.Bottom := ReadIntegerWithDefault('NormalHeight', FormNormalSize.Bottom - FormNormalSize.Top) 128 + FormNormalSize.Top; 129 // Restored size 130 FormRestoredSize.Left := ReadIntegerWithDefault('RestoredLeft', FormRestoredSize.Left); 131 FormRestoredSize.Top := ReadIntegerWithDefault('RestoredTop', FormRestoredSize.Top); 132 FormRestoredSize.Right := ReadIntegerWithDefault('RestoredWidth', FormRestoredSize.Right - FormRestoredSize.Left) 133 + FormRestoredSize.Left; 134 FormRestoredSize.Bottom := ReadIntegerWithDefault('RestoredHeight', FormRestoredSize.Bottom - FormRestoredSize.Top) 135 + FormRestoredSize.Top; 136 // Other state 137 FormWindowState := TWindowState(ReadIntegerWithDefault('WindowState', Integer(wsNormal))); 138 finally 139 Free; 140 end; 141 end; 142 143 procedure TPersistentForm.SaveToRegistry(RegistryContext: TRegistryContext); 144 begin 145 with Form, TRegistryEx.Create do 146 try 147 RootKey := RegistryContext.RootKey; 148 OpenKey(RegistryContext.Key + '\Forms\' + Form.Name, True); 149 // Normal state 150 WriteInteger('NormalWidth', FormNormalSize.Right - FormNormalSize.Left); 151 WriteInteger('NormalHeight', FormNormalSize.Bottom - FormNormalSize.Top); 152 WriteInteger('NormalTop', FormNormalSize.Top); 153 WriteInteger('NormalLeft', FormNormalSize.Left); 154 // Restored state 155 WriteInteger('RestoredWidth', FormRestoredSize.Right - FormRestoredSize.Left); 156 WriteInteger('RestoredHeight', FormRestoredSize.Bottom - FormRestoredSize.Top); 157 WriteInteger('RestoredTop', FormRestoredSize.Top); 158 WriteInteger('RestoredLeft', FormRestoredSize.Left); 159 // Other state 160 WriteInteger('WindowState', Integer(FormWindowState)); 161 finally 162 Free; 163 end; 164 end; 165 46 166 function TPersistentForm.CheckEntireVisible(Rect: TRect): TRect; 47 167 var … … 98 218 procedure TPersistentForm.Load(Form: TForm; DefaultMaximized: Boolean = False); 99 219 var 100 Normal: TRect;101 Restored: TRect;102 220 LoadDefaults: Boolean; 103 221 begin 104 with TRegistryEx.Create do 105 try 106 RootKey := RegistryContext.RootKey; 107 OpenKey(RegistryContext.Key + '\Forms\' + Form.Name, True); 108 109 //RestoredWindowState := TWindowState(ReadIntegerWithDefault('WindowState', Integer(Form.WindowState))); 110 //if RestoredWindowState = wsMinimized then 111 // RestoredWindowState := wsNormal; 112 //Form.WindowState := RestoredWindowState; 113 LoadDefaults := not ValueExists('NormalLeft'); 114 Normal := Bounds(ReadIntegerWithDefault('NormalLeft', (Screen.Width - Form.Width) div 2), 115 ReadIntegerWithDefault('NormalTop', (Screen.Height - Form.Height) div 2), 116 ReadIntegerWithDefault('NormalWidth', Form.Width), 117 ReadIntegerWithDefault('NormalHeight', Form.Height)); 118 Restored := Bounds(ReadIntegerWithDefault('RestoredLeft', (Screen.Width - Form.Width) div 2), 119 ReadIntegerWithDefault('RestoredTop', (Screen.Height - Form.Height) div 2), 120 ReadIntegerWithDefault('RestoredWidth', Form.Width), 121 ReadIntegerWithDefault('RestoredHeight', Form.Height)); 122 123 if not EqualRect(Normal, Restored) or 124 (LoadDefaults and DefaultMaximized) then begin 125 // Restore to maximized state 126 Form.WindowState := wsNormal; 127 if not EqualRect(Restored, Form.BoundsRect) then 128 Form.BoundsRect := Restored; 129 Form.WindowState := wsMaximized; 130 end else begin 131 // Restore to normal state 132 Form.WindowState := wsNormal; 133 if FEntireVisible then Normal := CheckEntireVisible(Normal) 134 else if FMinVisiblePart > 0 then 135 Normal := CheckPartVisible(Normal, FMinVisiblePart); 136 if not EqualRect(Normal, Form.BoundsRect) then 137 Form.BoundsRect := Normal; 138 end; 139 140 //if ReadBoolWithDefault('Visible', False) then Form.Show; 141 finally 142 Free; 143 end; 222 Self.Form := Form; 223 // Set default 224 FormNormalSize := Bounds((Screen.Width - Form.Width) div 2, 225 (Screen.Height - Form.Height) div 2, Form.Width, Form.Height); 226 FormRestoredSize := Bounds((Screen.Width - Form.Width) div 2, 227 (Screen.Height - Form.Height) div 2, Form.Width, Form.Height); 228 229 LoadFromRegistry(RegistryContext); 230 231 if not EqualRect(FormNormalSize, FormRestoredSize) or 232 (LoadDefaults and DefaultMaximized) then begin 233 // Restore to maximized state 234 Form.WindowState := wsNormal; 235 if not EqualRect(FormRestoredSize, Form.BoundsRect) then 236 Form.BoundsRect := FormRestoredSize; 237 Form.WindowState := wsMaximized; 238 end else begin 239 // Restore to normal state 240 Form.WindowState := wsNormal; 241 if FEntireVisible then FormNormalSize := CheckEntireVisible(FormNormalSize) 242 else if FMinVisiblePart > 0 then 243 FormNormalSize := CheckPartVisible(FormNormalSize, FMinVisiblePart); 244 if not EqualRect(FormNormalSize, Form.BoundsRect) then 245 Form.BoundsRect := FormNormalSize; 246 end; 247 LoadControl(Form); 144 248 end; 145 249 146 250 procedure TPersistentForm.Save(Form: TForm); 147 251 begin 148 with Form, TRegistryEx.Create do 149 try 150 RootKey := RegistryContext.RootKey; 151 OpenKey(RegistryContext.Key + '\Forms\' + Form.Name, True); 152 WriteInteger('NormalWidth', Form.Width); 153 WriteInteger('NormalHeight', Form.Height); 154 WriteInteger('NormalTop', Form.Top); 155 WriteInteger('NormalLeft', Form.Left); 156 WriteInteger('RestoredWidth', Form.RestoredWidth); 157 WriteInteger('RestoredHeight', Form.RestoredHeight); 158 WriteInteger('RestoredTop', Form.RestoredTop); 159 WriteInteger('RestoredLeft', Form.RestoredLeft); 160 //WriteInteger('WindowState', Integer(Form.WindowState)); 161 //WriteBool('Visible', Form.Visible); 162 finally 163 Free; 164 end; 252 Self.Form := Form; 253 FormNormalSize := Bounds(Form.Left, Form.Top, Form.Width, Form.Height); 254 FormRestoredSize := Bounds(Form.RestoredLeft, Form.RestoredTop, Form.RestoredWidth, 255 Form.RestoredHeight); 256 FormWindowState := Form.WindowState; 257 SaveToRegistry(RegistryContext); 258 SaveControl(Form); 165 259 end; 166 260 … … 168 262 begin 169 263 inherited; 264 if AOwner is TForm then Form := TForm(AOwner) 265 else Form := nil; 170 266 FMinVisiblePart := 50; 171 267 FRegistryContext.RootKey := HKEY_CURRENT_USER; -
trunk/Packages/Common/URegistry.pas
r10 r15 9 9 10 10 type 11 TRegistryRoot = (rrKeyClassesRoot = HKEY($80000000), 12 rrKeyCurrentUser = HKEY($80000001), 13 rrKeyLocalMachine = HKEY($80000002), 14 rrKeyUsers = HKEY($80000003), 15 rrKeyPerformanceData = HKEY($80000004), 16 rrKeyCurrentConfig = HKEY($80000005), 17 rrKeyDynData = HKEY($80000006)); 11 TRegistryRoot = (rrKeyClassesRoot, rrKeyCurrentUser, rrKeyLocalMachine, 12 rrKeyUsers, rrKeyPerformanceData, rrKeyCurrentConfig, rrKeyDynData); 18 13 19 14 { TRegistryContext } … … 23 18 Key: string; 24 19 class operator Equal(A, B: TRegistryContext): Boolean; 20 function Create(RootKey: TRegistryRoot; Key: string): TRegistryContext; overload; 21 function Create(RootKey: HKEY; Key: string): TRegistryContext; overload; 25 22 end; 26 23 … … 43 40 end; 44 41 45 function RegContext(RootKey: HKEY; Key: string): TRegistryContext; 46 42 const 43 RegistryRootHKEY: array[TRegistryRoot] of HKEY = (HKEY_CLASSES_ROOT, 44 HKEY_CURRENT_USER, HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_PERFORMANCE_DATA, 45 HKEY_CURRENT_CONFIG, HKEY_DYN_DATA); 47 46 48 47 implementation 49 48 50 function RegContext(RootKey: HKEY; Key: string): TRegistryContext;51 begin52 Result.RootKey := RootKey;53 Result.Key := Key;54 end;55 49 56 50 { TRegistryContext } … … 59 53 begin 60 54 Result := (A.Key = B.Key) and (A.RootKey = B.RootKey); 55 end; 56 57 function TRegistryContext.Create(RootKey: TRegistryRoot; Key: string): TRegistryContext; 58 begin 59 Result.RootKey := RegistryRootHKEY[RootKey]; 60 Result.Key := Key; 61 end; 62 63 function TRegistryContext.Create(RootKey: HKEY; Key: string): TRegistryContext; 64 begin 65 Result.RootKey := RootKey; 66 Result.Key := Key; 61 67 end; 62 68 -
trunk/Packages/Common/UScaleDPI.pas
r10 r15 17 17 TControlDimension = class 18 18 BoundsRect: TRect; 19 AuxSize: TPoint;20 19 FontHeight: Integer; 21 20 Controls: TObjectList; // TList<TControlDimension> 21 // Class specifics 22 ButtonSize: TPoint; // TToolBar 23 CoolBandWidth: Integer; 24 ConstraintsMin: TPoint; // TForm 25 ConstraintsMax: TPoint; // TForm 22 26 constructor Create; 23 27 destructor Destroy; override; … … 74 78 destructor TControlDimension.Destroy; 75 79 begin 76 Controls.Free;80 FreeAndNil(Controls); 77 81 inherited Destroy; 78 82 end; … … 113 117 Dimensions.Controls.Clear; 114 118 if Control is TToolBar then 115 Dimensions.AuxSize := Point(TToolBar(Control).ButtonWidth, TToolBar(Control).ButtonHeight); 116 119 Dimensions.ButtonSize := Point(TToolBar(Control).ButtonWidth, TToolBar(Control).ButtonHeight); 120 if Control is TForm then begin 121 Dimensions.ConstraintsMin := Point(TForm(Control).Constraints.MinWidth, 122 TForm(Control).Constraints.MinHeight); 123 Dimensions.ConstraintsMax := Point(TForm(Control).Constraints.MaxWidth, 124 TForm(Control).Constraints.MaxHeight); 125 end; 117 126 if Control is TWinControl then 118 127 for I := 0 to TWinControl(Control).ControlCount - 1 do begin 119 if TWinControl(Control).Controls[I] is TControl then begin 128 if TWinControl(Control).Controls[I] is TControl then 129 // Do not scale docked forms twice 130 if not (TWinControl(Control).Controls[I] is TForm) then begin 120 131 NewControl := TControlDimension.Create; 121 132 Dimensions.Controls.Add(NewControl); … … 133 144 Control.Font.Height := Dimensions.FontHeight; 134 145 if Control is TToolBar then begin 135 TToolBar(Control).ButtonWidth := Dimensions.AuxSize.X; 136 TToolBar(Control).ButtonHeight := Dimensions.AuxSize.Y; 146 TToolBar(Control).ButtonWidth := Dimensions.ButtonSize.X; 147 TToolBar(Control).ButtonHeight := Dimensions.ButtonSize.Y; 148 end; 149 if Control is TForm then begin 150 TForm(Control).Constraints.MinWidth := Dimensions.ConstraintsMin.X; 151 TForm(Control).Constraints.MinHeight := Dimensions.ConstraintsMin.Y; 152 TForm(Control).Constraints.MaxWidth := Dimensions.ConstraintsMax.X; 153 TForm(Control).Constraints.MaxHeight := Dimensions.ConstraintsMax.Y; 137 154 end; 138 155 if Control is TWinControl then 139 156 for I := 0 to TWinControl(Control).ControlCount - 1 do begin 140 if TWinControl(Control).Controls[I] is TControl then begin 157 if TWinControl(Control).Controls[I] is TControl then 158 // Do not scale docked forms twice 159 if not (TWinControl(Control).Controls[I] is TForm) then begin 141 160 RestoreDimensions(TWinControl(Control).Controls[I], TControlDimension(Dimensions.Controls[I])); 142 161 end; … … 152 171 Control.Font.Height := ScaleY(Dimensions.FontHeight, DesignDPI.Y); 153 172 if Control is TToolBar then begin 154 TToolBar(Control).ButtonWidth := ScaleX(Dimensions.AuxSize.X, DesignDPI.X); 155 TToolBar(Control).ButtonHeight := ScaleY(Dimensions.AuxSize.Y, DesignDPI.Y); 173 TToolBar(Control).ButtonWidth := ScaleX(Dimensions.ButtonSize.X, DesignDPI.X); 174 TToolBar(Control).ButtonHeight := ScaleY(Dimensions.ButtonSize.Y, DesignDPI.Y); 175 end; 176 if Control is TCoolBar then begin 177 with TCoolBar(Control) do 178 for I := 0 to Bands.Count - 1 do 179 with TCoolBand(Bands[I]) do begin 180 MinWidth := ScaleX(Dimensions.ButtonSize.X, DesignDPI.X); 181 MinHeight := ScaleY(Dimensions.ButtonSize.Y, DesignDPI.Y); 182 //Width := ScaleX(Dimensions.BoundsRect.Left - 183 end; 184 end; 185 if Control is TForm then begin 186 TForm(Control).Constraints.MinWidth := ScaleX(Dimensions.ConstraintsMin.X, DesignDPI.X); 187 TForm(Control).Constraints.MaxWidth := ScaleX(Dimensions.ConstraintsMax.X, DesignDPI.X); 188 TForm(Control).Constraints.MinHeight := ScaleY(Dimensions.ConstraintsMin.Y, DesignDPI.Y); 189 TForm(Control).Constraints.MaxHeight := ScaleY(Dimensions.ConstraintsMax.Y, DesignDPI.Y); 156 190 end; 157 191 if Control is TWinControl then 158 192 for I := 0 to TWinControl(Control).ControlCount - 1 do begin 159 if TWinControl(Control).Controls[I] is TControl then begin 193 if TWinControl(Control).Controls[I] is TControl then 194 // Do not scale docked forms twice 195 if not (TWinControl(Control).Controls[I] is TForm) then begin 160 196 ScaleDimensions(TWinControl(Control).Controls[I], TControlDimension(Dimensions.Controls[I])); 161 197 end; … … 183 219 184 220 SetLength(Temp, ImgList.Count); 185 TempBmp := TBitmap.Create;186 221 for I := 0 to ImgList.Count - 1 do 187 222 begin 223 TempBmp := TBitmap.Create; 224 TempBmp.PixelFormat := pf32bit; 188 225 ImgList.GetBitmap(I, TempBmp); 189 //TempBmp.PixelFormat := pfDevice;190 226 Temp[I] := TBitmap.Create; 191 227 Temp[I].SetSize(NewWidth, NewHeight); 228 Temp[I].PixelFormat := pf32bit; 192 229 Temp[I].TransparentColor := TempBmp.TransparentColor; 193 230 //Temp[I].TransparentMode := TempBmp.TransparentMode; … … 199 236 if (Temp[I].Width = 0) or (Temp[I].Height = 0) then Continue; 200 237 Temp[I].Canvas.StretchDraw(Rect(0, 0, Temp[I].Width, Temp[I].Height), TempBmp); 201 end;202 TempBmp.Free;238 TempBmp.Free; 239 end; 203 240 204 241 ImgList.Clear; … … 272 309 end; 273 310 274 311 if Control is TCoolBar then 312 with TCoolBar(Control) do begin 313 BeginUpdate; 314 for I := 0 to Bands.Count - 1 do 315 with Bands[I] do begin 316 MinWidth := ScaleX(MinWidth, FromDPI.X); 317 MinHeight := ScaleY(MinHeight, FromDPI.Y); 318 Width := ScaleX(Width, FromDPI.X); 319 //Control.Invalidate; 320 end; 321 EndUpdate; 322 end; 275 323 276 324 if Control is TToolBar then begin -
trunk/Packages/Common/UXMLUtils.pas
r10 r15 12 12 function DateTimeToXMLTime(Value: TDateTime; ApplyLocalBias: Boolean = True): WideString; 13 13 procedure WriteInteger(Node: TDOMNode; Name: string; Value: Integer); 14 procedure WriteInt64(Node: TDOMNode; Name: string; Value: Int64); 14 15 procedure WriteBoolean(Node: TDOMNode; Name: string; Value: Boolean); 15 16 procedure WriteString(Node: TDOMNode; Name: string; Value: string); 17 procedure WriteDateTime(Node: TDOMNode; Name: string; Value: TDateTime); 16 18 function ReadInteger(Node: TDOMNode; Name: string; DefaultValue: Integer): Integer; 19 function ReadInt64(Node: TDOMNode; Name: string; DefaultValue: Int64): Int64; 17 20 function ReadBoolean(Node: TDOMNode; Name: string; DefaultValue: Boolean): Boolean; 18 21 function ReadString(Node: TDOMNode; Name: string; DefaultValue: string): string; 22 function ReadDateTime(Node: TDOMNode; Name: string; DefaultValue: TDateTime): TDateTime; 19 23 20 24 … … 72 76 Minute: Integer; 73 77 Second: Integer; 78 SecondFraction: Double; 74 79 Millisecond: Integer; 75 80 begin … … 94 99 if Pos('Z', XMLDateTime) > 0 then 95 100 LeftCutString(XMLDateTime, Part, 'Z'); 96 Millisecond := StrToInt(Part); 101 SecondFraction := StrToFloat('0' + DecimalSeparator + Part); 102 Millisecond := Trunc(SecondFraction * 1000); 97 103 end else begin 98 104 if Pos('+', XMLDateTime) > 0 then … … 138 144 end; 139 145 146 procedure WriteInt64(Node: TDOMNode; Name: string; Value: Int64); 147 var 148 NewNode: TDOMNode; 149 begin 150 NewNode := Node.OwnerDocument.CreateElement(Name); 151 NewNode.TextContent := IntToStr(Value); 152 Node.AppendChild(NewNode); 153 end; 154 140 155 procedure WriteBoolean(Node: TDOMNode; Name: string; Value: Boolean); 141 156 var … … 156 171 end; 157 172 173 procedure WriteDateTime(Node: TDOMNode; Name: string; Value: TDateTime); 174 var 175 NewNode: TDOMNode; 176 begin 177 NewNode := Node.OwnerDocument.CreateElement(Name); 178 NewNode.TextContent := DateTimeToXMLTime(Value); 179 Node.AppendChild(NewNode); 180 end; 181 158 182 function ReadInteger(Node: TDOMNode; Name: string; DefaultValue: Integer): Integer; 159 183 var … … 166 190 end; 167 191 192 function ReadInt64(Node: TDOMNode; Name: string; DefaultValue: Int64): Int64; 193 var 194 NewNode: TDOMNode; 195 begin 196 Result := DefaultValue; 197 NewNode := Node.FindNode(Name); 198 if Assigned(NewNode) then 199 Result := StrToInt64(NewNode.TextContent); 200 end; 201 168 202 function ReadBoolean(Node: TDOMNode; Name: string; DefaultValue: Boolean): Boolean; 169 203 var … … 186 220 end; 187 221 222 function ReadDateTime(Node: TDOMNode; Name: string; DefaultValue: TDateTime 223 ): TDateTime; 224 var 225 NewNode: TDOMNode; 226 begin 227 Result := DefaultValue; 228 NewNode := Node.FindNode(Name); 229 if Assigned(NewNode) then 230 Result := XMLTimeToDateTime(NewNode.TextContent); 231 end; 232 188 233 end. 189 234
Note:
See TracChangeset
for help on using the changeset viewer.