Changeset 107
- Timestamp:
- Jul 19, 2024, 11:24:06 PM (4 months ago)
- Location:
- trunk
- Files:
-
- 1 added
- 19 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/Core.lfm
r89 r107 1 1 object Core: TCore 2 OnCreate = DataModuleCreate 2 3 OldCreateOrder = False 3 4 Height = 779 … … 549 550 Top = 266 550 551 end 552 object PersistentForm1: TPersistentForm 553 MinVisiblePart = 50 554 EntireVisible = False 555 Left = 656 556 Top = 432 557 end 551 558 end -
trunk/Core.pas
r74 r107 4 4 5 5 uses 6 Classes, SysUtils, Theme, ApplicationInfo, Translator ;6 Classes, SysUtils, Theme, ApplicationInfo, Translator, FormEx, PersistentForm; 7 7 8 8 type … … 12 12 TCore = class(TDataModule) 13 13 ApplicationInfo: TApplicationInfo; 14 PersistentForm1: TPersistentForm; 14 15 Translator1: TTranslator; 15 16 ThemeManager1: TThemeManager; 17 procedure DataModuleCreate(Sender: TObject); 16 18 end; 17 19 … … 24 26 {$R *.lfm} 25 27 28 { TCore } 29 30 procedure TCore.DataModuleCreate(Sender: TObject); 31 begin 32 PersistentForm1.RegistryContext := ApplicationInfo.GetRegistryContext; 33 34 TFormEx.Translator := Translator1; 35 TFormEx.ThemeManager := ThemeManager1; 36 TFormEx.PersistentForm := PersistentForm1; 37 end; 38 26 39 end. 27 40 -
trunk/Forms/FormMain.lfm
r83 r107 9 9 DesignTimePPI = 144 10 10 Menu = MainMenu1 11 OnClose = FormClose12 11 OnCreate = FormCreate 13 12 OnDeactivate = FormDeactivate … … 16 15 OnKeyUp = FormKeyUp 17 16 OnShow = FormShow 18 LCLVersion = '3. 2.0.0'17 LCLVersion = '3.4.0.0' 19 18 object StatusBar1: TStatusBar 20 19 Left = 0 21 Height = 2822 Top = 58 920 Height = 36 21 Top = 581 23 22 Width = 770 24 23 Panels = < … … 50 49 object Image1: TImage 51 50 Left = 0 52 Height = 58 951 Height = 581 53 52 Top = 0 54 53 Width = 770 -
trunk/Forms/FormMain.pas
r103 r107 4 4 5 5 uses 6 Classes, SysUtils, FileUtil, Forms, Controls, Graphics, LCLType, 6 Classes, SysUtils, FileUtil, Forms, Controls, Graphics, LCLType, FormEx, 7 7 Dialogs, ExtCtrls, ComCtrls, Menus, ActnList, Engine, Platform, Math, 8 8 DateUtils, GraphType, PersistentForm, ApplicationInfo, Translator, … … 13 13 { TFormMain } 14 14 15 TFormMain = class(TForm )15 TFormMain = class(TFormEx) 16 16 AAbout: TAction; 17 17 AShowRawImageDesc: TAction; … … 41 41 procedure AShowMapExecute(Sender: TObject); 42 42 procedure AShowRawImageDescExecute(Sender: TObject); 43 procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);44 43 procedure FormCreate(Sender: TObject); 45 44 procedure FormDestroy(Sender: TObject); … … 53 52 StartTime: TDateTime; 54 53 Drawing: Boolean; 55 FullScreenEnabled: Boolean;56 54 procedure LoadConfig; 57 55 procedure SaveConfig; 58 56 procedure UpdateInterface; 59 57 public 60 PersistentForm: TPersistentForm;61 58 Engine: TEngine; 62 59 FormNewGame: TFormNewGame; … … 145 142 begin 146 143 {$IFDEF LCLQT5} 147 MenuItem1.Visible := not FullScreen Enabled;148 MenuItem4.Visible := not FullScreen Enabled;149 MenuItem7.Visible := not FullScreen Enabled;144 MenuItem1.Visible := not FullScreen; 145 MenuItem4.Visible := not FullScreen; 146 MenuItem7.Visible := not FullScreen; 150 147 {$ELSE} 151 if FullScreen Enabledthen Menu := nil148 if FullScreen then Menu := nil 152 149 else Menu := MainMenu1; 153 150 {$ENDIF} 154 151 {$IFDEF DEBUG} 155 StatusBar1.Visible := not FullScreen Enabled;152 StatusBar1.Visible := not FullScreen; 156 153 AShowMap.Visible := True; 157 154 ANewGame.Visible := True; … … 178 175 179 176 Image1.ControlStyle := Image1.ControlStyle + [csOpaque]; 180 FullScreenEnabled := True; 181 182 PersistentForm := TPersistentForm.Create(nil); 183 PersistentForm.RegistryContext := TRegistryContext.Create(Core.Core.ApplicationInfo.RegistryRoot, 184 Core.Core.ApplicationInfo.RegistryKey); 177 FullScreen := True; 185 178 186 179 Application.OnDeactivate := FormDeactivate; … … 214 207 procedure TFormMain.AFullScreenExecute(Sender: TObject); 215 208 begin 216 FullScreenEnabled := not FullScreenEnabled; 217 PersistentForm.SetFullScreen(FullScreenEnabled); 209 FullScreen := not FullScreen; 210 TFormEx.PersistentForm.Load(Self); 211 TFormEx.PersistentForm.SetFullScreen(FullScreen); 218 212 UpdateInterface; 219 213 end; … … 244 238 end; 245 239 246 procedure TFormMain.FormClose(Sender: TObject; var CloseAction: TCloseAction);247 begin248 PersistentForm.Save(Self);249 end;250 251 240 procedure TFormMain.AExitExecute(Sender: TObject); 252 241 begin … … 282 271 procedure TFormMain.FormShow(Sender: TObject); 283 272 begin 284 PersistentForm.RegistryContext := Core.Core.ApplicationInfo.GetRegistryContext;285 PersistentForm.Load(Self, False, True);286 FullScreenEnabled := PersistentForm.FormFullScreen;287 //PersistentForm.SetFullScreen(FullScreenEnabled);288 273 UpdateInterface; 289 274 end; -
trunk/Languages/Tunneler.cs.po
r103 r107 216 216 msgstr "%0:s" 217 217 218 #: sound.splaynotsupported219 #, object-pascal-format220 msgctxt "sound.splaynotsupported"221 msgid "The play command %s does not work on your system"222 msgstr "Povel pÅehránà %s na vaÅ¡em systému nefunguje"223 224 218 #: sound.sunabletoplay 225 219 msgctxt "sound.sunabletoplay" … … 375 369 msgid "Controls" 376 370 msgstr "OvládánÃ" 371 -
trunk/Languages/Tunneler.pot
r103 r107 206 206 msgstr "" 207 207 208 #: sound.splaynotsupported209 #, object-pascal-format210 msgctxt "sound.splaynotsupported"211 msgid "The play command %s does not work on your system"212 msgstr ""213 214 208 #: sound.sunabletoplay 215 209 msgctxt "sound.sunabletoplay" -
trunk/Packages/Common/Common.pas
r74 r107 53 53 function ComputerName: string; 54 54 procedure DeleteFiles(APath, AFileSpec: string); 55 function EndsWith(Text, What: string): Boolean; 55 56 function Explode(Separator: Char; Data: string): TStringArray; 56 57 procedure ExecuteProgram(Executable: string; Parameters: array of string); … … 87 88 procedure SearchFiles(AList: TStrings; Dir: string; 88 89 FilterMethod: TFilterMethod = nil; FileNameMethod: TFileNameMethod = nil); 90 procedure SortStrings(Strings: TStrings); 89 91 function SplitString(var Text: string; Count: Word): string; 90 92 function StripTags(const S: string): string; 93 function StartsWith(Text, What: string): Boolean; 91 94 function TryHexToInt(Data: string; out Value: Integer): Boolean; 92 95 function TryBinToInt(Data: string; out Value: Integer): Boolean; 93 procedure SortStrings(Strings: TStrings);94 96 95 97 96 98 implementation 99 100 function StartsWith(Text, What: string): Boolean; 101 begin 102 Result := Copy(Text, 1, Length(Text)) = What; 103 end; 104 105 function EndsWith(Text, What: string): Boolean; 106 begin 107 Result := Copy(Text, Length(Text) - Length(What) + 1, MaxInt) = What; 108 end; 97 109 98 110 function BinToInt(BinStr : string) : Int64; -
trunk/Packages/Common/FindFile.pas
r74 r107 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
r74 r107 13 13 private 14 14 FCounter: Integer; static; 15 FFirstShow: Boolean; 15 16 protected 16 17 procedure DoShow; override; … … 19 20 procedure DoDestroy; override; 20 21 public 22 FullScreen: Boolean; 21 23 PersistentForm: TPersistentForm; static; 22 24 ThemeManager: TThemeManager; static; … … 44 46 begin 45 47 inherited; 46 PersistentForm.Load(Self); 48 if not FFirstShow and (not (csDesigning in ComponentState)) then begin 49 FFirstShow := True; 50 PersistentForm.Load(Self, False, FullScreen); 51 FullScreen := PersistentForm.FormFullScreen; 52 end; 47 53 end; 48 54 … … 68 74 end; 69 75 70 PersistentForm.Load(Self);71 76 Translator.TranslateComponentRecursive(Self); 72 77 ThemeManager.UseTheme(Self); … … 77 82 procedure TFormEx.DoClose(var CloseAction: TCloseAction); 78 83 begin 79 PersistentForm.Save(Self); 84 if (not (csDesigning in ComponentState)) then begin 85 PersistentForm.FormFullScreen := FullScreen; 86 PersistentForm.Save(Self); 87 end; 80 88 inherited; 81 89 end; -
trunk/Packages/Common/Languages.pas
r74 r107 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/Languages.cs.po
r74 r107 977 977 msgstr "ÄÃnÅ¡tina" 978 978 979 #: languages.slang_zh_hans 980 msgid "Simplified Chinese" 981 msgstr "" 982 983 #: languages.slang_zh_hant 984 msgid "Traditional Chinese" 985 msgstr "" 986 979 987 #: languages.slang_zu 980 988 msgctxt "languages.slang_zu" -
trunk/Packages/Common/Languages/Languages.pot
r74 r107 776 776 msgstr "" 777 777 778 #: languages.slang_zh_hans 779 msgid "Simplified Chinese" 780 msgstr "" 781 782 #: languages.slang_zh_hant 783 msgid "Traditional Chinese" 784 msgstr "" 785 778 786 #: languages.slang_zu 779 787 msgid "Zulu" -
trunk/Packages/Common/ListViewSort.pas
r74 r107 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/PersistentForm.pas
r74 r107 16 16 FMinVisiblePart: Integer; 17 17 FRegistryContext: TRegistryContext; 18 FResizeEventOccured: Boolean; 18 19 procedure LoadControl(Control: TControl); 19 20 procedure SaveControl(Control: TControl); 21 procedure WindowStateChange(Sender: TObject); 20 22 public 21 23 FormRestoredSize: TRect; … … 301 303 302 304 procedure TPersistentForm.SetFullScreen(State: Boolean); 305 {$IFDEF UNIX} 306 var 307 OldHandler: TNotifyEvent; 308 var 309 I: Integer; 310 {$ENDIF} 303 311 begin 304 312 if State then begin … … 312 320 end; 313 321 FormWindowState := Form.WindowState; 314 Form.WindowState := wsMaximized;315 Form.WindowState := wsNormal;316 ShowWindow(Form.Handle, SW_SHOWFULLSCREEN);317 322 {$IFDEF WINDOWS} 318 323 Form.BorderStyle := bsNone; 319 324 {$ENDIF} 325 Form.WindowState := wsFullscreen; 326 {$IFDEF UNIX} 327 // Workaround on Linux, WindowState is rewriten by WMSize event to wsNormal. 328 // We need for that even to occure 329 OldHandler := Form.OnWindowStateChange; 330 Form.OnWindowStateChange := WindowStateChange; 331 FResizeEventOccured := False; 332 for I := 0 to 10 do begin 333 if FResizeEventOccured then Break; 334 Application.ProcessMessages; 335 Sleep(1); 336 end; 337 Form.OnWindowStateChange := OldHandler; 338 {$ENDIF} 320 339 end else begin 321 340 FormFullScreen := False; 341 Form.WindowState := wsNormal; 322 342 {$IFDEF WINDOWS} 323 343 Form.BorderStyle := bsSizeable; 324 344 {$ENDIF} 325 ShowWindow(Form.Handle, SW_SHOWNORMAL);326 345 if FormWindowState = wsNormal then begin 327 346 Form.WindowState := wsNormal; … … 335 354 end; 336 355 356 procedure TPersistentForm.WindowStateChange(Sender: TObject); 357 begin 358 Form.WindowState := wsFullscreen; 359 FResizeEventOccured := True; 360 end; 361 337 362 end. -
trunk/Packages/Common/PixelPointer.pas
r74 r107 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
r74 r107 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/RegistryEx.pas
r74 r107 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
r54 r107 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
r74 r107 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.