Changeset 107


Ignore:
Timestamp:
Jul 19, 2024, 11:24:06 PM (7 weeks ago)
Author:
chronos
Message:
  • Fixed: Full screen mode switching on Windows.
  • Modified: Updated Common package.
Location:
trunk
Files:
1 added
19 edited

Legend:

Unmodified
Added
Removed

  • trunk/Core.lfm

    r89 r107  
    11object Core: TCore
     2  OnCreate = DataModuleCreate
    23  OldCreateOrder = False
    34  Height = 779
    … …  
    549550    Top = 266
    550551  end
     552  object PersistentForm1: TPersistentForm
     553    MinVisiblePart = 50
     554    EntireVisible = False
     555    Left = 656
     556    Top = 432
     557  end
    551558end

  • trunk/Core.pas

    r74 r107  
    44
    55uses
    6   Classes, SysUtils, Theme, ApplicationInfo, Translator;
     6  Classes, SysUtils, Theme, ApplicationInfo, Translator, FormEx, PersistentForm;
    77
    88type
    … …  
    1212  TCore = class(TDataModule)
    1313    ApplicationInfo: TApplicationInfo;
     14    PersistentForm1: TPersistentForm;
    1415    Translator1: TTranslator;
    1516    ThemeManager1: TThemeManager;
     17    procedure DataModuleCreate(Sender: TObject);
    1618  end;
    1719
    … …  
    2426{$R *.lfm}
    2527
     28{ TCore }
     29
     30procedure TCore.DataModuleCreate(Sender: TObject);
     31begin
     32  PersistentForm1.RegistryContext := ApplicationInfo.GetRegistryContext;
     33
     34  TFormEx.Translator := Translator1;
     35  TFormEx.ThemeManager := ThemeManager1;
     36  TFormEx.PersistentForm := PersistentForm1;
     37end;
     38
    2639end.
    2740

  • trunk/Forms/FormMain.lfm

    r83 r107  
    99  DesignTimePPI = 144
    1010  Menu = MainMenu1
    11   OnClose = FormClose
    1211  OnCreate = FormCreate
    1312  OnDeactivate = FormDeactivate
    … …  
    1615  OnKeyUp = FormKeyUp
    1716  OnShow = FormShow
    18   LCLVersion = '3.2.0.0'
     17  LCLVersion = '3.4.0.0'
    1918  object StatusBar1: TStatusBar
    2019    Left = 0
    21     Height = 28
    22     Top = 589
     20    Height = 36
     21    Top = 581
    2322    Width = 770
    2423    Panels = <   
    … …  
    5049  object Image1: TImage
    5150    Left = 0
    52     Height = 589
     51    Height = 581
    5352    Top = 0
    5453    Width = 770

  • trunk/Forms/FormMain.pas

    r103 r107  
    44
    55uses
    6   Classes, SysUtils, FileUtil, Forms, Controls, Graphics, LCLType,
     6  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, LCLType, FormEx,
    77  Dialogs, ExtCtrls, ComCtrls, Menus, ActnList, Engine, Platform, Math,
    88  DateUtils, GraphType, PersistentForm, ApplicationInfo, Translator,
    … …  
    1313  { TFormMain }
    1414
    15   TFormMain = class(TForm)
     15  TFormMain = class(TFormEx)
    1616    AAbout: TAction;
    1717    AShowRawImageDesc: TAction;
    … …  
    4141    procedure AShowMapExecute(Sender: TObject);
    4242    procedure AShowRawImageDescExecute(Sender: TObject);
    43     procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
    4443    procedure FormCreate(Sender: TObject);
    4544    procedure FormDestroy(Sender: TObject);
    … …  
    5352    StartTime: TDateTime;
    5453    Drawing: Boolean;
    55     FullScreenEnabled: Boolean;
    5654    procedure LoadConfig;
    5755    procedure SaveConfig;
    5856    procedure UpdateInterface;
    5957  public
    60     PersistentForm: TPersistentForm;
    6158    Engine: TEngine;
    6259    FormNewGame: TFormNewGame;
    … …  
    145142begin
    146143  {$IFDEF LCLQT5}
    147   MenuItem1.Visible := not FullScreenEnabled;
    148   MenuItem4.Visible := not FullScreenEnabled;
    149   MenuItem7.Visible := not FullScreenEnabled;
     144  MenuItem1.Visible := not FullScreen;
     145  MenuItem4.Visible := not FullScreen;
     146  MenuItem7.Visible := not FullScreen;
    150147  {$ELSE}
    151   if FullScreenEnabled then Menu := nil
     148  if FullScreen then Menu := nil
    152149    else Menu := MainMenu1;
    153150  {$ENDIF}
    154151  {$IFDEF DEBUG}
    155   StatusBar1.Visible := not FullScreenEnabled;
     152  StatusBar1.Visible := not FullScreen;
    156153  AShowMap.Visible := True;
    157154  ANewGame.Visible := True;
    … …  
    178175
    179176  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;
    185178
    186179  Application.OnDeactivate := FormDeactivate;
    … …  
    214207procedure TFormMain.AFullScreenExecute(Sender: TObject);
    215208begin
    216   FullScreenEnabled := not FullScreenEnabled;
    217   PersistentForm.SetFullScreen(FullScreenEnabled);
     209  FullScreen := not FullScreen;
     210  TFormEx.PersistentForm.Load(Self);
     211  TFormEx.PersistentForm.SetFullScreen(FullScreen);
    218212  UpdateInterface;
    219213end;
    … …  
    244238end;
    245239
    246 procedure TFormMain.FormClose(Sender: TObject; var CloseAction: TCloseAction);
    247 begin
    248   PersistentForm.Save(Self);
    249 end;
    250 
    251240procedure TFormMain.AExitExecute(Sender: TObject);
    252241begin
    … …  
    282271procedure TFormMain.FormShow(Sender: TObject);
    283272begin
    284   PersistentForm.RegistryContext := Core.Core.ApplicationInfo.GetRegistryContext;
    285   PersistentForm.Load(Self, False, True);
    286   FullScreenEnabled := PersistentForm.FormFullScreen;
    287   //PersistentForm.SetFullScreen(FullScreenEnabled);
    288273  UpdateInterface;
    289274end;

  • trunk/Languages/Tunneler.cs.po

    r103 r107  
    216216msgstr "%0:s"
    217217
    218 #: sound.splaynotsupported
    219 #, object-pascal-format
    220 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 
    224218#: sound.sunabletoplay
    225219msgctxt "sound.sunabletoplay"
    … …  
    375369msgid "Controls"
    376370msgstr "Ovládání"
     371

  • trunk/Languages/Tunneler.pot

    r103 r107  
    206206msgstr ""
    207207
    208 #: sound.splaynotsupported
    209 #, object-pascal-format
    210 msgctxt "sound.splaynotsupported"
    211 msgid "The play command %s does not work on your system"
    212 msgstr ""
    213 
    214208#: sound.sunabletoplay
    215209msgctxt "sound.sunabletoplay"

  • trunk/Packages/Common/Common.pas

    r74 r107  
    5353function ComputerName: string;
    5454procedure DeleteFiles(APath, AFileSpec: string);
     55function EndsWith(Text, What: string): Boolean;
    5556function Explode(Separator: Char; Data: string): TStringArray;
    5657procedure ExecuteProgram(Executable: string; Parameters: array of string);
    … …  
    8788procedure SearchFiles(AList: TStrings; Dir: string;
    8889  FilterMethod: TFilterMethod = nil; FileNameMethod: TFileNameMethod = nil);
     90procedure SortStrings(Strings: TStrings);
    8991function SplitString(var Text: string; Count: Word): string;
    9092function StripTags(const S: string): string;
     93function StartsWith(Text, What: string): Boolean;
    9194function TryHexToInt(Data: string; out Value: Integer): Boolean;
    9295function TryBinToInt(Data: string; out Value: Integer): Boolean;
    93 procedure SortStrings(Strings: TStrings);
    9496
    9597
    9698implementation
     99
     100function StartsWith(Text, What: string): Boolean;
     101begin
     102  Result := Copy(Text, 1, Length(Text)) = What;
     103end;
     104
     105function EndsWith(Text, What: string): Boolean;
     106begin
     107  Result := Copy(Text, Length(Text) - Length(What) + 1, MaxInt) = What;
     108end;
    97109
    98110function BinToInt(BinStr : string) : Int64;

  • trunk/Packages/Common/FindFile.pas

    r74 r107  
    7575constructor TFindFile.Create(AOwner: TComponent);
    7676begin
    77   inherited Create(AOwner);
     77  inherited;
    7878  Path := IncludeTrailingBackslash(UTF8Encode(GetCurrentDir));
    7979  FileMask := FilterAll;

  • trunk/Packages/Common/FormEx.pas

    r74 r107  
    1313  private
    1414    FCounter: Integer; static;
     15    FFirstShow: Boolean;
    1516  protected
    1617    procedure DoShow; override;
    … …  
    1920    procedure DoDestroy; override;
    2021  public
     22    FullScreen: Boolean;
    2123    PersistentForm: TPersistentForm; static;
    2224    ThemeManager: TThemeManager; static;
    … …  
    4446begin
    4547  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;
    4753end;
    4854
    … …  
    6874  end;
    6975
    70   PersistentForm.Load(Self);
    7176  Translator.TranslateComponentRecursive(Self);
    7277  ThemeManager.UseTheme(Self);
    … …  
    7782procedure TFormEx.DoClose(var CloseAction: TCloseAction);
    7883begin
    79   PersistentForm.Save(Self);
     84  if  (not (csDesigning in ComponentState)) then begin
     85    PersistentForm.FormFullScreen := FullScreen;
     86    PersistentForm.Save(Self);
     87  end;
    8088  inherited;
    8189end;

  • trunk/Packages/Common/Languages.pas

    r74 r107  
    216216  SLang_za = 'Zhuang';
    217217  SLang_zh = 'Chinese';
     218  SLang_zh_Hans = 'Simplified Chinese';
     219  SLang_zh_Hant = 'Traditional Chinese';
    218220  SLang_zu = 'Zulu';
     221
    219222
    220223implementation
    … …  
    228231begin
    229232  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]
    232235    else Result := nil;
    233236end;
    … …  
    439442  AddNew('za', SLang_za);
    440443  AddNew('zh', SLang_zh);
     444  AddNew('zh-Hant', SLang_zh_Hant);
     445  AddNew('zh-Hans', SLang_zh_Hans);
    441446  AddNew('zu', SLang_zu);
    442447end;

  • trunk/Packages/Common/Languages/Languages.cs.po

    r74 r107  
    977977msgstr "Čínština"
    978978
     979#: languages.slang_zh_hans
     980msgid "Simplified Chinese"
     981msgstr ""
     982
     983#: languages.slang_zh_hant
     984msgid "Traditional Chinese"
     985msgstr ""
     986
    979987#: languages.slang_zu
    980988msgctxt "languages.slang_zu"

  • trunk/Packages/Common/Languages/Languages.pot

    r74 r107  
    776776msgstr ""
    777777
     778#: languages.slang_zh_hans
     779msgid "Simplified Chinese"
     780msgstr ""
     781
     782#: languages.slang_zh_hant
     783msgid "Traditional Chinese"
     784msgstr ""
     785
    778786#: languages.slang_zu
    779787msgid "Zulu"

  • trunk/Packages/Common/ListViewSort.pas

    r74 r107  
    136136constructor TListViewEx.Create(TheOwner: TComponent);
    137137begin
    138   inherited Create(TheOwner);
     138  inherited;
    139139  Filter := TListViewFilter.Create(Self);
    140140  Filter.Parent := Self;
    … …  
    172172constructor TListViewFilter.Create(AOwner: TComponent);
    173173begin
    174   inherited Create(AOwner);
     174  inherited;
    175175  FStringGrid1 := TStringGrid.Create(Self);
    176176  FStringGrid1.Align := alClient;

  • trunk/Packages/Common/PersistentForm.pas

    r74 r107  
    1616    FMinVisiblePart: Integer;
    1717    FRegistryContext: TRegistryContext;
     18    FResizeEventOccured: Boolean;
    1819    procedure LoadControl(Control: TControl);
    1920    procedure SaveControl(Control: TControl);
     21    procedure WindowStateChange(Sender: TObject);
    2022  public
    2123    FormRestoredSize: TRect;
    … …  
    301303
    302304procedure TPersistentForm.SetFullScreen(State: Boolean);
     305{$IFDEF UNIX}
     306var
     307  OldHandler: TNotifyEvent;
     308var
     309  I: Integer;
     310{$ENDIF}
    303311begin
    304312  if State then begin
    … …  
    312320    end;
    313321    FormWindowState := Form.WindowState;
    314     Form.WindowState := wsMaximized;
    315     Form.WindowState := wsNormal;
    316     ShowWindow(Form.Handle, SW_SHOWFULLSCREEN);
    317322    {$IFDEF WINDOWS}
    318323    Form.BorderStyle := bsNone;
    319324    {$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}
    320339  end else begin
    321340    FormFullScreen := False;
     341    Form.WindowState := wsNormal;
    322342    {$IFDEF WINDOWS}
    323343    Form.BorderStyle := bsSizeable;
    324344    {$ENDIF}
    325     ShowWindow(Form.Handle, SW_SHOWNORMAL);
    326345    if FormWindowState = wsNormal then begin
    327346      Form.WindowState := wsNormal;
    … …  
    335354end;
    336355
     356procedure TPersistentForm.WindowStateChange(Sender: TObject);
     357begin
     358  Form.WindowState := wsFullscreen;
     359  FResizeEventOccured := True;
     360end;
     361
    337362end.

  • trunk/Packages/Common/PixelPointer.pas

    r74 r107  
    44
    55uses
    6   Classes, SysUtils, Graphics;
     6  Math, Classes, SysUtils, Graphics;
    77
    88type
    99  TColor32 = type Cardinal;
    1010  TColor32Component = (ccBlue, ccGreen, ccRed, ccAlpha);
     11  TColor32Planes = array[0..3] of Byte;
    1112
    1213  { TPixel32 }
    … …  
    1415  TPixel32 = packed record
    1516  private
    16     procedure SetRGB(AValue: Cardinal);
    17     function GetRGB: Cardinal;
     17    procedure SetRGB(AValue: Cardinal); inline;
     18    function GetRGB: Cardinal; inline;
    1819  public
     20    class function CreateRGB(R, G, B: Byte): TPixel32; static;
     21    class function CreateRGBA(R, G, B, A: Byte): TPixel32; static;
    1922    property RGB: Cardinal read GetRGB write SetRGB;
    2023    case Integer of
    2124      0: (B, G, R, A: Byte);
    2225      1: (ARGB: TColor32);
    23       2: (Planes: array[0..3] of Byte);
     26      2: (Planes: TColor32Planes);
    2427      3: (Components: array[TColor32Component] of Byte);
    2528  end;
    … …  
    2932
    3033  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
    3151    Base: PPixel32;
    3252    Pixel: PPixel32;
    … …  
    3555    BytesPerPixel: Integer;
    3656    BytesPerLine: Integer;
     57    Data: PPixel32;
     58    Width: Integer;
     59    Height: Integer;
    3760    procedure NextLine; inline; // Move pointer to start of next line
    3861    procedure PreviousLine; inline; // Move pointer to start of previous line
    … …  
    4164    procedure SetXY(X, Y: Integer); inline; // Set pixel position relative to base
    4265    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;
    4376  end;
    4477  PPixelPointer = ^TPixelPointer;
    4578
    46   function PixelPointer(Bitmap: TRasterImage; BaseX: Integer = 0; BaseY: Integer = 0): TPixelPointer; inline;
    4779  function SwapRedBlue(Color: TColor32): TColor32;
    4880  procedure BitmapCopyRect(DstBitmap: TRasterImage; DstRect: TRect; SrcBitmap: TRasterImage; SrcPos: TPoint);
    … …  
    6395implementation
    6496
     97resourcestring
     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
    65101{ TPixel32 }
    66102
    … …  
    70106end;
    71107
     108class function TPixel32.CreateRGB(R, G, B: Byte): TPixel32;
     109begin
     110  Result.R := R;
     111  Result.G := G;
     112  Result.B := B;
     113  Result.A := 0;
     114end;
     115
     116class function TPixel32.CreateRGBA(R, G, B, A: Byte): TPixel32;
     117begin
     118  Result.R := R;
     119  Result.G := G;
     120  Result.B := B;
     121  Result.A := A;
     122end;
     123
    72124procedure TPixel32.SetRGB(AValue: Cardinal);
    73125begin
    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);
    77127end;
    78128
    … …  
    112162end;
    113163
     164procedure TPixelPointer.CheckRange;
     165{$IFOPT R+}
     166var
     167  X: Integer;
     168  Y: Integer;
     169{$ENDIF}
     170begin
     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}
     181end;
     182
     183function TPixelPointer.PosValid: Boolean;
     184begin
     185  Result := not ((PByte(Pixel) < PByte(Data)) or
     186    (PByte(Pixel) >= PByte(Data) + Height * BytesPerLine));
     187end;
     188
     189function TPixelPointer.GetPixelPlanes: TColor32Planes;
     190begin
     191  CheckRange;
     192  Result := Pixel^.Planes;
     193end;
     194
     195function TPixelPointer.GetPixelRGB: Cardinal;
     196begin
     197  CheckRange;
     198  Result := Pixel^.RGB;
     199end;
     200
     201procedure TPixelPointer.SetPixelARGB(Value: TColor32);
     202begin
     203  CheckRange;
     204  Pixel^.ARGB := Value;
     205end;
     206
     207procedure TPixelPointer.SetPixelB(Value: Byte);
     208begin
     209  CheckRange;
     210  Pixel^.B := Value;
     211end;
     212
     213procedure TPixelPointer.SetPixelG(Value: Byte);
     214begin
     215  CheckRange;
     216  Pixel^.G := Value;
     217end;
     218
     219procedure TPixelPointer.SetPixelPlane(Index: Byte; AValue: Byte);
     220begin
     221  CheckRange;
     222  Pixel^.Planes[Index] := AValue;
     223end;
     224
     225procedure TPixelPointer.SetPixelR(Value: Byte);
     226begin
     227  CheckRange;
     228  Pixel^.R := Value;
     229end;
     230
     231procedure TPixelPointer.SetPixelA(Value: Byte);
     232begin
     233  CheckRange;
     234  Pixel^.A := Value;
     235end;
     236
     237function TPixelPointer.GetPixelARGB: TColor32;
     238begin
     239  CheckRange;
     240  Result := Pixel^.ARGB;
     241end;
     242
     243function TPixelPointer.GetPixelB: Byte;
     244begin
     245  CheckRange;
     246  Result := Pixel^.B;
     247end;
     248
     249function TPixelPointer.GetPixelG: Byte;
     250begin
     251  CheckRange;
     252  Result := Pixel^.G;
     253end;
     254
     255function TPixelPointer.GetPixelPlane(Index: Byte): Byte;
     256begin
     257  CheckRange;
     258  Result := Pixel^.Planes[Index];
     259end;
     260
     261function TPixelPointer.GetPixelR: Byte;
     262begin
     263  CheckRange;
     264  Result := Pixel^.R;
     265end;
     266
     267function TPixelPointer.GetPixelA: Byte;
     268begin
     269  CheckRange;
     270  Result := Pixel^.A;
     271end;
     272
     273procedure TPixelPointer.SetPixelRGB(Value: Cardinal);
     274begin
     275  CheckRange;
     276  Pixel^.RGB := Value;
     277end;
     278
    114279procedure BitmapCopyRect(DstBitmap: TRasterImage; DstRect: TRect;
    115280  SrcBitmap: TRasterImage; SrcPos: TPoint);
    … …  
    120285  SrcBitmap.BeginUpdate(True);
    121286  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);
    124289  for Y := 0 to DstRect.Height - 1 do begin
    125290    for X := 0 to DstRect.Width - 1 do begin
    126       DstPtr.Pixel^.ARGB := SrcPtr.Pixel^.ARGB;
     291      DstPtr.PixelARGB := SrcPtr.PixelARGB;
    127292      SrcPtr.NextPixel;
    128293      DstPtr.NextPixel;
    … …  
    150315  SrcBitmap.BeginUpdate(True);
    151316  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);
    154319  for Y := 0 to DstRect.Height - 1 do begin
    155320    for X := 0 to DstRect.Width - 1 do begin
    … …  
    160325      DstPtr.SetXY(X, Y);
    161326      SrcPtr.SetXY(R.Left, R.Top);
    162       C := SrcPtr.Pixel^.ARGB;
    163       DstPtr.Pixel^.ARGB := C;
     327      C := SrcPtr.PixelARGB;
     328      DstPtr.PixelARGB := C;
    164329      for YY := 0 to R.Height - 1 do begin
    165330        for XX := 0 to R.Width - 1 do begin
    166           DstPtr.Pixel^.ARGB := C;
     331          DstPtr.PixelARGB := C;
    167332          DstPtr.NextPixel;
    168333        end;
    … …  
    181346begin
    182347  Bitmap.BeginUpdate(True);
    183   Ptr := PixelPointer(Bitmap);
     348  Ptr := TPixelPointer.Create(Bitmap);
    184349  for Y := 0 to Bitmap.Height - 1 do begin
    185350    for X := 0 to Bitmap.Width - 1 do begin
    186       Ptr.Pixel^.ARGB := Color;
     351      Ptr.PixelARGB := Color;
    187352      Ptr.NextPixel;
    188353    end;
    … …  
    198363begin
    199364  Bitmap.BeginUpdate(True);
    200   Ptr := PixelPointer(Bitmap, Rect.Left, Rect.Top);
     365  Ptr := TPixelPointer.Create(Bitmap, Rect.Left, Rect.Top);
    201366  for Y := 0 to Rect.Height - 1 do begin
    202367    for X := 0 to Rect.Width - 1 do begin
    203       Ptr.Pixel^.ARGB := Color;
     368      Ptr.PixelARGB := Color;
    204369      Ptr.NextPixel;
    205370    end;
    … …  
    215380begin
    216381  Bitmap.BeginUpdate(True);
    217   Ptr := PixelPointer(Bitmap);
     382  Ptr := TPixelPointer.Create(Bitmap);
    218383  for Y := 0 to Bitmap.Height - 1 do begin
    219384    for X := 0 to Bitmap.Width - 1 do begin
    220       Ptr.Pixel^.ARGB := SwapRedBlue(Ptr.Pixel^.ARGB);
     385      Ptr.PixelARGB := SwapRedBlue(Ptr.PixelARGB);
    221386      Ptr.NextPixel;
    222387    end;
    … …  
    232397begin
    233398  Bitmap.BeginUpdate(True);
    234   Ptr := PixelPointer(Bitmap);
     399  Ptr := TPixelPointer.Create(Bitmap);
    235400  for Y := 0 to Bitmap.Height - 1 do begin
    236401    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;
    238403      Ptr.NextPixel;
    239404    end;
    … …  
    252417  Pixel := Color32ToPixel32(Color);
    253418  Bitmap.BeginUpdate(True);
    254   Ptr := PixelPointer(Bitmap);
     419  Ptr := TPixelPointer.Create(Bitmap);
    255420  for Y := 0 to Bitmap.Height - 1 do begin
    256421    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);
    262427      Ptr.NextPixel;
    263428    end;
    … …  
    295460end;
    296461
    297 function PixelPointer(Bitmap: TRasterImage; BaseX: Integer;
     462class function TPixelPointer.Create(Bitmap: TRasterImage; BaseX: Integer;
    298463  BaseY: Integer): TPixelPointer;
    299464begin
     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]));
    300469  Result.BytesPerLine := Bitmap.RawImage.Description.BytesPerLine;
    301470  Result.BytesPerPixel := Bitmap.RawImage.Description.BitsPerPixel shr 3;
     471  Result.Data := PPixel32(Bitmap.RawImage.Data);
    302472  Result.Base := PPixel32(Bitmap.RawImage.Data + BaseX * Result.BytesPerPixel +
    303473    BaseY * Result.BytesPerLine);

  • trunk/Packages/Common/Pool.pas

    r74 r107  
    5757  try
    5858    Lock.Acquire;
    59     inherited SetTotalCount(AValue);
     59    inherited;
    6060  finally
    6161    Lock.Release;
    … …  
    6767  try
    6868    Lock.Acquire;
    69     Result := inherited GetUsedCount;
     69    Result := inherited;
    7070  finally
    7171    Lock.Release;
    … …  
    8888      end;
    8989    end;
    90     Result := inherited Acquire;
     90    Result := inherited;
    9191  finally
    9292    Lock.Release;
    … …  
    9898  try
    9999    Lock.Acquire;
    100     inherited Release(Item);
     100    inherited;
    101101  finally
    102102    Lock.Release;
    … …  
    113113begin
    114114  TotalCount := 0;
    115   Lock.Free;
     115  FreeAndNil(Lock);
    116116  inherited;
    117117end;

  • trunk/Packages/Common/RegistryEx.pas

    r74 r107  
    133133  //CloseKey;
    134134  {$ENDIF}
    135   Result := inherited OpenKey(Key, CanCreate);
     135  Result := inherited;
    136136end;
    137137

  • trunk/Packages/Common/StopWatch.pas

    r54 r107  
    1313  TStopWatch = class
    1414  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);
    2020    function GetElapsedTicks: TLargeInteger;
    2121    function GetElapsedMiliseconds: TLargeInteger;
    2222    function GetElapsed: string;
    2323  public
    24     constructor Create(const startOnCreate : Boolean = False) ;
     24    constructor Create(const StartOnCreate: Boolean = False) ;
    2525    procedure Start;
    2626    procedure Stop;
    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;
     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;
    3232  end;
    3333
    … …  
    3535implementation
    3636
    37 constructor TStopWatch.Create(const startOnCreate : boolean = false) ;
     37constructor TStopWatch.Create(const StartOnCreate: Boolean = False);
    3838begin
    39   inherited Create;
    40 
    41   fIsRunning := False;
     39  FIsRunning := False;
    4240
    4341  {$IFDEF WINDOWS}
    4442  fIsHighResolution := QueryPerformanceFrequency(fFrequency) ;
    4543  {$ELSE}
    46   fIsHighResolution := False;
     44  FIsHighResolution := False;
    4745  {$ENDIF}
    48   if NOT fIsHighResolution then fFrequency := MSecsPerSec;
     46  if NOT FIsHighResolution then FFrequency := MSecsPerSec;
    4947
    5048  if StartOnCreate then Start;
    … …  
    5351function TStopWatch.GetElapsedTicks: TLargeInteger;
    5452begin
    55   Result := fStopCount - fStartCount;
     53  Result := FStopCount - FStartCount;
    5654end;
    5755
    58 procedure TStopWatch.SetTickStamp(var lInt : TLargeInteger) ;
     56procedure TStopWatch.SetTickStamp(var Value: TLargeInteger);
    5957begin
    60   if fIsHighResolution then
     58  if FIsHighResolution then
    6159    {$IFDEF Windows}
    62     QueryPerformanceCounter(lInt)
     60    QueryPerformanceCounter(Value)
    6361    {$ELSE}
    6462    {$ENDIF}
    6563  else
    66     lInt := MilliSecondOf(Now) ;
     64    Value := MilliSecondOf(Now);
    6765end;
    6866
    6967function TStopWatch.GetElapsed: string;
    7068var
    71   dt: TDateTime;
     69  Elapsed: TDateTime;
    7270begin
    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))]) ;
    7573end;
    7674
    7775function TStopWatch.GetElapsedMiliseconds: TLargeInteger;
    7876begin
    79   Result := (MSecsPerSec * (fStopCount - fStartCount)) div fFrequency;
     77  Result := (MSecsPerSec * (fStopCount - FStartCount)) div FFrequency;
    8078end;
    8179
    8280procedure TStopWatch.Start;
    8381begin
    84   SetTickStamp(fStartCount);
    85   fIsRunning := True;
     82  SetTickStamp(FStartCount);
     83  FIsRunning := True;
    8684end;
    8785
    8886procedure TStopWatch.Stop;
    8987begin
    90   SetTickStamp(fStopCount);
    91   fIsRunning := False;
     88  SetTickStamp(FStopCount);
     89  FIsRunning := False;
    9290end;
    9391

  • trunk/Packages/Common/Threading.pas

    r74 r107  
    188188constructor TThreadList.Create;
    189189begin
    190   inherited Create;
     190  inherited;
    191191end;
    192192
Note: See TracChangeset for help on using the changeset viewer.