Changeset 38 for trunk/Packages
- Timestamp:
- May 10, 2018, 9:39:53 AM (7 years ago)
- Location:
- trunk/Packages/Common
- Files:
-
- 2 added
- 20 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/Packages/Common/Common.lpk
r28 r38 11 11 <PathDelim Value="\"/> 12 12 <SearchPaths> 13 <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS) "/>13 <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)-$(BuildMode)"/> 14 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> 15 38 </CompilerOptions> 16 39 <Description Value="Various libraries"/> 17 40 <License Value="GNU/GPL"/> 18 41 <Version Minor="7"/> 19 <Files Count="2 0">42 <Files Count="22"> 20 43 <Item1> 21 44 <Filename Value="StopWatch.pas"/> … … 106 129 <UnitName Value="UScaleDPI"/> 107 130 </Item20> 131 <Item21> 132 <Filename Value="UTheme.pas"/> 133 <HasRegisterProc Value="True"/> 134 <UnitName Value="UTheme"/> 135 </Item21> 136 <Item22> 137 <Filename Value="UStringTable.pas"/> 138 <UnitName Value="UStringTable"/> 139 </Item22> 108 140 </Files> 109 141 <i18n> -
trunk/Packages/Common/Common.pas
r28 r38 5 5 unit Common; 6 6 7 {$warn 5023 off : no warning about unused units} 7 8 interface 8 9 … … 11 12 UMemory, UResetableThread, UPool, ULastOpenedList, URegistry, 12 13 UJobProgressView, UXMLUtils, UApplicationInfo, USyncCounter, UListViewSort, 13 UPersistentForm, UFindFile, UScaleDPI, LazarusPackageIntf; 14 UPersistentForm, UFindFile, UScaleDPI, UTheme, UStringTable, 15 LazarusPackageIntf; 14 16 15 17 implementation … … 25 27 RegisterUnit('UFindFile', @UFindFile.Register); 26 28 RegisterUnit('UScaleDPI', @UScaleDPI.Register); 29 RegisterUnit('UTheme', @UTheme.Register); 27 30 end; 28 31 -
trunk/Packages/Common/Languages/UJobProgressView.cs.po
r29 r38 25 25 26 26 #: ujobprogressview.soperations 27 msgid "Operations "28 msgstr " Operace"27 msgid "Operations:" 28 msgstr "" 29 29 30 30 #: ujobprogressview.spleasewait -
trunk/Packages/Common/Languages/UJobProgressView.po
r28 r38 15 15 16 16 #: ujobprogressview.soperations 17 msgid "Operations "17 msgid "Operations:" 18 18 msgstr "" 19 19 -
trunk/Packages/Common/UApplicationInfo.pas
r28 r38 6 6 7 7 uses 8 SysUtils, Registry, Classes, Forms, URegistry;8 SysUtils, Classes, Forms, URegistry, Controls; 9 9 10 10 type … … 14 14 TApplicationInfo = class(TComponent) 15 15 private 16 FDescription: TCaption; 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; … … 54 57 55 58 implementation 56 59 57 60 procedure Register; 58 61 begin … … 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
r28 r38 28 28 unfDNSDomainName = 11); 29 29 30 TFilterMethodMethod = function (FileName: string): Boolean of object; 30 31 var 31 32 ExceptionHandler: TExceptionEvent; … … 63 64 procedure OpenWebPage(URL: string); 64 65 procedure OpenFileInShell(FileName: string); 65 procedure ExecuteProgram( CommandLine:string);66 procedure ExecuteProgram(Executable: string; Parameters: array of string); 66 67 procedure FreeThenNil(var Obj); 67 68 function RemoveQuotes(Text: string): string; … … 71 72 function MergeArray(A, B: array of string): TArrayOfString; 72 73 function LoadFileToStr(const FileName: TFileName): AnsiString; 74 procedure SearchFiles(AList: TStrings; Dir: string; 75 FilterMethod: TFilterMethodMethod); 76 function GetStringPart(var Text: string; Separator: string): string; 73 77 74 78 … … 112 116 Path := IncludeTrailingPathDelimiter(APath); 113 117 114 Find := FindFirst( UTF8Decode(Path + AFileSpec), faAnyFile xor faDirectory, SearchRec);118 Find := FindFirst(Path + AFileSpec, faAnyFile xor faDirectory, SearchRec); 115 119 while Find = 0 do begin 116 DeleteFile(Path + UTF8Encode(SearchRec.Name));120 DeleteFile(Path + SearchRec.Name); 117 121 118 122 Find := SysUtils.FindNext(SearchRec); … … 429 433 end; 430 434 431 procedure ExecuteProgram( CommandLine:string);435 procedure ExecuteProgram(Executable: string; Parameters: array of string); 432 436 var 433 437 Process: TProcess; 438 I: Integer; 434 439 begin 435 440 try 436 441 Process := TProcess.Create(nil); 437 Process.CommandLine := CommandLine; 442 Process.Executable := Executable; 443 for I := 0 to Length(Parameters) - 1 do 444 Process.Parameters.Add(Parameters[I]); 438 445 Process.Options := [poNoConsole]; 439 446 Process.Execute; … … 456 463 procedure OpenFileInShell(FileName: string); 457 464 begin 458 ExecuteProgram('cmd.exe /c start "' + FileName + '"');465 ExecuteProgram('cmd.exe', ['/c', 'start', FileName]); 459 466 end; 460 467 … … 511 518 end; 512 519 520 function DefaultSearchFilter(const FileName: string): Boolean; 521 begin 522 Result := True; 523 end; 524 525 procedure SearchFiles(AList: TStrings; Dir: string; 526 FilterMethod: TFilterMethodMethod); 527 var 528 SR: TSearchRec; 529 begin 530 Dir := IncludeTrailingPathDelimiter(Dir); 531 if FindFirst(Dir + '*', faAnyFile, SR) = 0 then 532 try 533 repeat 534 if (SR.Name = '.') or (SR.Name = '..') or not FilterMethod(SR.Name) or 535 not FilterMethod(Copy(Dir, 3, Length(Dir)) + SR.Name) then Continue; 536 AList.Add(Dir + SR.Name); 537 if (SR.Attr and faDirectory) <> 0 then 538 SearchFiles(AList, Dir + SR.Name, FilterMethod); 539 until FindNext(SR) <> 0; 540 finally 541 FindClose(SR); 542 end; 543 end; 544 545 function GetStringPart(var Text: string; Separator: string): string; 546 var 547 P: Integer; 548 begin 549 P := Pos(Separator, Text); 550 if P > 0 then begin 551 Result := Copy(Text, 1, P - 1); 552 Delete(Text, 1, P - 1 + Length(Separator)); 553 end else begin 554 Result := Text; 555 Text := ''; 556 end; 557 Result := Trim(Result); 558 Text := Trim(Text); 559 end; 560 513 561 514 562 -
trunk/Packages/Common/UDebugLog.pas
r28 r38 104 104 if ExtractFileDir(FileName) <> '' then 105 105 ForceDirectories(ExtractFileDir(FileName)); 106 if FileExists(FileName) then LogFile := TFileStream.Create( UTF8Decode(FileName), fmOpenWrite)107 else LogFile := TFileStream.Create( UTF8Decode(FileName), fmCreate);106 if FileExists(FileName) then LogFile := TFileStream.Create(FileName, fmOpenWrite) 107 else LogFile := TFileStream.Create(FileName, fmCreate); 108 108 LogFile.Seek(0, soFromEnd); 109 109 Text := FormatDateTime('hh:nn:ss.zzz', Now) + ': ' + Text + LineEnding; -
trunk/Packages/Common/UFindFile.pas
r28 r38 24 24 25 25 uses 26 SysUtils, Classes, Graphics, Controls, Forms, Dialogs , FileCtrl;26 SysUtils, Classes, Graphics, Controls, Forms, Dialogs; 27 27 28 28 type … … 117 117 Attr := 0; 118 118 if ffaReadOnly in FileAttr then Attr := Attr + faReadOnly; 119 if ffaHidden in FileAttr then Attr := Attr + faHidden;120 if ffaSysFile in FileAttr then Attr := Attr + faSysFile;121 if ffaVolumeID in FileAttr then Attr := Attr + faVolumeID;119 if ffaHidden in FileAttr then Attr := Attr + 2; //faHidden; use constant to avoid platform warning 120 if ffaSysFile in FileAttr then Attr := Attr + 4; //faSysFile; use constant to avoid platform warning 121 // Deprecated: if ffaVolumeID in FileAttr then Attr := Attr + faVolumeID; 122 122 if ffaDirectory in FileAttr then Attr := Attr + faDirectory; 123 123 if ffaArchive in FileAttr then Attr := Attr + faArchive; 124 124 if ffaAnyFile in FileAttr then Attr := Attr + faAnyFile; 125 125 126 if SysUtils.FindFirst( UTF8Decode(inPath + FileMask), Attr, Rec) = 0 then126 if SysUtils.FindFirst(inPath + FileMask, Attr, Rec) = 0 then 127 127 try 128 128 repeat 129 s.Add(inPath + UTF8Encode(Rec.Name));129 s.Add(inPath + Rec.Name); 130 130 until SysUtils.FindNext(Rec) <> 0; 131 131 finally … … 135 135 If not InSubFolders then Exit; 136 136 137 if SysUtils.FindFirst( UTF8Decode(inPath + FilterAll), faDirectory, Rec) = 0 then137 if SysUtils.FindFirst(inPath + FilterAll, faDirectory, Rec) = 0 then 138 138 try 139 139 repeat 140 140 if ((Rec.Attr and faDirectory) > 0) and (Rec.Name <> '.') 141 141 and (Rec.Name <> '..') then 142 FileSearch(IncludeTrailingBackslash(inPath + UTF8Encode(Rec.Name)));142 FileSearch(IncludeTrailingBackslash(inPath + Rec.Name)); 143 143 until SysUtils.FindNext(Rec) <> 0; 144 144 finally -
trunk/Packages/Common/UJobProgressView.lfm
r28 r38 1 1 object FormJobProgressView: TFormJobProgressView 2 2 Left = 467 3 Height = 2463 Height = 345 4 4 Top = 252 5 Width = 3285 Width = 539 6 6 BorderIcons = [biSystemMenu] 7 ClientHeight = 246 8 ClientWidth = 328 9 Font.Height = -11 10 Font.Name = 'MS Sans Serif' 7 ClientHeight = 345 8 ClientWidth = 539 9 DesignTimePPI = 120 11 10 OnClose = FormClose 12 11 OnCloseQuery = FormCloseQuery 13 12 OnCreate = FormCreate 14 13 OnDestroy = FormDestroy 14 OnHide = FormHide 15 OnShow = FormShow 15 16 Position = poScreenCenter 16 LCLVersion = '1. 6.0.4'17 LCLVersion = '1.8.2.0' 17 18 object PanelOperationsTitle: TPanel 18 19 Left = 0 19 Height = 2420 Height = 32 20 21 Top = 0 21 Width = 32822 Align = alTop 23 BevelOuter = bvNone 24 ClientHeight = 2425 ClientWidth = 32822 Width = 539 23 Align = alTop 24 BevelOuter = bvNone 25 ClientHeight = 32 26 ClientWidth = 539 26 27 FullRepaint = False 27 28 TabOrder = 0 28 29 object LabelOperation: TLabel 29 30 Left = 8 30 Height = 1331 Height = 20 31 32 Top = 8 32 Width = 6633 Width = 76 33 34 Caption = 'Operations:' 34 Font.Height = -1135 Font.Name = 'MS Sans Serif'36 Font.Style = [fsBold]37 35 ParentColor = False 38 36 ParentFont = False … … 41 39 object PanelLog: TPanel 42 40 Left = 0 43 Height = 1 2244 Top = 12445 Width = 32841 Height = 133 42 Top = 212 43 Width = 539 46 44 Align = alClient 47 45 BevelOuter = bvSpace 48 ClientHeight = 1 2249 ClientWidth = 32846 ClientHeight = 133 47 ClientWidth = 539 50 48 TabOrder = 1 51 49 object MemoLog: TMemo 52 50 Left = 8 53 Height = 1 0651 Height = 117 54 52 Top = 8 55 Width = 31253 Width = 523 56 54 Anchors = [akTop, akLeft, akRight, akBottom] 57 55 ReadOnly = True … … 62 60 object PanelProgress: TPanel 63 61 Left = 0 64 Height = 3865 Top = 5066 Width = 32867 Align = alTop 68 BevelOuter = bvNone 69 ClientHeight = 3870 ClientWidth = 32862 Height = 54 63 Top = 106 64 Width = 539 65 Align = alTop 66 BevelOuter = bvNone 67 ClientHeight = 54 68 ClientWidth = 539 71 69 TabOrder = 2 72 70 object ProgressBarPart: TProgressBar 73 Left = 874 Height = 1775 Top = 1676 Width = 31271 Left = 10 72 Height = 24 73 Top = 24 74 Width = 523 77 75 Anchors = [akTop, akLeft, akRight] 78 76 TabOrder = 0 … … 80 78 object LabelEstimatedTimePart: TLabel 81 79 Left = 8 82 Height = 1380 Height = 20 83 81 Top = -2 84 Width = 7182 Width = 103 85 83 Caption = 'Estimated time:' 86 84 ParentColor = False … … 89 87 object PanelOperations: TPanel 90 88 Left = 0 91 Height = 2692 Top = 2493 Width = 32894 Align = alTop 95 BevelOuter = bvNone 96 ClientHeight = 2697 ClientWidth = 32889 Height = 42 90 Top = 64 91 Width = 539 92 Align = alTop 93 BevelOuter = bvNone 94 ClientHeight = 42 95 ClientWidth = 539 98 96 FullRepaint = False 99 97 TabOrder = 3 100 98 object ListViewJobs: TListView 101 99 Left = 8 102 Height = 16100 Height = 32 103 101 Top = 5 104 Width = 312102 Width = 523 105 103 Anchors = [akTop, akLeft, akRight, akBottom] 106 104 AutoWidthLastColumn = True … … 109 107 Columns = < 110 108 item 111 Width = 312109 Width = 523 112 110 end> 113 111 OwnerData = True … … 122 120 object PanelProgressTotal: TPanel 123 121 Left = 0 124 Height = 36125 Top = 88126 Width = 328127 Align = alTop 128 BevelOuter = bvNone 129 ClientHeight = 36130 ClientWidth = 328122 Height = 52 123 Top = 160 124 Width = 539 125 Align = alTop 126 BevelOuter = bvNone 127 ClientHeight = 52 128 ClientWidth = 539 131 129 TabOrder = 4 132 130 object LabelEstimatedTimeTotal: TLabel 133 131 Left = 8 134 Height = 13132 Height = 20 135 133 Top = 0 136 Width = 97134 Width = 141 137 135 Caption = 'Total estimated time:' 138 136 ParentColor = False … … 140 138 object ProgressBarTotal: TProgressBar 141 139 Left = 8 142 Height = 16143 Top = 16144 Width = 312140 Height = 24 141 Top = 24 142 Width = 523 145 143 Anchors = [akTop, akLeft, akRight] 146 144 TabOrder = 0 145 end 146 end 147 object PanelText: TPanel 148 Left = 0 149 Height = 32 150 Top = 32 151 Width = 539 152 Align = alTop 153 BevelOuter = bvNone 154 ClientHeight = 32 155 ClientWidth = 539 156 TabOrder = 5 157 object LabelText: TLabel 158 Left = 8 159 Height = 24 160 Top = 8 161 Width = 525 162 Anchors = [akTop, akLeft, akRight] 163 AutoSize = False 164 ParentColor = False 147 165 end 148 166 end -
trunk/Packages/Common/UJobProgressView.pas
r28 r38 7 7 uses 8 8 SysUtils, Variants, Classes, Graphics, Controls, Forms, Syncobjs, 9 Dialogs, ComCtrls, StdCtrls, ExtCtrls, Contnrs, UThreading, 9 Dialogs, ComCtrls, StdCtrls, ExtCtrls, Contnrs, UThreading, Math, 10 10 DateUtils; 11 11 … … 13 13 EstimatedTimeShowTreshold = 4; 14 14 EstimatedTimeShowTresholdTotal = 1; 15 MemoLogHeight = 200;16 15 UpdateInterval = 100; // ms 17 16 … … 24 23 FLock: TCriticalSection; 25 24 FOnChange: TNotifyEvent; 25 FText: string; 26 26 FValue: Integer; 27 27 FMax: Integer; 28 28 procedure SetMax(const AValue: Integer); 29 procedure SetText(AValue: string); 29 30 procedure SetValue(const AValue: Integer); 30 31 public … … 35 36 property Value: Integer read FValue write SetValue; 36 37 property Max: Integer read FMax write SetMax; 38 property Text: string read FText write SetText; 37 39 property OnChange: TNotifyEvent read FOnChange write FOnChange; 38 40 end; … … 69 71 end; 70 72 73 TJobs = class(TObjectList) 74 end; 75 71 76 TJobThread = class(TListedThread) 72 77 procedure Execute; override; … … 80 85 TFormJobProgressView = class(TForm) 81 86 ImageList1: TImageList; 87 LabelText: TLabel; 82 88 Label2: TLabel; 83 89 LabelOperation: TLabel; … … 86 92 ListViewJobs: TListView; 87 93 MemoLog: TMemo; 94 PanelText: TPanel; 88 95 PanelProgressTotal: TPanel; 89 96 PanelOperationsTitle: TPanel; … … 94 101 ProgressBarTotal: TProgressBar; 95 102 TimerUpdate: TTimer; 103 procedure FormHide(Sender: TObject); 104 procedure FormShow(Sender: TObject); 105 procedure ReloadJobList; 96 106 procedure FormClose(Sender: TObject; var CloseAction: TCloseAction); 97 107 procedure FormDestroy(Sender: TObject); … … 100 110 procedure FormCreate(Sender: TObject); 101 111 procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); 112 procedure UpdateHeight; 102 113 public 103 114 JobProgressView: TJobProgressView; … … 118 129 TotalStartTime: TDateTime; 119 130 Log: TStringList; 131 FForm: TFormJobProgressView; 120 132 procedure SetTerminate(const AValue: Boolean); 121 133 procedure UpdateProgress; 122 procedure ReloadJobList;123 procedure StartJobs;124 procedure UpdateHeight;125 134 procedure JobProgressChange(Sender: TObject); 126 135 public 127 Form: TFormJobProgressView; 128 Jobs: TObjectList; // TListObject<TJob> 136 Jobs: TJobs; 129 137 CurrentJob: TJob; 130 138 CurrentJobIndex: Integer; … … 132 140 destructor Destroy; override; 133 141 procedure Clear; 134 procedureAddJob(Title: string; Method: TJobProgressViewMethod;135 NoThreaded: Boolean = False; WaitFor: Boolean = False) ;136 procedure Start (AAutoClose: Boolean = True);142 function AddJob(Title: string; Method: TJobProgressViewMethod; 143 NoThreaded: Boolean = False; WaitFor: Boolean = False): TJob; 144 procedure Start; 137 145 procedure Stop; 138 146 procedure TermSleep(Delay: Integer); 147 property Form: TFormJobProgressView read FForm; 139 148 property Terminate: Boolean read FTerminate write SetTerminate; 140 149 published … … 166 175 STotalEstimatedTime = 'Total estimated time: %s'; 167 176 SFinished = 'Finished'; 168 SOperations = 'Operations ';177 SOperations = 'Operations:'; 169 178 170 179 procedure Register; … … 172 181 RegisterComponents('Common', [TJobProgressView]); 173 182 end; 183 184 { TJobThread } 174 185 175 186 procedure TJobThread.Execute; … … 190 201 end; 191 202 192 procedure TJobProgressView.AddJob(Title: string; Method: TJobProgressViewMethod; 193 NoThreaded: Boolean = False; WaitFor: Boolean = False); 203 { TFormJobProgressView } 204 205 procedure TFormJobProgressView.UpdateHeight; 194 206 var 195 NewJob: TJob; 196 begin 197 NewJob := TJob.Create; 198 NewJob.ProgressView := Self; 199 NewJob.Title := Title; 200 NewJob.Method := Method; 201 NewJob.NoThreaded := NoThreaded; 202 NewJob.WaitFor := WaitFor; 203 NewJob.Progress.Max := 100; 204 NewJob.Progress.Reset; 205 NewJob.Progress.OnChange := JobProgressChange; 206 Jobs.Add(NewJob); 207 H: Integer; 208 PanelOperationsVisible: Boolean; 209 PanelOperationsHeight: Integer; 210 PanelProgressVisible: Boolean; 211 PanelProgressTotalVisible: Boolean; 212 PanelLogVisible: Boolean; 213 MemoLogHeight: Integer = 200; 214 I: Integer; 215 ItemRect: TRect; 216 MaxH: Integer; 217 begin 218 H := PanelOperationsTitle.Height; 219 PanelOperationsVisible := JobProgressView.Jobs.Count > 0; 220 if PanelOperationsVisible <> PanelOperations.Visible then 221 PanelOperations.Visible := PanelOperationsVisible; 222 if ListViewJobs.Items.Count > 0 then begin 223 Maxh := 0; 224 for I := 0 to ListViewJobs.Items.Count - 1 do 225 begin 226 ItemRect := ListViewJobs.Items[i].DisplayRect(drBounds); 227 Maxh := Max(Maxh, ItemRect.Top + (ItemRect.Bottom - ItemRect.Top)); 228 end; 229 PanelOperationsHeight := Scale96ToScreen(12) + Maxh; 230 end else PanelOperationsHeight := Scale96ToScreen(8); 231 if PanelOperationsHeight <> PanelOperations.Height then 232 PanelOperations.Height := PanelOperationsHeight; 233 if PanelOperationsVisible then 234 H := H + PanelOperations.Height; 235 236 PanelProgressVisible := (JobProgressView.Jobs.Count > 0) and not JobProgressView.Finished; 237 if PanelProgressVisible <> PanelProgress.Visible then 238 PanelProgress.Visible := PanelProgressVisible; 239 if PanelProgressVisible then 240 H := H + PanelProgress.Height; 241 PanelProgressTotalVisible := (JobProgressView.Jobs.Count > 1) and not JobProgressView.Finished; 242 if PanelProgressTotalVisible <> PanelProgressTotal.Visible then 243 PanelProgressTotal.Visible := PanelProgressTotalVisible; 244 if PanelProgressTotalVisible then 245 H := H + PanelProgressTotal.Height; 246 Constraints.MinHeight := H; 247 PanelLogVisible := MemoLog.Lines.Count > 0; 248 if PanelLogVisible <> PanelLog.Visible then 249 PanelLog.Visible := PanelLogVisible; 250 if PanelLogVisible then 251 H := H + Scale96ToScreen(MemoLogHeight); 252 if PanelText.Visible then 253 H := H + PanelText.Height; 254 if Height <> H then begin 255 Height := H; 256 Top := (Screen.Height - H) div 2; 257 end; 258 end; 259 260 procedure TFormJobProgressView.TimerUpdateTimer(Sender: TObject); 261 var 262 ProgressBarPartVisible: Boolean; 263 ProgressBarTotalVisible: Boolean; 264 begin 265 JobProgressView.UpdateProgress; 266 if Visible and (not ProgressBarPart.Visible) and 267 Assigned(JobProgressView.CurrentJob) and 268 (JobProgressView.CurrentJob.Progress.Value > 0) then begin 269 ProgressBarPartVisible := True; 270 if ProgressBarPartVisible <> ProgressBarPart.Visible then 271 ProgressBarPart.Visible := ProgressBarPartVisible; 272 ProgressBarTotalVisible := True; 273 if ProgressBarTotalVisible <> ProgressBarTotal.Visible then 274 ProgressBarTotal.Visible := ProgressBarTotalVisible; 275 end; 276 if not Visible then begin 277 TimerUpdate.Interval := UpdateInterval; 278 if not JobProgressView.OwnerDraw then Show; 279 end; 280 if Assigned(JobProgressView.CurrentJob) then begin 281 LabelText.Caption := JobProgressView.CurrentJob.Progress.Text; 282 if LabelText.Caption <> '' then begin 283 PanelText.Visible := True; 284 UpdateHeight; 285 end; 286 end; 287 end; 288 289 procedure TFormJobProgressView.FormDestroy(Sender:TObject); 290 begin 291 end; 292 293 procedure TFormJobProgressView.ListViewJobsData(Sender: TObject; Item: TListItem); 294 begin 295 if (Item.Index >= 0) and (Item.Index < JobProgressView.Jobs.Count) then 296 with TJob(JobProgressView.Jobs[Item.Index]) do begin 297 Item.Caption := Title; 298 if Item.Index = JobProgressView.CurrentJobIndex then Item.ImageIndex := 1 299 else if Finished then Item.ImageIndex := 0 300 else Item.ImageIndex := 2; 301 Item.Data := JobProgressView.Jobs[Item.Index]; 302 end; 303 end; 304 305 procedure TFormJobProgressView.FormClose(Sender: TObject; 306 var CloseAction: TCloseAction); 307 begin 308 end; 309 310 procedure TFormJobProgressView.FormCreate(Sender: TObject); 311 begin 312 Caption := SPleaseWait; 313 try 314 //Animate1.FileName := ExtractFileDir(UTF8Encode(Application.ExeName)) + 315 // DirectorySeparator + 'horse.avi'; 316 //Animate1.Active := True; 317 except 318 319 end; 320 end; 321 322 procedure TFormJobProgressView.ReloadJobList; 323 begin 324 // Workaround for not showing first line 325 //Form.ListViewJobs.Items.Count := Jobs.Count + 1; 326 //Form.ListViewJobs.Refresh; 327 328 if ListViewJobs.Items.Count <> JobProgressView.Jobs.Count then 329 ListViewJobs.Items.Count := JobProgressView.Jobs.Count; 330 ListViewJobs.Refresh; 331 Application.ProcessMessages; 332 UpdateHeight; 333 end; 334 335 procedure TFormJobProgressView.FormShow(Sender: TObject); 336 begin 337 ReloadJobList; 338 end; 339 340 procedure TFormJobProgressView.FormHide(Sender: TObject); 341 begin 342 JobProgressView.Jobs.Clear; 343 ReloadJobList; 344 end; 345 346 procedure TFormJobProgressView.FormCloseQuery(Sender: TObject; var CanClose: Boolean); 347 begin 348 CanClose := JobProgressView.Finished; 349 JobProgressView.Terminate := True; 350 Caption := SPleaseWait + STerminate; 351 end; 352 353 354 { TJobProgressView } 355 356 function TJobProgressView.AddJob(Title: string; Method: TJobProgressViewMethod; 357 NoThreaded: Boolean = False; WaitFor: Boolean = False): TJob; 358 begin 359 Result := TJob.Create; 360 Result.ProgressView := Self; 361 Result.Title := Title; 362 Result.Method := Method; 363 Result.NoThreaded := NoThreaded; 364 Result.WaitFor := WaitFor; 365 Result.Progress.Max := 100; 366 Result.Progress.Reset; 367 Result.Progress.OnChange := JobProgressChange; 368 Jobs.Add(Result); 207 369 //ReloadJobList; 208 370 end; 209 371 210 procedure TJobProgressView.Start(AAutoClose: Boolean = True); 211 begin 212 AutoClose := AAutoClose; 213 StartJobs; 214 end; 215 216 procedure TJobProgressView.StartJobs; 372 procedure TJobProgressView.Start; 217 373 var 218 374 I: Integer; … … 229 385 Form.MemoLog.Clear; 230 386 387 Form.PanelText.Visible := False; 231 388 Form.LabelEstimatedTimePart.Visible := False; 232 389 Form.LabelEstimatedTimeTotal.Visible := False; … … 258 415 Form.ProgressBarPart.Visible := False; 259 416 //Show; 260 ReloadJobList;417 Form.ReloadJobList; 261 418 Application.ProcessMessages; 262 419 if NoThreaded then begin … … 296 453 //if Visible then Hide; 297 454 Form.MemoLog.Lines.Assign(Log); 298 if (Form.MemoLog.Lines.Count = 0) and AutoClose then begin455 if (Form.MemoLog.Lines.Count = 0) and FAutoClose then begin 299 456 Form.Hide; 300 457 end; 301 Clear;458 if not Form.Visible then Clear; 302 459 Form.Caption := SFinished; 303 460 //LabelEstimatedTimePart.Visible := False; 304 461 Finished := True; 305 462 CurrentJobIndex := -1; 306 ReloadJobList; 307 end; 308 end; 309 310 procedure TJobProgressView.UpdateHeight; 311 var 312 H: Integer; 313 PanelOperationsVisible: Boolean; 314 PanelOperationsHeight: Integer; 315 PanelProgressVisible: Boolean; 316 PanelProgressTotalVisible: Boolean; 317 PanelLogVisible: Boolean; 318 begin 319 with Form do begin 320 H := PanelOperationsTitle.Height; 321 PanelOperationsVisible := Jobs.Count > 0; 322 if PanelOperationsVisible <> PanelOperations.Visible then 323 PanelOperations.Visible := PanelOperationsVisible; 324 PanelOperationsHeight := 8 + 18 * Jobs.Count; 325 if PanelOperationsHeight <> PanelOperations.Height then 326 PanelOperations.Height := PanelOperationsHeight; 327 if PanelOperationsVisible then 328 H := H + PanelOperations.Height; 329 330 PanelProgressVisible := (Jobs.Count > 0) and not Finished; 331 if PanelProgressVisible <> PanelProgress.Visible then 332 PanelProgress.Visible := PanelProgressVisible; 333 if PanelProgressVisible then 334 H := H + PanelProgress.Height; 335 PanelProgressTotalVisible := (Jobs.Count > 1) and not Finished; 336 if PanelProgressTotalVisible <> PanelProgressTotal.Visible then 337 PanelProgressTotal.Visible := PanelProgressTotalVisible; 338 if PanelProgressTotalVisible then 339 H := H + PanelProgressTotal.Height; 340 Constraints.MinHeight := H; 341 PanelLogVisible := MemoLog.Lines.Count > 0; 342 if PanelLogVisible <> PanelLog.Visible then 343 PanelLog.Visible := PanelLogVisible; 344 if PanelLogVisible then 345 H := H + MemoLogHeight; 346 if Height <> H then Height := H; 463 Form.ReloadJobList; 347 464 end; 348 465 end; … … 352 469 if Assigned(FOnOwnerDraw) then 353 470 FOnOwnerDraw(Self); 354 end;355 356 procedure TFormJobProgressView.TimerUpdateTimer(Sender: TObject);357 var358 ProgressBarPartVisible: Boolean;359 ProgressBarTotalVisible: Boolean;360 begin361 JobProgressView.UpdateProgress;362 if Visible and (not ProgressBarPart.Visible) and363 Assigned(JobProgressView.CurrentJob) and364 (JobProgressView.CurrentJob.Progress.Value > 0) then begin365 ProgressBarPartVisible := True;366 if ProgressBarPartVisible <> ProgressBarPart.Visible then367 ProgressBarPart.Visible := ProgressBarPartVisible;368 ProgressBarTotalVisible := True;369 if ProgressBarTotalVisible <> ProgressBarTotal.Visible then370 ProgressBarTotal.Visible := ProgressBarTotalVisible;371 end;372 if not Visible then begin373 TimerUpdate.Interval := UpdateInterval;374 if not JobProgressView.OwnerDraw then Show;375 end;376 end;377 378 procedure TFormJobProgressView.FormDestroy(Sender:TObject);379 begin380 end;381 382 procedure TFormJobProgressView.ListViewJobsData(Sender: TObject; Item: TListItem);383 begin384 if (Item.Index >= 0) and (Item.Index < JobProgressView.Jobs.Count) then385 with TJob(JobProgressView.Jobs[Item.Index]) do begin386 Item.Caption := Title;387 if Item.Index = JobProgressView.CurrentJobIndex then Item.ImageIndex := 1388 else if Finished then Item.ImageIndex := 0389 else Item.ImageIndex := 2;390 Item.Data := JobProgressView.Jobs[Item.Index];391 end;392 end;393 394 procedure TFormJobProgressView.FormClose(Sender: TObject;395 var CloseAction: TCloseAction);396 begin397 ListViewJobs.Clear;398 end;399 400 procedure TFormJobProgressView.FormCreate(Sender: TObject);401 begin402 Caption := SPleaseWait;403 try404 //Animate1.FileName := ExtractFileDir(UTF8Encode(Application.ExeName)) +405 // DirectorySeparator + 'horse.avi';406 //Animate1.Active := True;407 except408 409 end;410 471 end; 411 472 … … 426 487 Sleep(Quantum); 427 488 end; 428 end;429 430 procedure TFormJobProgressView.FormCloseQuery(Sender: TObject; var CanClose: Boolean);431 begin432 CanClose := JobProgressView.Finished;433 JobProgressView.Terminate := True;434 Caption := SPleaseWait + STerminate;435 489 end; 436 490 … … 490 544 end; 491 545 492 procedure TJobProgressView.ReloadJobList;493 begin494 UpdateHeight;495 // Workaround for not showing first line496 Form.ListViewJobs.Items.Count := Jobs.Count + 1;497 Form.ListViewJobs.Refresh;498 499 if Form.ListViewJobs.Items.Count <> Jobs.Count then500 Form.ListViewJobs.Items.Count := Jobs.Count;501 Form.ListViewJobs.Refresh;502 //Application.ProcessMessages;503 end;504 505 546 constructor TJobProgressView.Create(TheOwner: TComponent); 506 547 begin 507 548 inherited; 508 549 if not (csDesigning in ComponentState) then begin 509 F orm := TFormJobProgressView.Create(Self);510 F orm.JobProgressView := Self;511 end; 512 Jobs := T ObjectList.Create;550 FForm := TFormJobProgressView.Create(Self); 551 FForm.JobProgressView := Self; 552 end; 553 Jobs := TJobs.Create; 513 554 Log := TStringList.Create; 514 555 //PanelOperationsTitle.Height := 80; 515 ShowDelay := 0; //1000; // ms 556 AutoClose := True; 557 ShowDelay := 0; 516 558 end; 517 559 … … 519 561 begin 520 562 Jobs.Clear; 563 Log.Clear; 521 564 //ReloadJobList; 522 565 end; … … 528 571 inherited; 529 572 end; 573 574 { TProgress } 530 575 531 576 procedure TProgress.SetMax(const AValue: Integer); … … 536 581 if FMax < 1 then FMax := 1; 537 582 if FValue >= FMax then FValue := FMax; 583 finally 584 FLock.Release; 585 end; 586 end; 587 588 procedure TProgress.SetText(AValue: string); 589 begin 590 try 591 FLock.Acquire; 592 if FText = AValue then Exit; 593 FText := AValue; 538 594 finally 539 595 FLock.Release; … … 563 619 end; 564 620 565 { TProgress }566 567 621 procedure TProgress.Increment; 568 622 begin -
trunk/Packages/Common/ULastOpenedList.pas
r28 r38 6 6 7 7 uses 8 Classes, SysUtils, Registry, URegistry, Menus, XMLConf ;8 Classes, SysUtils, Registry, URegistry, Menus, XMLConf, DOM; 9 9 10 10 type … … 139 139 OpenKey(Context.Key, True); 140 140 for I := 0 to Items.Count - 1 do 141 WriteString('File' + IntToStr(I), UTF8Decode(Items[I]));141 WriteString('File' + IntToStr(I), Items[I]); 142 142 finally 143 143 Free; … … 153 153 begin 154 154 with XMLConfig do begin 155 Count := GetValue( Path + '/Count', 0);155 Count := GetValue(DOMString(Path + '/Count'), 0); 156 156 if Count > MaxCount then Count := MaxCount; 157 157 Items.Clear; 158 158 for I := 0 to Count - 1 do begin 159 Value := GetValue(Path + '/File' + IntToStr(I), '');159 Value := string(GetValue(DOMString(Path + '/File' + IntToStr(I)), '')); 160 160 if Trim(Value) <> '' then Items.Add(Value); 161 161 end; … … 170 170 begin 171 171 with XMLConfig do begin 172 SetValue( Path + '/Count', Items.Count);172 SetValue(DOMString(Path + '/Count'), Items.Count); 173 173 for I := 0 to Items.Count - 1 do 174 SetValue( Path + '/File' + IntToStr(I), Items[I]);174 SetValue(DOMString(Path + '/File' + IntToStr(I)), DOMString(Items[I])); 175 175 Flush; 176 176 end; -
trunk/Packages/Common/UListViewSort.pas
r28 r38 81 81 FOnChange: TNotifyEvent; 82 82 FStringGrid1: TStringGrid; 83 procedure DoOnKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);84 procedure DoOnResize(Sender: TObject);83 procedure GridDoOnKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); 84 procedure GridDoOnResize(Sender: TObject); 85 85 public 86 86 constructor Create(AOwner: TComponent); override; … … 110 110 { TListViewFilter } 111 111 112 procedure TListViewFilter. DoOnKeyUp(Sender: TObject; var Key: Word;112 procedure TListViewFilter.GridDoOnKeyUp(Sender: TObject; var Key: Word; 113 113 Shift: TShiftState); 114 114 begin … … 117 117 end; 118 118 119 procedure TListViewFilter. DoOnResize(Sender: TObject);119 procedure TListViewFilter.GridDoOnResize(Sender: TObject); 120 120 begin 121 121 FStringGrid1.DefaultRowHeight := FStringGrid1.Height; … … 135 135 FStringGrid1.Options := [goFixedHorzLine, goFixedVertLine, goVertLine, 136 136 goHorzLine, goRangeSelect, goEditing, goAlwaysShowEditor, goSmoothScroll]; 137 FStringGrid1.OnKeyUp := DoOnKeyUp;138 FStringGrid1.OnResize := DoOnResize;137 FStringGrid1.OnKeyUp := GridDoOnKeyUp; 138 FStringGrid1.OnResize := GridDoOnResize; 139 139 end; 140 140 … … 142 142 var 143 143 I: Integer; 144 R: TRect; 144 145 begin 145 146 with FStringGrid1 do begin 146 //Columns.Clear;147 147 while Columns.Count > ListView.Columns.Count do Columns.Delete(Columns.Count - 1); 148 148 while Columns.Count < ListView.Columns.Count do Columns.Add; 149 149 for I := 0 to ListView.Columns.Count - 1 do begin 150 150 Columns[I].Width := ListView.Columns[I].Width; 151 if Selection.Left = I then begin 152 R := CellRect(I, 0); 153 Editor.Left := R.Left + 2; 154 Editor.Width := R.Width - 4; 155 end; 151 156 end; 152 157 end; … … 197 202 if AMsg.Msg = WM_NOTIFY then 198 203 begin 199 Code := PHDNotify(vMsgNotify.NMHdr)^.Hdr.Code;204 Code := NMHDR(PHDNotify(vMsgNotify.NMHdr)^.Hdr).Code; 200 205 case Code of 201 206 HDN_ENDTRACKA, HDN_ENDTRACKW: … … 353 358 TP1: TPoint; 354 359 XBias, YBias: Integer; 355 OldColor: TColor; 360 PenColor: TColor; 361 BrushColor: TColor; 356 362 BiasTop, BiasLeft: Integer; 357 363 Rect1: TRect; … … 365 371 Item.Left := 0; 366 372 GetCheckBias(XBias, YBias, BiasTop, BiasLeft, ListView); 367 OldColor := ListView.Canvas.Pen.Color; 373 PenColor := ListView.Canvas.Pen.Color; 374 BrushColor := ListView.Canvas.Brush.Color; 368 375 //TP1 := Item.GetPosition; 369 376 lRect := Item.DisplayRect(drBounds); // Windows 7 workaround … … 377 384 ItemLeft := Item.Left; 378 385 ItemLeft := 23; // Windows 7 workaround 379 386 380 387 Rect1.Left := ItemLeft - CheckWidth - BiasLeft + 1 + XBias; 381 388 //ShowMessage(IntToStr(Tp1.Y) + ', ' + IntToStr(BiasTop) + ', ' + IntToStr(XBias)); … … 408 415 end; 409 416 //ListView.Canvas.Brush.Color := ListView.Color; 410 ListView.Canvas.Brush.Color := clWindow;411 ListView.Canvas.Pen.Color := OldColor;417 ListView.Canvas.Brush.Color := BrushColor; 418 ListView.Canvas.Pen.Color := PenColor; 412 419 end; 413 420 … … 476 483 FHeaderHandle := ListView_GetHeader(FListView.Handle); 477 484 for I := 0 to FListView.Columns.Count - 1 do begin 485 {$push}{$warn 5057 off} 478 486 FillChar(Item, SizeOf(THDItem), 0); 487 {$pop} 479 488 Item.Mask := HDI_FORMAT; 480 489 Header_GetItem(FHeaderHandle, I, Item); -
trunk/Packages/Common/UMemory.pas
r37 r38 10 10 type 11 11 12 { T Block}12 { TMemory } 13 13 14 T Block= class14 TMemory = class 15 15 private 16 16 FData: PByte; 17 17 FSize: Integer; 18 function GetItem(Index: Integer): Byte; virtual; abstract;19 procedure SetItem(Index: Integer; AValue: Byte); virtual; abstract;20 procedure SetSize(AValue: Integer); virtual; abstract;18 function GetItem(Index: Integer): Byte; 19 procedure SetItem(Index: Integer; AValue: Byte); 20 procedure SetSize(AValue: Integer); virtual; 21 21 public 22 procedure ReadBlock(Block: TBlock; Position: Integer); virtual; 23 procedure WriteBlock(Block: TBlock; Position: Integer); virtual; 24 procedure Clear(Value: Byte = 0); virtual; 25 procedure Assign(Source: TBlock); virtual; 26 property Size: Integer read FSize write SetSize; 27 property Items[Index: Integer]: Byte read GetItem write SetItem; default; 28 end; 29 30 { TMemory } 31 32 TMemory = class(TBlock) 33 private 34 FData: PByte; 35 FSize: Integer; 36 function GetItem(Index: Integer): Byte; override; 37 procedure SetItem(Index: Integer; AValue: Byte); override; 38 procedure SetSize(AValue: Integer); override; 39 public 40 procedure Clear(Value: Byte = 0); override; 41 procedure Assign(Source: TBlock); override; 22 procedure Clear(Value: Byte = 0); 23 procedure Assign(Source: TMemory); 42 24 constructor Create; 43 25 destructor Destroy; override; 44 26 property Data: PByte read FData; 27 property Size: Integer read FSize write SetSize; 28 property Items[Index: Integer]: Byte read GetItem write SetItem; default; 45 29 end; 46 30 … … 58 42 end; 59 43 60 { TBitBlock }61 62 TBitBlock = class63 private64 function GetItem(Index: Integer): Byte; virtual;65 function GetSize: Integer; virtual;66 procedure SetItem(Index: Integer; AValue: Byte); virtual;67 procedure SetSize(AValue: Integer); virtual;68 public69 procedure Invert; virtual;70 function GetInteger: Integer; virtual;71 procedure SetInteger(Value: Integer); virtual;72 procedure ReadBlock(Block: TBitBlock; Position: Integer); virtual;73 procedure WriteBlock(Block: TBitBlock; Position: Integer); virtual;74 procedure Clear(Value: Byte = 0); virtual;75 procedure Assign(Source: TBlock); virtual;76 property Size: Integer read GetSize write SetSize;77 property Items[Index: Integer]: Byte read GetItem write SetItem; default;78 end;79 80 { TBitMemory }81 82 TBitMemory = class(TBitBlock)83 private84 FData: PByte;85 FSize: Integer;86 function GetSize: Integer; override;87 procedure SetSize(AValue: Integer); override;88 function GetItem(Index: Integer): Byte; override;89 procedure SetItem(Index: Integer; AValue: Byte); override;90 public91 constructor Create;92 destructor Destroy; override;93 function GetInteger: Integer; override;94 procedure SetInteger(Value: Integer); override;95 procedure Clear(Value: Byte = 0); override;96 procedure ReadBlock(Block: TBitBlock; Position: Integer); override;97 procedure WriteBlock(Block: TBitBlock; Position: Integer); override;98 property Data: PByte read FData;99 procedure Invert; override;100 end;101 102 103 44 implementation 104 105 { TBitMemory }106 107 procedure TBitMemory.Clear(Value: Byte);108 begin109 if (Size and 7) = 0 then begin110 if Value = 0 then FillChar(FData^, Size shr 3, 0)111 else FillChar(FData^, Size shr 3, $ff);112 end else inherited;113 end;114 115 procedure TBitMemory.ReadBlock(Block: TBitBlock; Position: Integer);116 begin117 if Block is TBitMemory then begin118 if (Position and 7) = 0 then begin119 if (Block.Size and 7) = 0 then120 Move(PByte(FData + Position shr 3)^, TBitMemory(Block).Data^, Block.Size shr 3)121 else inherited;122 end else inherited;123 end else inherited;124 end;125 126 procedure TBitMemory.WriteBlock(Block: TBitBlock; Position: Integer);127 begin128 if Block is TBitMemory then begin129 if (Position and 7) = 0 then begin130 if (Block.Size and 7) = 0 then131 Move(TBitMemory(Block).Data^, PByte(FData + Position shr 3)^, Block.Size shr 3)132 else inherited;133 end else inherited;134 end else inherited;135 end;136 137 procedure TBitMemory.Invert;138 var139 I: Integer;140 begin141 if (Size and 7) = 0 then begin142 for I := 0 to (Size shr 3) - 1 do143 PByte(FData + I)^ := PByte(FData + I)^ xor $ff;144 end145 else inherited;146 147 end;148 149 function TBitMemory.GetInteger: Integer;150 var151 I: Integer;152 V: Integer;153 begin154 Result := 0;155 I := 0;156 while (I < 32) and (I < Size) do begin157 V := FData[I shr 3];158 V := V shl I;159 Result := Result or V;160 // Result := Result or (FData[I shr 3] shl I);161 Inc(I, 8);162 end;163 if Size < 32 then164 Result := Result and ((1 shl Size) - 1);165 end;166 167 procedure TBitMemory.SetInteger(Value: Integer);168 var169 I: Integer;170 begin171 I := 0;172 while (I < 32) and (I < Size) do begin173 FData[I shr 3] := (Value shr I) and $ff;174 Inc(I, 8);175 end;176 end;177 178 function TBitMemory.GetSize: Integer;179 begin180 Result := FSize;181 end;182 183 procedure TBitMemory.SetSize(AValue: Integer);184 var185 ByteSize: Integer;186 begin187 if AValue = FSize then Exit;188 FSize := AValue;189 ByteSize := FSize shr 3;190 if (FSize and 7) > 0 then Inc(ByteSize);191 FData := ReAllocMem(FData, ByteSize);192 end;193 194 function TBitMemory.GetItem(Index: Integer): Byte;195 begin196 if Index >= Size then raise Exception.Create('Out of range');197 Result := (PByte(FData + (Index shr 3))^ shr (Index and 7)) and 1;198 end;199 200 procedure TBitMemory.SetItem(Index: Integer; AValue: Byte);201 begin202 if Index >= Size then raise Exception.Create('Out of range, Size:' + IntToStr(Size) + ', Index:' + IntToStr(Index));203 PByte(FData + (Index shr 3))^ := PByte(FData + (Index shr 3))^ and not (1 shl (Index and 7))204 or ((AValue and 1) shl (Index and 7));205 end;206 207 constructor TBitMemory.Create;208 begin209 FData := nil;210 end;211 212 destructor TBitMemory.Destroy;213 begin214 FreeMem(FData);215 inherited Destroy;216 end;217 218 { TBitBlock }219 220 function TBitBlock.GetItem(Index: Integer): Byte;221 begin222 Result := 0;223 end;224 225 function TBitBlock.GetSize: Integer;226 begin227 Result := 0;228 end;229 230 procedure TBitBlock.SetItem(Index: Integer; AValue: Byte);231 begin232 233 end;234 235 procedure TBitBlock.SetSize(AValue: Integer);236 begin237 end;238 239 procedure TBitBlock.Invert;240 var241 I: Integer;242 begin243 for I := 0 to Size - 1 do244 Items[I] := not Items[I];245 end;246 247 function TBitBlock.GetInteger: Integer;248 begin249 Result := 0;250 end;251 252 procedure TBitBlock.SetInteger(Value: Integer);253 begin254 255 end;256 257 procedure TBitBlock.ReadBlock(Block: TBitBlock; Position: Integer);258 var259 I: Integer;260 begin261 for I := 0 to Block.Size - 1 do262 Block.Items[I] := Items[Position + I];263 end;264 265 procedure TBitBlock.WriteBlock(Block: TBitBlock; Position: Integer);266 var267 I: Integer;268 begin269 for I := 0 to Block.Size - 1 do270 Items[Position + I] := Block.Items[I];271 end;272 273 procedure TBitBlock.Clear(Value: Byte);274 var275 I: Integer;276 begin277 for I := 0 to Size - 1 do278 Items[I] := Value;279 end;280 281 procedure TBitBlock.Assign(Source: TBlock);282 var283 I: Integer;284 begin285 Size := Source.Size;286 for I := 0 to Size - 1 do287 Items[I] := Source.Items[I];288 end;289 290 { TBlock }291 292 procedure TBlock.ReadBlock(Block: TBlock; Position: Integer);293 var294 I: Integer;295 begin296 if Position + Block.Size > Size then raise Exception.Create('');297 for I := 0 to Block.Size - 1 do298 Items[I] := Items[Position + I];299 end;300 301 procedure TBlock.WriteBlock(Block: TBlock; Position: Integer);302 var303 I: Integer;304 begin305 if Position + Block.Size > Size then raise Exception.Create('');306 for I := 0 to Block.Size - 1 do307 Items[Position + I] := Items[I];308 end;309 310 procedure TBlock.Clear(Value: Byte);311 var312 I: Integer;313 begin314 for I := 0 to Size - 1 do315 Items[I] := Value;316 end;317 318 procedure TBlock.Assign(Source: TBlock);319 var320 I: Integer;321 begin322 Size := Source.Size;323 for I := 0 to Size - 1 do324 Items[I] := Source.Items[I];325 end;326 45 327 46 { TPositionMemory } … … 371 90 end; 372 91 373 procedure TMemory.Assign(Source: T Block);92 procedure TMemory.Assign(Source: TMemory); 374 93 begin 375 if Source is TMemory then begin 376 Size := Source.Size; 377 Move(TMemory(Source).Data^, FData^, Size); 378 end else inherited; 94 Size := Source.Size; 95 Move(Source.Data^, FData^, Size); 379 96 end; 380 97 -
trunk/Packages/Common/UPersistentForm.pas
r28 r38 56 56 I: Integer; 57 57 WinControl: TWinControl; 58 Count: Integer;59 58 begin 60 59 if Control is TListView then begin … … 217 216 218 217 procedure TPersistentForm.Load(Form: TForm; DefaultMaximized: Boolean = False); 219 var220 LoadDefaults: Boolean;221 218 begin 222 219 Self.Form := Form; … … 230 227 231 228 if not EqualRect(FormNormalSize, FormRestoredSize) or 232 (LoadDefaults and DefaultMaximized)then begin229 DefaultMaximized then begin 233 230 // Restore to maximized state 234 231 Form.WindowState := wsNormal; -
trunk/Packages/Common/URegistry.pas
r28 r38 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/UResetableThread.pas
r28 r38 156 156 FThread.Name := 'ResetableThread'; 157 157 FThread.Parent := Self; 158 FThread. Resume;158 FThread.Start; 159 159 end; 160 160 -
trunk/Packages/Common/UScaleDPI.pas
r28 r38 215 215 I: Integer; 216 216 begin 217 ImgList.BeginUpdate; 217 218 NewWidth := ScaleX(ImgList.Width, FromDPI.X); 218 219 NewHeight := ScaleY(ImgList.Height, FromDPI.Y); … … 248 249 Temp[i].Free; 249 250 end; 251 ImgList.EndUpdate; 250 252 end; 251 253 … … 284 286 WinControl: TWinControl; 285 287 ToolBarControl: TToolBar; 286 OldAnchors: TAnchors;287 OldAutoSize: Boolean;288 //OldAnchors: TAnchors; 289 //OldAutoSize: Boolean; 288 290 begin 289 291 //if Control is TMemo then Exit; … … 316 318 MinWidth := ScaleX(MinWidth, FromDPI.X); 317 319 MinHeight := ScaleY(MinHeight, FromDPI.Y); 318 Width := ScaleX(Width, FromDPI.X); 320 // Workaround to bad band width auto sizing 321 //Width := ScaleX(Width, FromDPI.X); 322 Width := ScaleX(Control.Width + 28, FromDPI.X); 319 323 //Control.Invalidate; 320 324 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; 321 331 EndUpdate; 322 332 end; -
trunk/Packages/Common/UThreading.pas
r28 r38 30 30 Name: string; 31 31 procedure Execute; virtual; abstract; 32 procedure Resume; virtual; abstract;33 procedure Suspend; virtual; abstract;34 32 procedure Start; virtual; abstract; 35 33 procedure Terminate; virtual; abstract; … … 81 79 procedure Sleep(Delay: Integer); override; 82 80 procedure Execute; override; 83 procedure Resume; override;84 procedure Suspend; override;85 81 procedure Start; override; 86 82 procedure Terminate; override; … … 134 130 Thread.FreeOnTerminate := False; 135 131 Thread.Method := Method; 136 Thread. Resume;132 Thread.Start; 137 133 while (Thread.State = ttsRunning) or (Thread.State = ttsReady) do begin 138 134 if MainThreadID = ThreadID then Application.ProcessMessages; … … 155 151 Thread.Method := Method; 156 152 Thread.OnFinished := CallBack; 157 Thread. Resume;153 Thread.Start; 158 154 //if Thread.State = ttsExceptionOccured then 159 155 // raise Exception.Create(Thread.ExceptionMessage); … … 313 309 procedure TListedThread.Execute; 314 310 begin 315 end;316 317 procedure TListedThread.Resume;318 begin319 FThread.Resume;320 end;321 322 procedure TListedThread.Suspend;323 begin324 FThread.Suspend;325 311 end; 326 312 -
trunk/Packages/Common/UURI.pas
r28 r38 89 89 function LeftCutString(var Source: string; out Output: string; Delimiter: string; Allowed: string = ''): Boolean; 90 90 var 91 I , J: Integer;91 I: Integer; 92 92 Matched: Boolean; 93 93 begin … … 113 113 function RightCutString(var Source: string; out Output: string; Delimiter: string; Allowed: string = ''): Boolean; 114 114 var 115 I , J: Integer;115 I: Integer; 116 116 Matched: Boolean; 117 117 begin … … 202 202 203 203 procedure TURI.SetAsString(Value: string); 204 var205 HostAddr: string;206 HostPort: string;207 204 begin 208 205 LeftCutString(Value, Scheme, ':'); -
trunk/Packages/Common/UXMLUtils.pas
r28 r38 7 7 uses 8 8 {$IFDEF WINDOWS}Windows,{$ENDIF} 9 Classes, SysUtils, DateUtils, XMLRead, XMLWrite,DOM;9 Classes, SysUtils, DateUtils, DOM; 10 10 11 11 function XMLTimeToDateTime(XMLDateTime: string): TDateTime; 12 function DateTimeToXMLTime(Value: TDateTime; ApplyLocalBias: Boolean = True): WideString;12 function DateTimeToXMLTime(Value: TDateTime; ApplyLocalBias: Boolean = True): string; 13 13 procedure WriteInteger(Node: TDOMNode; Name: string; Value: Integer); 14 14 procedure WriteInt64(Node: TDOMNode; Name: string; Value: Int64); … … 30 30 TimeZoneInfo: TTimeZoneInformation; 31 31 begin 32 {$push}{$warn 5057 off} 32 33 case GetTimeZoneInformation(TimeZoneInfo) of 33 TIME_ZONE_ID_STANDARD: Result := TimeZoneInfo.Bias + TimeZoneInfo.StandardBias;34 TIME_ZONE_ID_DAYLIGHT: Result := TimeZoneInfo.Bias + TimeZoneInfo.DaylightBias;34 TIME_ZONE_ID_STANDARD: Result := TimeZoneInfo.Bias + TimeZoneInfo.StandardBias; 35 TIME_ZONE_ID_DAYLIGHT: Result := TimeZoneInfo.Bias + TimeZoneInfo.DaylightBias; 35 36 else 36 37 Result := 0; 37 38 end; 39 {$pop} 38 40 end; 39 41 {$ELSE} … … 45 47 function LeftCutString(var Source: string; out Output: string; Delimiter: string; Allowed: string = ''): Boolean; 46 48 var 47 I , J: Integer;49 I: Integer; 48 50 Matched: Boolean; 49 51 begin … … 99 101 if Pos('Z', XMLDateTime) > 0 then 100 102 LeftCutString(XMLDateTime, Part, 'Z'); 101 SecondFraction := StrToFloat('0' + De cimalSeparator + Part);103 SecondFraction := StrToFloat('0' + DefaultFormatSettings.DecimalSeparator + Part); 102 104 Millisecond := Trunc(SecondFraction * 1000); 103 105 end else begin … … 118 120 end; 119 121 120 function DateTimeToXMLTime(Value: TDateTime; ApplyLocalBias: Boolean = True): WideString;122 function DateTimeToXMLTime(Value: TDateTime; ApplyLocalBias: Boolean = True): string; 121 123 const 122 124 Neg: array[Boolean] of string = ('+', '-'); … … 139 141 NewNode: TDOMNode; 140 142 begin 141 NewNode := Node.OwnerDocument.CreateElement( Name);142 NewNode.TextContent := IntToStr(Value);143 NewNode := Node.OwnerDocument.CreateElement(DOMString(Name)); 144 NewNode.TextContent := DOMString(IntToStr(Value)); 143 145 Node.AppendChild(NewNode); 144 146 end; … … 148 150 NewNode: TDOMNode; 149 151 begin 150 NewNode := Node.OwnerDocument.CreateElement( Name);151 NewNode.TextContent := IntToStr(Value);152 NewNode := Node.OwnerDocument.CreateElement(DOMString(Name)); 153 NewNode.TextContent := DOMString(IntToStr(Value)); 152 154 Node.AppendChild(NewNode); 153 155 end; … … 157 159 NewNode: TDOMNode; 158 160 begin 159 NewNode := Node.OwnerDocument.CreateElement( Name);160 NewNode.TextContent := BoolToStr(Value);161 NewNode := Node.OwnerDocument.CreateElement(DOMString(Name)); 162 NewNode.TextContent := DOMString(BoolToStr(Value)); 161 163 Node.AppendChild(NewNode); 162 164 end; … … 166 168 NewNode: TDOMNode; 167 169 begin 168 NewNode := Node.OwnerDocument.CreateElement( Name);169 NewNode.TextContent := Value;170 NewNode := Node.OwnerDocument.CreateElement(DOMString(Name)); 171 NewNode.TextContent := DOMString(Value); 170 172 Node.AppendChild(NewNode); 171 173 end; … … 175 177 NewNode: TDOMNode; 176 178 begin 177 NewNode := Node.OwnerDocument.CreateElement( Name);178 NewNode.TextContent := D ateTimeToXMLTime(Value);179 NewNode := Node.OwnerDocument.CreateElement(DOMString(Name)); 180 NewNode.TextContent := DOMString(DateTimeToXMLTime(Value)); 179 181 Node.AppendChild(NewNode); 180 182 end; … … 185 187 begin 186 188 Result := DefaultValue; 187 NewNode := Node.FindNode( Name);188 if Assigned(NewNode) then 189 Result := StrToInt( NewNode.TextContent);189 NewNode := Node.FindNode(DOMString(Name)); 190 if Assigned(NewNode) then 191 Result := StrToInt(string(NewNode.TextContent)); 190 192 end; 191 193 … … 195 197 begin 196 198 Result := DefaultValue; 197 NewNode := Node.FindNode( Name);198 if Assigned(NewNode) then 199 Result := StrToInt64( NewNode.TextContent);199 NewNode := Node.FindNode(DOMString(Name)); 200 if Assigned(NewNode) then 201 Result := StrToInt64(string(NewNode.TextContent)); 200 202 end; 201 203 … … 205 207 begin 206 208 Result := DefaultValue; 207 NewNode := Node.FindNode( Name);208 if Assigned(NewNode) then 209 Result := StrToBool( NewNode.TextContent);209 NewNode := Node.FindNode(DOMString(Name)); 210 if Assigned(NewNode) then 211 Result := StrToBool(string(NewNode.TextContent)); 210 212 end; 211 213 … … 215 217 begin 216 218 Result := DefaultValue; 217 NewNode := Node.FindNode( Name);218 if Assigned(NewNode) then 219 Result := NewNode.TextContent;219 NewNode := Node.FindNode(DOMString(Name)); 220 if Assigned(NewNode) then 221 Result := string(NewNode.TextContent); 220 222 end; 221 223 … … 226 228 begin 227 229 Result := DefaultValue; 228 NewNode := Node.FindNode( Name);229 if Assigned(NewNode) then 230 Result := XMLTimeToDateTime( NewNode.TextContent);230 NewNode := Node.FindNode(DOMString(Name)); 231 if Assigned(NewNode) then 232 Result := XMLTimeToDateTime(string(NewNode.TextContent)); 231 233 end; 232 234
Note:
See TracChangeset
for help on using the changeset viewer.