Changeset 172
- Timestamp:
- Jun 14, 2024, 9:41:40 PM (7 months ago)
- Location:
- trunk
- Files:
-
- 2 added
- 25 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/Forms/FormImport.lfm
r168 r172 12 12 OnDestroy = FormDestroy 13 13 OnShow = FormShow 14 LCLVersion = ' 2.2.6.0'14 LCLVersion = '3.0.0.3' 15 15 object ButtonCancel: TButton 16 16 Left = 578 … … 32 32 Caption = 'Import' 33 33 ModalResult = 1 34 OnClick = ButtonImportClick35 34 ParentFont = False 36 35 TabOrder = 1 36 OnClick = ButtonImportClick 37 37 end 38 38 object ScrollBox1: TScrollBox … … 61 61 Width = 225 62 62 ItemHeight = 0 63 OnChange = ComboBoxInputFormatChange64 63 ReadOnly = True 65 64 Style = csDropDownList 66 65 TabOrder = 0 66 OnChange = ComboBoxInputFormatChange 67 67 end 68 68 object Label2: TLabel … … 80 80 Width = 464 81 81 Anchors = [akTop, akLeft, akRight] 82 TabOrder = 1 82 83 OnChange = EditInputFileChange 83 TabOrder = 184 84 end 85 85 object ButtonBrowse: TButton … … 90 90 Anchors = [akTop, akRight] 91 91 Caption = 'Browse' 92 TabOrder = 2 92 93 OnClick = ButtonBrowseClick 93 TabOrder = 294 94 end 95 95 object ListView1: TListView -
trunk/Forms/FormImport.pas
r170 r172 136 136 if not FileExists(EditInputFile.Text) then Exit; 137 137 138 Table.SetInput(TableFormat, LoadFileToStr(EditInputFile.Text)); 139 Table.Title := ExtractFileNameWithoutExt(EditInputFile.Text); 138 try 139 Table.SetInput(TableFormat, LoadFileToStr(EditInputFile.Text)); 140 Table.Title := ExtractFileNameWithoutExt(EditInputFile.Text); 141 except 142 // It may fail due to invalid format 143 end; 140 144 end; 141 145 -
trunk/Packages/Common/FindFile.pas
r148 r172 75 75 constructor TFindFile.Create(AOwner: TComponent); 76 76 begin 77 inherited Create(AOwner);77 inherited; 78 78 Path := IncludeTrailingBackslash(UTF8Encode(GetCurrentDir)); 79 79 FileMask := FilterAll; -
trunk/Packages/Common/FormEx.pas
r165 r172 68 68 end; 69 69 70 PersistentForm.Load(Self);71 70 Translator.TranslateComponentRecursive(Self); 72 71 ThemeManager.UseTheme(Self); -
trunk/Packages/Common/Languages.pas
r148 r172 216 216 SLang_za = 'Zhuang'; 217 217 SLang_zh = 'Chinese'; 218 SLang_zh_Hans = 'Simplified Chinese'; 219 SLang_zh_Hant = 'Traditional Chinese'; 218 220 SLang_zu = 'Zulu'; 221 219 222 220 223 implementation … … 228 231 begin 229 232 I := 0; 230 while (I < Count) and ( TLanguage(Items[I]).Code <ACode) do Inc(I);231 if I < Count then Result := TLanguage(Items[I])233 while (I < Count) and (Items[I].Code <> ACode) do Inc(I); 234 if I < Count then Result := Items[I] 232 235 else Result := nil; 233 236 end; … … 439 442 AddNew('za', SLang_za); 440 443 AddNew('zh', SLang_zh); 444 AddNew('zh-Hant', SLang_zh_Hant); 445 AddNew('zh-Hans', SLang_zh_Hans); 441 446 AddNew('zu', SLang_zu); 442 447 end; -
trunk/Packages/Common/Languages/DataFile.cs.po
r158 r172 21 21 msgid "Data file" 22 22 msgstr "Datový soubor" 23 -
trunk/Packages/Common/Languages/DebugLog.cs.po
r158 r172 16 16 msgid "Filename not defined" 17 17 msgstr "Neurčen soubor" 18 -
trunk/Packages/Common/Languages/FindFile.cs.po
r158 r172 16 16 msgid "Directory not found" 17 17 msgstr "Adresář nenalezen" 18 -
trunk/Packages/Common/Languages/FormAbout.cs.po
r164 r172 27 27 msgstr "Verze" 28 28 29 #: tformabout.caption 30 msgid "About" 31 msgstr "O aplikaci" -
trunk/Packages/Common/Languages/FormAbout.pot
r164 r172 14 14 msgstr "" 15 15 16 #: tformabout.caption 17 msgid "About" 18 msgstr "" 19 -
trunk/Packages/Common/Languages/JobProgressView.cs.po
r158 r172 43 43 msgid "Total estimated time: %s" 44 44 msgstr "Celkový odhadovaný čas: %s" 45 -
trunk/Packages/Common/Languages/Languages.cs.po
r158 r172 981 981 msgid "Zulu" 982 982 msgstr "Zuluština" 983 -
trunk/Packages/Common/Languages/Pool.cs.po
r158 r172 21 21 msgid "Unknown object for release from pool" 22 22 msgstr "Neznýmý objekt pro uvolnění ze zásobníku" 23 -
trunk/Packages/Common/Languages/ResetableThread.cs.po
r158 r172 16 16 msgid "WaitFor error" 17 17 msgstr "Chyba WaitFor" 18 -
trunk/Packages/Common/Languages/ScaleDPI.cs.po
r158 r172 17 17 msgid "Wrong DPI [%d,%d]" 18 18 msgstr "Chybné DPI [%d,%d]" 19 -
trunk/Packages/Common/Languages/Table.cs.po
r167 r172 10 10 "Content-Type: text/plain; charset=UTF-8\n" 11 11 "Content-Transfer-Encoding: 8bit\n" 12 "X-Generator: Poedit 3. 0.1\n"12 "X-Generator: Poedit 3.4.2\n" 13 13 14 14 #: table.sunsupportedformat -
trunk/Packages/Common/Languages/TestCase.cs.po
r158 r172 26 26 msgid "Passed" 27 27 msgstr "Prošlo" 28 -
trunk/Packages/Common/Languages/Threading.cs.po
r158 r172 17 17 msgid "Current thread ID %d not found in virtual thread list." 18 18 msgstr "Aktuální vlákno ID %d nenalezeno v seznamu virtuálních vláken." 19 -
trunk/Packages/Common/ListViewSort.pas
r148 r172 136 136 constructor TListViewEx.Create(TheOwner: TComponent); 137 137 begin 138 inherited Create(TheOwner);138 inherited; 139 139 Filter := TListViewFilter.Create(Self); 140 140 Filter.Parent := Self; … … 172 172 constructor TListViewFilter.Create(AOwner: TComponent); 173 173 begin 174 inherited Create(AOwner);174 inherited; 175 175 FStringGrid1 := TStringGrid.Create(Self); 176 176 FStringGrid1.Align := alClient; -
trunk/Packages/Common/PixelPointer.pas
r148 r172 4 4 5 5 uses 6 Classes, SysUtils, Graphics;6 Math, Classes, SysUtils, Graphics; 7 7 8 8 type 9 9 TColor32 = type Cardinal; 10 10 TColor32Component = (ccBlue, ccGreen, ccRed, ccAlpha); 11 TColor32Planes = array[0..3] of Byte; 11 12 12 13 { TPixel32 } … … 14 15 TPixel32 = packed record 15 16 private 16 procedure SetRGB(AValue: Cardinal); 17 function GetRGB: Cardinal; 17 procedure SetRGB(AValue: Cardinal); inline; 18 function GetRGB: Cardinal; inline; 18 19 public 20 class function CreateRGB(R, G, B: Byte): TPixel32; static; 21 class function CreateRGBA(R, G, B, A: Byte): TPixel32; static; 19 22 property RGB: Cardinal read GetRGB write SetRGB; 20 23 case Integer of 21 24 0: (B, G, R, A: Byte); 22 25 1: (ARGB: TColor32); 23 2: (Planes: array[0..3] of Byte);26 2: (Planes: TColor32Planes); 24 27 3: (Components: array[TColor32Component] of Byte); 25 28 end; … … 29 32 30 33 TPixelPointer = record 34 private 35 function GetPixelARGB: TColor32; inline; 36 function GetPixelB: Byte; inline; 37 function GetPixelG: Byte; inline; 38 function GetPixelPlane(Index: Byte): Byte; inline; 39 function GetPixelR: Byte; inline; 40 function GetPixelA: Byte; inline; 41 function GetPixelPlanes: TColor32Planes; 42 function GetPixelRGB: Cardinal; inline; 43 procedure SetPixelARGB(Value: TColor32); inline; 44 procedure SetPixelB(Value: Byte); inline; 45 procedure SetPixelG(Value: Byte); inline; 46 procedure SetPixelPlane(Index: Byte; AValue: Byte); inline; 47 procedure SetPixelR(Value: Byte); inline; 48 procedure SetPixelA(Value: Byte); inline; 49 procedure SetPixelRGB(Value: Cardinal); inline; 50 public 31 51 Base: PPixel32; 32 52 Pixel: PPixel32; … … 35 55 BytesPerPixel: Integer; 36 56 BytesPerLine: Integer; 57 Data: PPixel32; 58 Width: Integer; 59 Height: Integer; 37 60 procedure NextLine; inline; // Move pointer to start of next line 38 61 procedure PreviousLine; inline; // Move pointer to start of previous line … … 41 64 procedure SetXY(X, Y: Integer); inline; // Set pixel position relative to base 42 65 procedure SetX(X: Integer); inline; // Set horizontal pixel position relative to base 66 procedure CheckRange; inline; // Check if current pixel position is not out of range 67 function PosValid: Boolean; 68 class function Create(Bitmap: TRasterImage; BaseX: Integer = 0; BaseY: Integer = 0): TPixelPointer; static; 69 property PixelARGB: TColor32 read GetPixelARGB write SetPixelARGB; 70 property PixelRGB: Cardinal read GetPixelRGB write SetPixelRGB; 71 property PixelB: Byte read GetPixelB write SetPixelB; 72 property PixelG: Byte read GetPixelG write SetPixelG; 73 property PixelR: Byte read GetPixelR write SetPixelR; 74 property PixelA: Byte read GetPixelA write SetPixelA; 75 property PixelPlane[Index: Byte]: Byte read GetPixelPlane write SetPixelPlane; 43 76 end; 44 77 PPixelPointer = ^TPixelPointer; 45 78 46 function PixelPointer(Bitmap: TRasterImage; BaseX: Integer = 0; BaseY: Integer = 0): TPixelPointer; inline;47 79 function SwapRedBlue(Color: TColor32): TColor32; 48 80 procedure BitmapCopyRect(DstBitmap: TRasterImage; DstRect: TRect; SrcBitmap: TRasterImage; SrcPos: TPoint); … … 63 95 implementation 64 96 97 resourcestring 98 SOutOfRange = 'Pixel pointer out of range [X: %d, Y: %d, Width: %d, Height: %d]'; 99 SWrongBitmapSize = 'Wrong bitmap size [width: %d, height: %d]'; 100 65 101 { TPixel32 } 66 102 … … 70 106 end; 71 107 108 class function TPixel32.CreateRGB(R, G, B: Byte): TPixel32; 109 begin 110 Result.R := R; 111 Result.G := G; 112 Result.B := B; 113 Result.A := 0; 114 end; 115 116 class function TPixel32.CreateRGBA(R, G, B, A: Byte): TPixel32; 117 begin 118 Result.R := R; 119 Result.G := G; 120 Result.B := B; 121 Result.A := A; 122 end; 123 72 124 procedure TPixel32.SetRGB(AValue: Cardinal); 73 125 begin 74 R := (AValue shr 16) and $ff; 75 G := (AValue shr 8) and $ff; 76 B := (AValue shr 0) and $ff; 126 ARGB := (ARGB and $ff000000) or (AValue and $ffffff); 77 127 end; 78 128 … … 112 162 end; 113 163 164 procedure TPixelPointer.CheckRange; 165 {$IFOPT R+} 166 var 167 X: Integer; 168 Y: Integer; 169 {$ENDIF} 170 begin 171 {$IFOPT R+} 172 if (PByte(Pixel) < PByte(Data)) or 173 (PByte(Pixel) >= PByte(Data) + Height * BytesPerLine) then begin 174 X := PByte(Pixel) - PByte(Data); 175 Y := Floor(X / BytesPerLine); 176 X := X - Y * BytesPerLine; 177 X := Floor(X / BytesPerPixel); 178 raise Exception.Create(Format(SOutOfRange, [X, Y, Width, Height])); 179 end; 180 {$ENDIF} 181 end; 182 183 function TPixelPointer.PosValid: Boolean; 184 begin 185 Result := not ((PByte(Pixel) < PByte(Data)) or 186 (PByte(Pixel) >= PByte(Data) + Height * BytesPerLine)); 187 end; 188 189 function TPixelPointer.GetPixelPlanes: TColor32Planes; 190 begin 191 CheckRange; 192 Result := Pixel^.Planes; 193 end; 194 195 function TPixelPointer.GetPixelRGB: Cardinal; 196 begin 197 CheckRange; 198 Result := Pixel^.RGB; 199 end; 200 201 procedure TPixelPointer.SetPixelARGB(Value: TColor32); 202 begin 203 CheckRange; 204 Pixel^.ARGB := Value; 205 end; 206 207 procedure TPixelPointer.SetPixelB(Value: Byte); 208 begin 209 CheckRange; 210 Pixel^.B := Value; 211 end; 212 213 procedure TPixelPointer.SetPixelG(Value: Byte); 214 begin 215 CheckRange; 216 Pixel^.G := Value; 217 end; 218 219 procedure TPixelPointer.SetPixelPlane(Index: Byte; AValue: Byte); 220 begin 221 CheckRange; 222 Pixel^.Planes[Index] := AValue; 223 end; 224 225 procedure TPixelPointer.SetPixelR(Value: Byte); 226 begin 227 CheckRange; 228 Pixel^.R := Value; 229 end; 230 231 procedure TPixelPointer.SetPixelA(Value: Byte); 232 begin 233 CheckRange; 234 Pixel^.A := Value; 235 end; 236 237 function TPixelPointer.GetPixelARGB: TColor32; 238 begin 239 CheckRange; 240 Result := Pixel^.ARGB; 241 end; 242 243 function TPixelPointer.GetPixelB: Byte; 244 begin 245 CheckRange; 246 Result := Pixel^.B; 247 end; 248 249 function TPixelPointer.GetPixelG: Byte; 250 begin 251 CheckRange; 252 Result := Pixel^.G; 253 end; 254 255 function TPixelPointer.GetPixelPlane(Index: Byte): Byte; 256 begin 257 CheckRange; 258 Result := Pixel^.Planes[Index]; 259 end; 260 261 function TPixelPointer.GetPixelR: Byte; 262 begin 263 CheckRange; 264 Result := Pixel^.R; 265 end; 266 267 function TPixelPointer.GetPixelA: Byte; 268 begin 269 CheckRange; 270 Result := Pixel^.A; 271 end; 272 273 procedure TPixelPointer.SetPixelRGB(Value: Cardinal); 274 begin 275 CheckRange; 276 Pixel^.RGB := Value; 277 end; 278 114 279 procedure BitmapCopyRect(DstBitmap: TRasterImage; DstRect: TRect; 115 280 SrcBitmap: TRasterImage; SrcPos: TPoint); … … 120 285 SrcBitmap.BeginUpdate(True); 121 286 DstBitmap.BeginUpdate(True); 122 SrcPtr := PixelPointer(SrcBitmap, SrcPos.X, SrcPos.Y);123 DstPtr := PixelPointer(DstBitmap, DstRect.Left, DstRect.Top);287 SrcPtr := TPixelPointer.Create(SrcBitmap, SrcPos.X, SrcPos.Y); 288 DstPtr := TPixelPointer.Create(DstBitmap, DstRect.Left, DstRect.Top); 124 289 for Y := 0 to DstRect.Height - 1 do begin 125 290 for X := 0 to DstRect.Width - 1 do begin 126 DstPtr.Pixel ^.ARGB := SrcPtr.Pixel^.ARGB;291 DstPtr.PixelARGB := SrcPtr.PixelARGB; 127 292 SrcPtr.NextPixel; 128 293 DstPtr.NextPixel; … … 150 315 SrcBitmap.BeginUpdate(True); 151 316 DstBitmap.BeginUpdate(True); 152 SrcPtr := PixelPointer(SrcBitmap, SrcRect.Left, SrcRect.Top);153 DstPtr := PixelPointer(DstBitmap, DstRect.Left, DstRect.Top);317 SrcPtr := TPixelPointer.Create(SrcBitmap, SrcRect.Left, SrcRect.Top); 318 DstPtr := TPixelPointer.Create(DstBitmap, DstRect.Left, DstRect.Top); 154 319 for Y := 0 to DstRect.Height - 1 do begin 155 320 for X := 0 to DstRect.Width - 1 do begin … … 160 325 DstPtr.SetXY(X, Y); 161 326 SrcPtr.SetXY(R.Left, R.Top); 162 C := SrcPtr.Pixel ^.ARGB;163 DstPtr.Pixel ^.ARGB := C;327 C := SrcPtr.PixelARGB; 328 DstPtr.PixelARGB := C; 164 329 for YY := 0 to R.Height - 1 do begin 165 330 for XX := 0 to R.Width - 1 do begin 166 DstPtr.Pixel ^.ARGB := C;331 DstPtr.PixelARGB := C; 167 332 DstPtr.NextPixel; 168 333 end; … … 181 346 begin 182 347 Bitmap.BeginUpdate(True); 183 Ptr := PixelPointer(Bitmap);348 Ptr := TPixelPointer.Create(Bitmap); 184 349 for Y := 0 to Bitmap.Height - 1 do begin 185 350 for X := 0 to Bitmap.Width - 1 do begin 186 Ptr.Pixel ^.ARGB := Color;351 Ptr.PixelARGB := Color; 187 352 Ptr.NextPixel; 188 353 end; … … 198 363 begin 199 364 Bitmap.BeginUpdate(True); 200 Ptr := PixelPointer(Bitmap, Rect.Left, Rect.Top);365 Ptr := TPixelPointer.Create(Bitmap, Rect.Left, Rect.Top); 201 366 for Y := 0 to Rect.Height - 1 do begin 202 367 for X := 0 to Rect.Width - 1 do begin 203 Ptr.Pixel ^.ARGB := Color;368 Ptr.PixelARGB := Color; 204 369 Ptr.NextPixel; 205 370 end; … … 215 380 begin 216 381 Bitmap.BeginUpdate(True); 217 Ptr := PixelPointer(Bitmap);382 Ptr := TPixelPointer.Create(Bitmap); 218 383 for Y := 0 to Bitmap.Height - 1 do begin 219 384 for X := 0 to Bitmap.Width - 1 do begin 220 Ptr.Pixel ^.ARGB := SwapRedBlue(Ptr.Pixel^.ARGB);385 Ptr.PixelARGB := SwapRedBlue(Ptr.PixelARGB); 221 386 Ptr.NextPixel; 222 387 end; … … 232 397 begin 233 398 Bitmap.BeginUpdate(True); 234 Ptr := PixelPointer(Bitmap);399 Ptr := TPixelPointer.Create(Bitmap); 235 400 for Y := 0 to Bitmap.Height - 1 do begin 236 401 for X := 0 to Bitmap.Width - 1 do begin 237 Ptr.Pixel ^.ARGB := Ptr.Pixel^.ARGB xor $ffffff;402 Ptr.PixelARGB := Ptr.PixelARGB xor $ffffff; 238 403 Ptr.NextPixel; 239 404 end; … … 252 417 Pixel := Color32ToPixel32(Color); 253 418 Bitmap.BeginUpdate(True); 254 Ptr := PixelPointer(Bitmap);419 Ptr := TPixelPointer.Create(Bitmap); 255 420 for Y := 0 to Bitmap.Height - 1 do begin 256 421 for X := 0 to Bitmap.Width - 1 do begin 257 A := Ptr.Pixel ^.A; //(Ptr.Pixel^.A + Pixel.A) shr 1;258 R := (Ptr.Pixel ^.R + Pixel.R) shr 1;259 G := (Ptr.Pixel ^.G + Pixel.G) shr 1;260 B := (Ptr.Pixel ^.B + Pixel.B) shr 1;261 Ptr.Pixel ^.ARGB := Color32(A, R, G, B);422 A := Ptr.PixelA; //(Ptr.PixelA + Pixel.A) shr 1; 423 R := (Ptr.PixelR + Pixel.R) shr 1; 424 G := (Ptr.PixelG + Pixel.G) shr 1; 425 B := (Ptr.PixelB + Pixel.B) shr 1; 426 Ptr.PixelARGB := Color32(A, R, G, B); 262 427 Ptr.NextPixel; 263 428 end; … … 295 460 end; 296 461 297 function PixelPointer(Bitmap: TRasterImage; BaseX: Integer;462 class function TPixelPointer.Create(Bitmap: TRasterImage; BaseX: Integer; 298 463 BaseY: Integer): TPixelPointer; 299 464 begin 465 Result.Width := Bitmap.Width; 466 Result.Height := Bitmap.Height; 467 if (Result.Width < 0) or (Result.Height < 0) then 468 raise Exception.Create(Format(SWrongBitmapSize, [Result.Width, Result.Height])); 300 469 Result.BytesPerLine := Bitmap.RawImage.Description.BytesPerLine; 301 470 Result.BytesPerPixel := Bitmap.RawImage.Description.BitsPerPixel shr 3; 471 Result.Data := PPixel32(Bitmap.RawImage.Data); 302 472 Result.Base := PPixel32(Bitmap.RawImage.Data + BaseX * Result.BytesPerPixel + 303 473 BaseY * Result.BytesPerLine); -
trunk/Packages/Common/Pool.pas
r148 r172 57 57 try 58 58 Lock.Acquire; 59 inherited SetTotalCount(AValue);59 inherited; 60 60 finally 61 61 Lock.Release; … … 67 67 try 68 68 Lock.Acquire; 69 Result := inherited GetUsedCount;69 Result := inherited; 70 70 finally 71 71 Lock.Release; … … 88 88 end; 89 89 end; 90 Result := inherited Acquire;90 Result := inherited; 91 91 finally 92 92 Lock.Release; … … 98 98 try 99 99 Lock.Acquire; 100 inherited Release(Item);100 inherited; 101 101 finally 102 102 Lock.Release; … … 113 113 begin 114 114 TotalCount := 0; 115 Lock.Free;115 FreeAndNil(Lock); 116 116 inherited; 117 117 end; -
trunk/Packages/Common/PrefixMultiplier.pas
r148 r172 31 31 ( 32 32 (ShortText: 'y'; FullText: 'yocto'; Value: 1e-24), 33 33 (ShortText: 'z'; FullText: 'zepto'; Value: 1e-21), 34 34 (ShortText: 'a'; FullText: 'atto'; Value: 1e-18), 35 35 (ShortText: 'f'; FullText: 'femto'; Value: 1e-15), … … 52 52 ( 53 53 (ShortText: 'ys'; FullText: 'yocto'; Value: 1e-24), 54 54 (ShortText: 'zs'; FullText: 'zepto'; Value: 1e-21), 55 55 (ShortText: 'as'; FullText: 'atto'; Value: 1e-18), 56 56 (ShortText: 'fs'; FullText: 'femto'; Value: 1e-15), -
trunk/Packages/Common/RegistryEx.pas
r148 r172 133 133 //CloseKey; 134 134 {$ENDIF} 135 Result := inherited OpenKey(Key, CanCreate);135 Result := inherited; 136 136 end; 137 137 -
trunk/Packages/Common/StopWatch.pas
r135 r172 13 13 TStopWatch = class 14 14 private 15 fFrequency: TLargeInteger;16 fIsRunning: Boolean;17 fIsHighResolution: Boolean;18 fStartCount, fStopCount: TLargeInteger;19 procedure SetTickStamp(var lInt : TLargeInteger);15 FFrequency: TLargeInteger; 16 FIsRunning: Boolean; 17 FIsHighResolution: Boolean; 18 FStartCount, fStopCount: TLargeInteger; 19 procedure SetTickStamp(var Value: TLargeInteger); 20 20 function GetElapsedTicks: TLargeInteger; 21 21 function GetElapsedMiliseconds: TLargeInteger; 22 22 function GetElapsed: string; 23 23 public 24 constructor Create(const startOnCreate: Boolean = False) ;24 constructor Create(const StartOnCreate: Boolean = False) ; 25 25 procedure Start; 26 26 procedure Stop; 27 property IsHighResolution : Boolean read fIsHighResolution;28 property ElapsedTicks 29 property ElapsedMiliseconds 30 property Elapsed 31 property IsRunning : Boolean read fIsRunning;27 property IsHighResolution: Boolean read FIsHighResolution; 28 property ElapsedTicks: TLargeInteger read GetElapsedTicks; 29 property ElapsedMiliseconds: TLargeInteger read GetElapsedMiliseconds; 30 property Elapsed: string read GetElapsed; 31 property IsRunning: Boolean read FIsRunning; 32 32 end; 33 33 … … 35 35 implementation 36 36 37 constructor TStopWatch.Create(const startOnCreate : boolean = false);37 constructor TStopWatch.Create(const StartOnCreate: Boolean = False); 38 38 begin 39 inherited Create; 40 41 fIsRunning := False; 39 FIsRunning := False; 42 40 43 41 {$IFDEF WINDOWS} 44 42 fIsHighResolution := QueryPerformanceFrequency(fFrequency) ; 45 43 {$ELSE} 46 fIsHighResolution := False;44 FIsHighResolution := False; 47 45 {$ENDIF} 48 if NOT fIsHighResolution then fFrequency := MSecsPerSec;46 if NOT FIsHighResolution then FFrequency := MSecsPerSec; 49 47 50 48 if StartOnCreate then Start; … … 53 51 function TStopWatch.GetElapsedTicks: TLargeInteger; 54 52 begin 55 Result := fStopCount - fStartCount;53 Result := FStopCount - FStartCount; 56 54 end; 57 55 58 procedure TStopWatch.SetTickStamp(var lInt : TLargeInteger);56 procedure TStopWatch.SetTickStamp(var Value: TLargeInteger); 59 57 begin 60 if fIsHighResolution then58 if FIsHighResolution then 61 59 {$IFDEF Windows} 62 QueryPerformanceCounter( lInt)60 QueryPerformanceCounter(Value) 63 61 {$ELSE} 64 62 {$ENDIF} 65 63 else 66 lInt := MilliSecondOf(Now);64 Value := MilliSecondOf(Now); 67 65 end; 68 66 69 67 function TStopWatch.GetElapsed: string; 70 68 var 71 dt: TDateTime;69 Elapsed: TDateTime; 72 70 begin 73 dt:= ElapsedMiliseconds / MSecsPerSec / SecsPerDay;74 result := Format('%d days, %s', [Trunc(dt), FormatDateTime('hh:nn:ss.z', Frac(dt))]) ;71 Elapsed := ElapsedMiliseconds / MSecsPerSec / SecsPerDay; 72 Result := Format('%d days, %s', [Trunc(Elapsed), FormatDateTime('hh:nn:ss.z', Frac(Elapsed))]) ; 75 73 end; 76 74 77 75 function TStopWatch.GetElapsedMiliseconds: TLargeInteger; 78 76 begin 79 Result := (MSecsPerSec * (fStopCount - fStartCount)) div fFrequency;77 Result := (MSecsPerSec * (fStopCount - FStartCount)) div FFrequency; 80 78 end; 81 79 82 80 procedure TStopWatch.Start; 83 81 begin 84 SetTickStamp( fStartCount);85 fIsRunning := True;82 SetTickStamp(FStartCount); 83 FIsRunning := True; 86 84 end; 87 85 88 86 procedure TStopWatch.Stop; 89 87 begin 90 SetTickStamp( fStopCount);91 fIsRunning := False;88 SetTickStamp(FStopCount); 89 FIsRunning := False; 92 90 end; 93 91 -
trunk/Packages/Common/Threading.pas
r148 r172 188 188 constructor TThreadList.Create; 189 189 begin 190 inherited Create;190 inherited; 191 191 end; 192 192
Note:
See TracChangeset
for help on using the changeset viewer.