Changeset 463
- Timestamp:
- Nov 29, 2023, 2:35:44 PM (13 months ago)
- Location:
- branches/highdpi/Packages
- Files:
-
- 9 added
- 18 edited
- 1 copied
- 50 moved
Legend:
- Unmodified
- Added
- Removed
-
branches/highdpi/Packages/CevoComponents/AsyncProcess2.pas
r307 r463 122 122 123 123 end. 124 -
branches/highdpi/Packages/CevoComponents/BaseWin.pas
r412 r463 8 8 9 9 type 10 TShowNewContent = procedure (NewMode: Integer; HelpContext: string) of object; 10 TWindowMode = (wmNone, wmModal, wmPersistent, wmSubmodal); 11 TShowNewContent = procedure (NewMode: TWindowMode; HelpContext: string) of object; 11 12 12 13 { TBufferedDrawDlg } 13 14 14 15 TBufferedDrawDlg = class(TDrawDlg) 16 protected 17 FWindowMode: TWindowMode; 18 ModalFrameIndent: Integer; 19 HelpContext: string; 20 procedure ShowNewContent(NewMode: TWindowMode; ForceClose: Boolean = False); 21 procedure MarkUsedOffscreen(xMax, yMax: Integer); 22 procedure OffscreenPaint; virtual; 23 procedure VPaint; virtual; 15 24 public 16 25 UserLeft: Integer; 17 26 UserTop: Integer; 27 UsedOffscreenWidth: Integer; 28 UsedOffscreenHeight: Integer; 29 Offscreen: TDpiBitmap; 30 OffscreenUser: TDpiForm; 18 31 constructor Create(AOwner: TComponent); override; 19 32 destructor Destroy; override; … … 22 35 procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); 23 36 procedure FormDeactivate(Sender: TObject); 24 procedure SmartUpdateContent(ImmUpdate: Boolean = false);37 procedure SmartUpdateContent(ImmUpdate: Boolean = False); 25 38 procedure StayOnTop_Workaround; 26 protected 27 FWindowMode: Integer; 28 ModalFrameIndent: Integer; 29 HelpContext: string; 30 procedure ShowNewContent(NewMode: Integer; ForceClose: Boolean = False); 31 procedure MarkUsedOffscreen(xMax, yMax: Integer); 32 procedure OffscreenPaint; virtual; 33 procedure VPaint; virtual; 34 public 35 UsedOffscreenWidth: Integer; 36 UsedOffscreenHeight: Integer; 37 Offscreen: TDpiBitmap; 38 OffscreenUser: TDpiForm; 39 property WindowMode: integer read FWindowMode; 39 property WindowMode: TWindowMode read FWindowMode; 40 40 end; 41 41 42 42 TFramedDlg = class(TBufferedDrawDlg) 43 public44 constructor Create(AOwner: TComponent); override;45 procedure FormCreate(Sender: TObject);46 procedure SmartInvalidate; override;47 43 protected 48 44 CaptionLeft: Integer; 49 45 CaptionRight: Integer; 50 46 InnerWidth: Integer; 51 InnerHeight: integer;47 InnerHeight: Integer; 52 48 WideBottom: Boolean; 53 49 FullCaption: Boolean; … … 57 53 procedure VPaint; override; 58 54 procedure FillOffscreen(Left, Top, Width, Height: Integer); 55 public 56 constructor Create(AOwner: TComponent); override; 57 procedure FormCreate(Sender: TObject); 58 procedure SmartInvalidate; override; 59 59 end; 60 60 … … 64 64 65 65 const 66 // window modes67 wmNone = 0;68 wmModal = $1;69 wmPersistent = $2;70 wmSubmodal = $3;71 72 66 yUnused = 161; 73 67 NarrowFrame = 11; … … 76 70 77 71 procedure CreateOffscreen(var Offscreen: TDpiBitmap); 72 function WindowModeMakePersistent(Mode: TWindowMode): TWindowMode; 78 73 procedure Register; 79 74 … … 83 78 uses 84 79 ButtonBase, Area; 80 81 function WindowModeMakePersistent(Mode: TWindowMode): TWindowMode; 82 begin 83 if Mode = wmModal then Result := wmSubmodal 84 else Result := wmPersistent; 85 end; 85 86 86 87 procedure Register; … … 118 119 UserTop := Top; 119 120 end; 120 if OffscreenUser = self then121 if OffscreenUser = Self then 121 122 OffscreenUser := nil; 122 123 end; … … 124 125 procedure TBufferedDrawDlg.FormPaint(Sender: TObject); 125 126 begin 126 if OffscreenUser <> self then127 if OffscreenUser <> Self then 127 128 OffscreenPaint; 128 129 VPaint; … … 142 143 if Key = VK_F1 then begin 143 144 if Assigned(ShowNewContentProc) then 144 ShowNewContentProc( FWindowMode or wmPersistent, HelpContext);145 ShowNewContentProc(WindowModeMakePersistent(FWindowMode), HelpContext); 145 146 end else 146 147 if FWindowMode = wmPersistent then begin … … 165 166 procedure TBufferedDrawDlg.VPaint; 166 167 begin 167 DpiBit Canvas(Canvas, 0, 0, ClientWidth, ClientHeight, Offscreen.Canvas, 0, 0);168 end; 169 170 procedure TBufferedDrawDlg.ShowNewContent(NewMode: Integer;168 DpiBitBltCanvas(Canvas, 0, 0, ClientWidth, ClientHeight, Offscreen.Canvas, 0, 0); 169 end; 170 171 procedure TBufferedDrawDlg.ShowNewContent(NewMode: TWindowMode; 171 172 ForceClose: Boolean); 172 173 begin … … 178 179 UserLeft := Left; 179 180 UserTop := Top; 180 Visible := false;181 Visible := False; 181 182 FWindowMode := NewMode; 182 183 ShowModal; … … 184 185 else if forceclose then 185 186 begin // make modal 186 Visible := false;187 Visible := False; 187 188 FWindowMode := NewMode; 188 189 Left := UserLeft; … … 204 205 Left := UserLeft; 205 206 Top := UserTop; 206 if FWindowMode = wmModal then 207 ShowModal 207 if FWindowMode = wmModal then begin 208 Gtk2Fix; 209 ShowModal; 210 end 208 211 else 209 212 Show; … … 268 271 procedure TFramedDlg.SmartInvalidate; 269 272 var 270 i, BottomFrame: integer;273 I, BottomFrame: Integer; 271 274 r0, r1: HRgn; 272 275 begin … … 277 280 r0 := DpiCreateRectRgn(SideFrame, TitleHeight, ClientWidth - SideFrame, 278 281 ClientHeight - BottomFrame); 279 for i:= 0 to ControlCount - 1 do280 if not(Controls[ i] is TArea) and Controls[i].Visible then282 for I := 0 to ControlCount - 1 do 283 if not(Controls[I] is TArea) and Controls[I].Visible then 281 284 begin 282 with Controls[ i].BoundsRect do285 with Controls[I].BoundsRect do 283 286 r1 := DpiCreateRectRgn(Left, Top, Right, Bottom); 284 287 CombineRgn(r0, r0, r1, RGN_DIFF); … … 291 294 procedure TFramedDlg.VPaint; 292 295 293 procedure CornerFrame(x0, y0, x1, y1: integer);296 procedure CornerFrame(x0, y0, x1, y1: Integer); 294 297 begin 295 298 Frame(Canvas, x0 + 1, y0 + 1, x1 - 2, y1 - 2, MainTexture.ColorBevelLight, … … 304 307 305 308 var 306 i, l, FrameTop, FrameBottom, InnerBottom, Cut, xTexOffset,307 yTexOffset: integer;309 I, L, FrameTop, FrameBottom, InnerBottom, Cut, xTexOffset, 310 yTexOffset: Integer; 308 311 R: TRect; 309 312 begin … … 317 320 end; 318 321 Canvas.Font.Assign(UniFont[ftCaption]); 319 l:= BiColorTextWidth(Canvas, Caption);320 Cut := (ClientWidth - l) div 2;322 L := BiColorTextWidth(Canvas, Caption); 323 Cut := (ClientWidth - L) div 2; 321 324 xTexOffset := (Maintexture.Width - ClientWidth) div 2; 322 325 yTexOffset := (Maintexture.Height - ClientHeight) div 2; … … 442 445 RisedTextOut(Canvas, Cut - 1, 7, Caption); 443 446 444 for i:= 0 to ControlCount - 1 do445 if Controls[ i].Visible and (Controls[i] is TButtonBase) then447 for I := 0 to ControlCount - 1 do 448 if Controls[I].Visible and (Controls[I] is TButtonBase) then 446 449 begin 447 R := Controls[ i].BoundsRect;450 R := Controls[I].BoundsRect; 448 451 if (R.Bottom <= TitleHeight) or (R.Top >= InnerBottom) then 449 452 BtnFrame(Canvas, R, MainTexture); 450 453 end; 451 454 452 DpiBit Canvas(Canvas, SideFrame, TitleHeight, ClientWidth - 2 * SideFrame,455 DpiBitBltCanvas(Canvas, SideFrame, TitleHeight, ClientWidth - 2 * SideFrame, 453 456 InnerBottom - TitleHeight, Offscreen.Canvas, 0, 0); 454 457 end; … … 459 462 begin 460 463 if FullCaption then 461 exit;464 Exit; 462 465 r0 := DpiCreateRectRgn(0, 0, ClientWidth, ClientHeight); 463 466 r1 := DpiCreateRectRgn(0, 0, CaptionLeft, TitleHeight - NarrowFrame); … … 509 512 MainFormKeyDown := nil; 510 513 511 finalization512 513 514 end. -
branches/highdpi/Packages/CevoComponents/ButtonA.pas
r349 r463 46 46 with Canvas do 47 47 if FGraphic <> nil then begin 48 DpiBit Canvas(Canvas, 0, 0, 100, 25, Graphic.Canvas, 195,48 DpiBitBltCanvas(Canvas, 0, 0, 100, 25, Graphic.Canvas, 195, 49 49 243 + 26 * Byte(Down)); 50 50 Canvas.Brush.Style := bsClear; … … 54 54 end else begin 55 55 Brush.Color := $0000FF; 56 FrameRect(Rect(0, 0, 100, 25)) 56 FrameRect(Rect(0, 0, 100, 25)); 57 57 end; 58 58 end; -
branches/highdpi/Packages/CevoComponents/ButtonB.pas
r303 r463 11 11 private 12 12 FMask: TDpiBitmap; 13 FIndex: integer;14 procedure SetIndex(Text: integer);13 FIndex: Integer; 14 procedure SetIndex(Text: Integer); 15 15 public 16 16 property Mask: TDpiBitmap read FMask write FMask; 17 17 published 18 18 property Visible; 19 property ButtonIndex: integer read FIndex write SetIndex;19 property ButtonIndex: Integer read FIndex write SetIndex; 20 20 property OnClick; 21 21 protected … … 47 47 with Canvas do 48 48 if FGraphic <> nil then begin 49 DpiBit Canvas(Canvas, 0, 0, 25, 25, FGraphic.Canvas, 169,49 DpiBitBltCanvas(Canvas, 0, 0, 25, 25, FGraphic.Canvas, 169, 50 50 243 + 26 * Byte(FDown)); 51 51 if FIndex >= 0 then begin 52 DpiBit Canvas(Canvas, 0, 0, 25, 25, FMask.Canvas,52 DpiBitBltCanvas(Canvas, 0, 0, 25, 25, FMask.Canvas, 53 53 1 + FIndex mod 12 * 26, 337 + FIndex div 12 * 26, SRCAND); 54 DpiBit Canvas(Canvas, 0, 0, 25, 25, FGraphic.Canvas,54 DpiBitBltCanvas(Canvas, 0, 0, 25, 25, FGraphic.Canvas, 55 55 1 + FIndex mod 12 * 26, 337 + FIndex div 12 * 26, SRCPAINT); 56 end 56 end; 57 57 end else begin 58 58 Brush.Color := $0000FF; … … 61 61 end; 62 62 63 procedure TButtonB.SetIndex(Text: integer);63 procedure TButtonB.SetIndex(Text: Integer); 64 64 begin 65 65 if Text <> FIndex then begin -
branches/highdpi/Packages/CevoComponents/ButtonBase.pas
r361 r463 9 9 TButtonBase = class(TDpiGraphicControl) 10 10 protected 11 FDown, FPermanent: boolean; 11 FDown: Boolean; 12 FPermanent: Boolean; 12 13 FGraphic: TDpiBitmap; 13 14 // FDownSound, FUpSound: string; 14 15 ClickProc: TNotifyEvent; 15 16 DownChangedProc: TNotifyEvent; 16 procedure SetDown( x: boolean);17 procedure SetDown(X: Boolean); 17 18 // procedure PlayDownSound; 18 19 // procedure PlayUpSound; 19 20 procedure MouseDown(Button: TMouseButton; Shift: TShiftState; 20 x, y: integer); override;21 X, Y: Integer); override; 21 22 procedure MouseUp(Button: TMouseButton; Shift: TShiftState; 22 x, y: integer); override;23 procedure MouseMove(Shift: TShiftState; x, y: integer); override;23 X, Y: Integer); override; 24 procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; 24 25 private 25 Active: boolean;26 Active: Boolean; 26 27 public 27 28 constructor Create(aOwner: TComponent); override; … … 31 32 published 32 33 property Visible; 33 property Down: boolean read FDown write SetDown;34 property Permanent: boolean read FPermanent write FPermanent;34 property Down: Boolean read FDown write SetDown; 35 property Permanent: Boolean read FPermanent write FPermanent; 35 36 property OnClick: TNotifyEvent read ClickProc write ClickProc; 36 37 property OnDownChanged: TNotifyEvent read DownChangedProc … … 49 50 // FUpSound:=''; 50 51 FGraphic := nil; 51 Active := false;52 FDown := false;53 FPermanent := false;52 Active := False; 53 FDown := False; 54 FPermanent := False; 54 55 ClickProc := nil; 55 56 end; 56 57 57 58 procedure TButtonBase.MouseDown(Button: TMouseButton; Shift: TShiftState; 58 x, y: integer);59 X, Y: Integer); 59 60 begin 60 Active := true;61 MouseMove(Shift, x, y)61 Active := True; 62 MouseMove(Shift, X, Y); 62 63 end; 63 64 64 65 procedure TButtonBase.MouseUp(Button: TMouseButton; Shift: TShiftState; 65 x, y: integer);66 X, Y: Integer); 66 67 begin 67 68 if ssLeft in Shift then 68 exit;69 MouseMove(Shift, x, y);69 Exit; 70 MouseMove(Shift, X, Y); 70 71 if Active and FDown then 71 72 begin 72 73 // PlayUpSound; 73 Active := false;74 Active := False; 74 75 if FDown <> FPermanent then 75 76 begin … … 85 86 begin 86 87 // if FDown then PlayUpSound; 87 Active := false;88 Active := False; 88 89 if FDown then 89 90 begin 90 FDown := false;91 FDown := False; 91 92 Invalidate; 92 93 if @DownChangedProc <> nil then 93 94 DownChangedProc(self); 94 95 end; 95 end 96 end; 96 97 end; 97 98 98 procedure TButtonBase.MouseMove(Shift: TShiftState; x, y: integer);99 procedure TButtonBase.MouseMove(Shift: TShiftState; X, Y: Integer); 99 100 begin 100 101 if Active then 101 if ( x >= 0) and (x < Width) and (y >= 0) and (y< Height) then102 if (X >= 0) and (X < Width) and (Y >= 0) and (Y < Height) then 102 103 if (ssLeft in Shift) and not FDown then 103 104 begin 104 105 { PlayDownSound; } 105 FDown := true;106 FDown := True; 106 107 Paint; 107 108 if @DownChangedProc <> nil then … … 112 113 begin 113 114 { PlayUpSound; } 114 FDown := false;115 FDown := False; 115 116 Paint; 116 117 if @DownChangedProc <> nil then … … 119 120 end; 120 121 121 procedure TButtonBase.SetDown( x: boolean);122 procedure TButtonBase.SetDown(X: Boolean); 122 123 begin 123 FDown := x;124 FDown := X; 124 125 Invalidate; 125 126 end; -
branches/highdpi/Packages/CevoComponents/ButtonC.pas
r303 r463 14 14 published 15 15 property Visible; 16 property ButtonIndex: integer read FIndex write SetIndex;16 property ButtonIndex: Integer read FIndex write SetIndex; 17 17 property OnClick; 18 18 protected … … 41 41 with Canvas do 42 42 if FGraphic <> nil then 43 DpiBit Canvas(Canvas, 0, 0, 12, 12, FGraphic.Canvas,43 DpiBitBltCanvas(Canvas, 0, 0, 12, 12, FGraphic.Canvas, 44 44 169 + 13 * Byte(FDown), 159 + 13 * FIndex) 45 45 else 46 46 begin 47 47 Brush.Color := $0000FF; 48 FrameRect(Rect(0, 0, 12, 12)) 48 FrameRect(Rect(0, 0, 12, 12)); 49 49 end; 50 50 end; 51 51 52 procedure TButtonC.SetIndex(Text: integer);52 procedure TButtonC.SetIndex(Text: Integer); 53 53 begin 54 54 if Text <> FIndex then -
branches/highdpi/Packages/CevoComponents/ButtonN.pas
r303 r463 10 10 constructor Create(aOwner: TComponent); override; 11 11 private 12 FPossible, FLit: boolean;12 FPossible, FLit: Boolean; 13 13 FGraphic, FMask, FBackGraphic: TDpiBitmap; 14 FIndex, BackIndex: integer;14 FIndex, BackIndex: Integer; 15 15 FSmartHint: string; 16 16 ChangeProc: TNotifyEvent; 17 procedure SetPossible( x: boolean);18 procedure SetLit( x: boolean);19 procedure SetIndex( x: integer);20 procedure SetSmartHint( x: string);17 procedure SetPossible(X: Boolean); 18 procedure SetLit(X: Boolean); 19 procedure SetIndex(X: Integer); 20 procedure SetSmartHint(X: string); 21 21 published 22 property Possible: boolean read FPossible write SetPossible;23 property Lit: boolean read FLit write SetLit;22 property Possible: Boolean read FPossible write SetPossible; 23 property Lit: Boolean read FLit write SetLit; 24 24 property SmartHint: string read FSmartHint write SetSmartHint; 25 25 property Graphic: TDpiBitmap read FGraphic write FGraphic; 26 26 property Mask: TDpiBitmap read FMask write FMask; 27 27 property BackGraphic: TDpiBitmap read FBackGraphic write FBackGraphic; 28 property ButtonIndex: integer read FIndex write SetIndex;28 property ButtonIndex: Integer read FIndex write SetIndex; 29 29 property OnClick: TNotifyEvent read ChangeProc write ChangeProc; 30 30 protected 31 31 procedure Paint; override; 32 32 procedure MouseDown(Button: TMouseButton; Shift: TShiftState; 33 x, y: integer); override;33 X, Y: Integer); override; 34 34 end; 35 35 … … 46 46 begin 47 47 inherited; 48 ShowHint := true;48 ShowHint := True; 49 49 FGraphic := nil; 50 50 FBackGraphic := nil; 51 FPossible := true;52 FLit := false;51 FPossible := True; 52 FLit := False; 53 53 FIndex := -1; 54 54 ChangeProc := nil; … … 62 62 if FGraphic <> nil then 63 63 begin 64 DpiBit Canvas(Canvas, 1, 1, 40, 40, FBackGraphic.Canvas,65 1 + 80 * BackIndex + 40 * byte(FPossible and FLit), 176);64 DpiBitBltCanvas(Canvas, 1, 1, 40, 40, FBackGraphic.Canvas, 65 1 + 80 * BackIndex + 40 * Byte(FPossible and FLit), 176); 66 66 if FPossible then 67 67 begin 68 DpiBit Canvas(Canvas, 3, 3, 36, 36, FMask.Canvas,68 DpiBitBltCanvas(Canvas, 3, 3, 36, 36, FMask.Canvas, 69 69 195 + 37 * (FIndex mod 3), 21 + 37 * (FIndex div 3), SRCAND); 70 DpiBit Canvas(Canvas, 3, 3, 36, 36, FGraphic.Canvas,70 DpiBitBltCanvas(Canvas, 3, 3, 36, 36, FGraphic.Canvas, 71 71 195 + 37 * (FIndex mod 3), 21 + 37 * (FIndex div 3), SRCPAINT); 72 72 end; … … 83 83 84 84 procedure TButtonN.MouseDown(Button: TMouseButton; Shift: TShiftState; 85 x, y: integer);85 X, Y: Integer); 86 86 begin 87 87 if FPossible and (Button = mbLeft) and (@ChangeProc <> nil) then … … 89 89 end; 90 90 91 procedure TButtonN.SetPossible( x: boolean);91 procedure TButtonN.SetPossible(X: Boolean); 92 92 begin 93 if x<> FPossible then93 if X <> FPossible then 94 94 begin 95 FPossible := x;96 if xthen95 FPossible := X; 96 if X then 97 97 Hint := FSmartHint 98 98 else … … 102 102 end; 103 103 104 procedure TButtonN.SetLit( x: boolean);104 procedure TButtonN.SetLit(X: Boolean); 105 105 begin 106 if x<> FLit then106 if X <> FLit then 107 107 begin 108 FLit := x;108 FLit := X; 109 109 Invalidate; 110 110 end; 111 111 end; 112 112 113 procedure TButtonN.SetIndex( x: integer);113 procedure TButtonN.SetIndex(X: Integer); 114 114 begin 115 if x<> FIndex then115 if X <> FIndex then 116 116 begin 117 FIndex := x;118 if x< 6 then117 FIndex := X; 118 if X < 6 then 119 119 BackIndex := 1 120 120 else … … 124 124 end; 125 125 126 procedure TButtonN.SetSmartHint( x: string);126 procedure TButtonN.SetSmartHint(X: string); 127 127 begin 128 if x<> FSmartHint then128 if X <> FSmartHint then 129 129 begin 130 FSmartHint := x;130 FSmartHint := X; 131 131 if FPossible then 132 Hint := x;132 Hint := X; 133 133 end; 134 134 end; -
branches/highdpi/Packages/CevoComponents/CevoComponents.lpk
r405 r463 1 1 <?xml version="1.0" encoding="UTF-8"?> 2 2 <CONFIG> 3 <Package Version=" 4">3 <Package Version="5"> 4 4 <PathDelim Value="\"/> 5 5 <Name Value="CevoComponents"/> … … 103 103 </Item14> 104 104 <Item15> 105 <Filename Value=" UGraphicSet.pas"/>106 <UnitName Value=" UGraphicSet"/>105 <Filename Value="GraphicSet.pas"/> 106 <UnitName Value="GraphicSet"/> 107 107 </Item15> 108 108 <Item16> 109 <Filename Value=" UTexture.pas"/>110 <UnitName Value=" UTexture"/>109 <Filename Value="Texture.pas"/> 110 <UnitName Value="Texture"/> 111 111 </Item16> 112 112 </Files> 113 <CompatibilityMode Value="True"/> 113 114 <RequiredPkgs Count="3"> 114 115 <Item1> -
branches/highdpi/Packages/CevoComponents/CevoComponents.pas
r405 r463 10 10 uses 11 11 Area, ButtonA, ButtonB, ButtonC, ButtonN, EOTButton, ButtonBase, DrawDlg, 12 Sound, BaseWin, AsyncProcess2, UGraphicSet, UTexture, LazarusPackageIntf;12 Sound, BaseWin, AsyncProcess2, GraphicSet, Texture, LazarusPackageIntf; 13 13 14 14 implementation -
branches/highdpi/Packages/CevoComponents/Directories.pas
r405 r463 33 33 34 34 if Lang = '' then begin 35 for i:= 1 to Paramcount - 1 do36 if (ParamStrUTF8( i) = '--LANG') or (ParamStrUTF8(i) = '-l') or37 (ParamStrUTF8( i) = '--lang') then38 Lang := ParamStrUTF8( i+ 1);35 for I := 1 to Paramcount - 1 do 36 if (ParamStrUTF8(I) = '--LANG') or (ParamStrUTF8(I) = '-l') or 37 (ParamStrUTF8(I) = '--lang') then 38 Lang := ParamStrUTF8(I + 1); 39 39 end; 40 40 if Lang = '' then begin … … 73 73 (Dst.Time < Src.Time) then 74 74 CopyFile(SourceDir + DirectorySeparator + Src.Name, 75 DestinationDir + DirectorySeparator + Src.Name, false);75 DestinationDir + DirectorySeparator + Src.Name, False); 76 76 FindClose(Dst); 77 77 until FindNext(Src) <> 0; -
branches/highdpi/Packages/CevoComponents/DrawDlg.pas
r413 r463 1 1 unit DrawDlg; 2 2 3 {$mode delphi}{$H+}4 5 3 interface 6 4 7 5 uses 8 UDpiControls, Classes, SysUtils, Forms, LCLIntf, LCLType, {$IFDEF LINUX}LMessages,{$ENDIF}6 UDpiControls, Classes, SysUtils, Forms, LCLIntf, LCLType, {$IFDEF UNIX}LMessages,{$ENDIF} 9 7 Messages, Graphics, Controls, ButtonBase, ButtonA, ButtonB, Area, ScreenTools 10 8 {$IFDEF LCLGTK2}, Gtk2Globals{$ENDIF}; … … 48 46 Lines: Integer; 49 47 TopSpace: Integer; 50 procedure SplitText( preview: boolean);48 procedure SplitText(Preview: Boolean); 51 49 procedure CorrectHeight; 52 50 end; … … 76 74 MoveActive := False; 77 75 AddHandlerOnVisibleChanged(VisibleChangedHandler); 78 {$IFDEF LINUX}76 {$IFDEF UNIX} 79 77 OnDeactivate := DoDeactivate; 80 78 {$ENDIF} … … 102 100 else 103 101 begin 104 Pos := ScalePointFromNative(Point(Integer(Msg.LParam and $ffff),105 Integer((Msg.LParam shr 16) and $ffff)));102 Pos := Point(ScaleFromNative(Integer(Msg.LParam and $ffff)), 103 ScaleFromNative(Integer((Msg.LParam shr 16) and $ffff))); 106 104 if Pos.Y >= Top + TitleHeight then 107 105 Msg.Result := HTCLIENT … … 131 129 MousePos1: TPoint; 132 130 MousePos2: TPoint; 133 {$IFDEF LINUX}131 {$IFDEF UNIX} 134 132 MousePosNew: TPoint; 135 133 NewFormPos: TPoint; 136 134 {$ENDIF} 137 135 begin 138 MousePos1 := DpiMouse.CursorPos;139 inherited; 140 MousePos2 := DpiMouse.CursorPos;141 {$IFDEF LINUX}136 MousePos1 := Mouse.CursorPos; 137 inherited; 138 MousePos2 := Mouse.CursorPos; 139 {$IFDEF UNIX} 142 140 // Only if client is not doing own mouse move handling 143 141 if not Assigned(OnMouseDown) or not Assigned(OnMouseMove) or not Assigned(OnMouseUp) then begin 144 142 // HitTest is not supported under Linux GTK2 so use form inside move mechanizm 145 NewFormPos := ScreenToClient( DpiMouse.CursorPos);143 NewFormPos := ScreenToClient(Mouse.CursorPos); 146 144 if (NewFormPos.X >= 0) and (NewFormPos.X < Width) and 147 145 (NewFormPos.Y >= 0) and (NewFormPos.Y < Height) and … … 149 147 MoveMousePos := ClientToScreen(Point(X, Y)); 150 148 MoveFormPos := Point(Left, Top); 151 MousePosNew := DpiMouse.CursorPos;149 MousePosNew := Mouse.CursorPos; 152 150 // Activate move only if mouse position was not changed during inherited call 153 151 if (MousePos1.X = MousePos2.X) and (MousePos1.Y = MousePos2.Y) then begin … … 197 195 {$IFDEF LCLGTK2} 198 196 // GTK2 bug workaround https://bugs.freepascal.org/view.php?id=35720 199 if Visible then LastMouse.WinControl := Self .GetNativeForm;197 if Visible then LastMouse.WinControl := Self; 200 198 {$ENDIF} 201 199 end; … … 208 206 procedure TDrawDlg.InitButtons; 209 207 var 210 cix: integer;208 cix: Integer; 211 209 // ButtonDownSound, ButtonUpSound: string; 212 210 begin … … 230 228 procedure TDrawDlg.SmartInvalidate; 231 229 var 232 i: integer;230 i: Integer; 233 231 r0, r1: HRgn; 234 232 begin … … 242 240 DeleteObject(r1); 243 241 end; 244 InvalidateRgn(Handle, r0, false);242 InvalidateRgn(Handle, r0, False); 245 243 DeleteObject(r0); 246 244 end; … … 250 248 procedure TBaseMessgDlg.FormCreate(Sender: TObject); 251 249 begin 252 Left := ( DpiScreen.Width - Width) div 2;250 Left := (Screen.Width - Width) div 2; 253 251 Canvas.Font.Assign(UniFont[ftNormal]); 254 252 Canvas.Brush.Style := bsClear; 255 253 MessgText := ''; 256 254 TopSpace := 0; 257 TitleHeight := DpiScreen.Height;255 TitleHeight := Screen.Height; 258 256 if csDesigning in ComponentState then Exit; 259 257 InitButtons; … … 262 260 procedure TBaseMessgDlg.FormPaint(Sender: TObject); 263 261 var 264 i, cix: integer;262 i, cix: Integer; 265 263 begin 266 264 if csDesigning in ComponentState then Exit; 267 PaintBackground( self, 3 + Border, 3 + Border, ClientWidth - (6 + 2 * Border),265 PaintBackground(Self, 3 + Border, 3 + Border, ClientWidth - (6 + 2 * Border), 268 266 ClientHeight - (6 + 2 * Border)); 269 267 for i := 0 to Border do … … 276 274 ClientHeight - (3 + Border), MainTexture.ColorBevelLight, 277 275 MainTexture.ColorBevelShade); 278 SplitText( false);276 SplitText(False); 279 277 280 278 for cix := 0 to ControlCount - 1 do … … 283 281 end; 284 282 285 procedure TBaseMessgDlg.SplitText( preview: boolean);286 var 287 Start, Stop, OrdinaryStop, LinesCount: integer;283 procedure TBaseMessgDlg.SplitText(Preview: Boolean); 284 var 285 Start, Stop, OrdinaryStop, LinesCount: Integer; 288 286 s: string; 289 287 begin … … 296 294 (BiColorTextWidth(Canvas, Copy(MessgText, Start, Stop - Start + 1)) < 297 295 ClientWidth - 56) do 298 inc(Stop);296 Inc(Stop); 299 297 if Stop <> Length(MessgText) then 300 298 begin … … 305 303 (MessgText[OrdinaryStop + 1] = '\'); 306 304 if (OrdinaryStop + 1 - Start) * 2 >= Stop - Start then 307 Stop := OrdinaryStop 308 end; 309 if not preview then305 Stop := OrdinaryStop; 306 end; 307 if not Preview then 310 308 begin 311 309 s := Copy(MessgText, Start, Stop - Start + 1); … … 315 313 end; 316 314 Start := Stop + 2; 317 inc(LinesCount) 318 end; 319 if preview then315 inc(LinesCount); 316 end; 317 if Preview then 320 318 Lines := LinesCount; 321 319 end; … … 323 321 procedure TBaseMessgDlg.CorrectHeight; 324 322 var 325 i: integer;323 i: Integer; 326 324 begin 327 325 ClientHeight := 72 + Border + TopSpace + Lines * MessageLineSpacing; 328 Top := ( DpiScreen.Height - ClientHeight) div 2;326 Top := (Screen.Height - ClientHeight) div 2; 329 327 for i := 0 to ControlCount - 1 do 330 328 Controls[i].Top := ClientHeight - (34 + Border); … … 333 331 end. 334 332 333 334 -
branches/highdpi/Packages/CevoComponents/EOTButton.pas
r349 r463 19 19 constructor Create(aOwner: TComponent); override; 20 20 destructor Destroy; override; 21 procedure SetButtonIndexFast( x: integer);22 procedure SetBack(ca: TDpiCanvas; x, y: integer);21 procedure SetButtonIndexFast(X: Integer); 22 procedure SetBack(ca: TDpiCanvas; X, Y: Integer); 23 23 private 24 24 FTemplate: TDpiBitmap; 25 FIndex: integer;26 procedure SetIndex( x: integer);25 FIndex: Integer; 26 procedure SetIndex(X: Integer); 27 27 public 28 28 property Template: TDpiBitmap read FTemplate write FTemplate; 29 29 published 30 30 property Visible; 31 property ButtonIndex: integer read FIndex write SetIndex;31 property ButtonIndex: Integer read FIndex write SetIndex; 32 32 property OnClick; 33 33 protected … … 60 60 Back.SetSize(48, 48); 61 61 Back.Canvas.FillRect(0, 0, Back.Width, Back.Height); 62 ShowHint := true;62 ShowHint := True; 63 63 SetBounds(0, 0, 48, 48); 64 64 end; … … 76 76 if FGraphic <> nil then begin 77 77 UnshareBitmap(Buffer); 78 DpiBit Canvas(Buffer.Canvas, 0, 0, 48, 48, Back.Canvas, 0, 0);78 DpiBitBltCanvas(Buffer.Canvas, 0, 0, 48, 48, Back.Canvas, 0, 0); 79 79 ImageOp_CBC(Buffer, Template, 0, 0, 133, 149 + 48 * Byte(FDown), 48, 48, 80 80 $000000, $FFFFFF); … … 82 82 ImageOp_CBC(Buffer, Template, 8, 8, 1 + 32 * Byte(FIndex), 246, 32, 32, 83 83 $000000, $FFFFFF); 84 DpiBit Canvas(Canvas, 0, 0, 48, 48, Buffer.Canvas, 0, 0);84 DpiBitBltCanvas(Canvas, 0, 0, 48, 48, Buffer.Canvas, 0, 0); 85 85 end else begin 86 86 Brush.Color := $0000FF; … … 89 89 end; 90 90 91 procedure TEOTButton.SetIndex( x: integer);91 procedure TEOTButton.SetIndex(X: Integer); 92 92 begin 93 if x<> FIndex then begin94 FIndex := x;93 if X <> FIndex then begin 94 FIndex := X; 95 95 Invalidate; 96 96 end; 97 97 end; 98 98 99 procedure TEOTButton.SetButtonIndexFast( x: integer);99 procedure TEOTButton.SetButtonIndexFast(X: Integer); 100 100 begin 101 if Visible and ( x<> FIndex) then begin102 FIndex := x;101 if Visible and (X <> FIndex) then begin 102 FIndex := X; 103 103 try 104 104 Paint; … … 108 108 end; 109 109 110 procedure TEOTButton.SetBack(ca: TDpiCanvas; x, y: integer);110 procedure TEOTButton.SetBack(ca: TDpiCanvas; X, Y: Integer); 111 111 begin 112 DpiBit Canvas(Back.Canvas, 0, 0, 48, 48, ca, x, y);112 DpiBitBltCanvas(Back.Canvas, 0, 0, 48, 48, ca, X, Y); 113 113 end; 114 114 -
branches/highdpi/Packages/CevoComponents/GraphicSet.pas
r462 r463 1 unit UGraphicSet;1 unit GraphicSet; 2 2 3 3 interface 4 4 5 5 uses 6 UDpiControls, Classes, SysUtils, Graphics, fgl, LCLType, UPixelPointer, DOM, XMLRead,7 XML Write, UXMLUtils;6 UDpiControls, Classes, SysUtils, Graphics, Generics.Collections, LCLType, DOM, 7 XMLRead, XMLWrite, XML; 8 8 9 9 type … … 31 31 { TGraphicSetItems } 32 32 33 TGraphicSetItems = class(T FPGObjectList<TGraphicSetItem>)33 TGraphicSetItems = class(TObjectList<TGraphicSetItem>) 34 34 GraphicSet: TGraphicSet; 35 35 function SearchByName(Name: string): TGraphicSetItem; … … 55 55 end; 56 56 57 TGraphicSetClass = class of TGraphicSet; 58 57 59 { TGraphicSets } 58 60 59 TGraphicSets = class(T FPGObjectList<TGraphicSet>)61 TGraphicSets = class(TObjectList<TGraphicSet>) 60 62 function SearchByName(Name: string): TGraphicSet; 61 63 function AddNew(Name: string): TGraphicSet; … … 91 93 procedure TGraphicSetItem.DrawTo(Canvas: TDpiCanvas; Pos: TPoint); 92 94 begin 93 { DpiBit Canvas(Canvas, Pos.X, Pos.Y, BoundsRect.Width, BoundsRect.Height,95 { DpiBitBltCanvas(Canvas, Pos.X, Pos.Y, BoundsRect.Width, BoundsRect.Height, 94 96 GraphicSet.Mask.Canvas, BoundsRect.Left, BoundsRect.Top, SRCAND); 95 DpiBit Canvas(Canvas, Pos.X, Pos.Y, BoundsRect.Width, BoundsRect.Height,97 DpiBitBltCanvas(Canvas, Pos.X, Pos.Y, BoundsRect.Width, BoundsRect.Height, 96 98 GraphicSet.Data.Canvas, BoundsRect.Left, BoundsRect.Top, SRCPAINT); 97 99 } … … 270 272 end. 271 273 274 275 -
branches/highdpi/Packages/CevoComponents/ScreenTools.pas
r405 r463 8 8 {$ENDIF} 9 9 StringTables, LCLIntf, LCLType, SysUtils, Classes, Graphics, Controls, Math, 10 Forms, Menus, GraphType, fgl, UGraphicSet, LazFileUtils, UTexture;10 Forms, Menus, GraphType, GraphicSet, LazFileUtils, Texture; 11 11 12 12 type … … 17 17 18 18 {$IFDEF WINDOWS} 19 function ChangeResolution( x, y, bpp, freq: integer): boolean;19 function ChangeResolution(X, Y, bpp, freq: Integer): Boolean; 20 20 {$ENDIF} 21 21 procedure RestoreResolution; 22 22 procedure EmptyMenu(MenuItems: TDpiMenuItem; Keep: Integer = 0); 23 function TurnToYear(Turn: integer): integer;24 function TurnToString(Turn: integer): string;25 function MovementToString(Movement: integer): string;26 procedure BtnFrame( ca: TDpiCanvas; p: TRect; T: TTexture);27 procedure EditFrame( ca: TDpiCanvas; p: TRect; T: TTexture);28 function HexStringToColor(S: string): integer;23 function TurnToYear(Turn: Integer): Integer; 24 function TurnToString(Turn: Integer): string; 25 function MovementToString(Movement: Integer): string; 26 procedure BtnFrame(Canvas: TDpiCanvas; P: TRect; T: TTexture); 27 procedure EditFrame(Canvas: TDpiCanvas; P: TRect; T: TTexture); 28 function HexStringToColor(S: string): Integer; 29 29 function ExtractFileNameWithoutExt(const Filename: string): string; 30 function LoadGraphicFile(Bmp: TDpiBitmap; FileName: string; Options: TLoadGraphicFileOptions = []): boolean; 31 function LoadGraphicSet(const Name: string): TGraphicSet; 32 function LoadGraphicSet2(const Name: string): TGraphicSet; 33 procedure Dump(dst: TDpiBitmap; HGr: TGraphicSet; xDst, yDst, Width, Height, xGr, yGr: integer); 30 function LoadGraphicFile(Bmp: TDpiBitmap; FileName: string; Options: TLoadGraphicFileOptions = []): Boolean; 31 function LoadGraphicSet(const Name: string; Transparency: Boolean = True): TGraphicSet; 32 procedure Dump(dst: TDpiBitmap; HGr: TGraphicSet; xDst, yDst, Width, Height, xGr, yGr: Integer); 34 33 procedure BitmapReplaceColor(Dst: TDpiBitmap; X, Y, Width, Height: Integer; OldColor, NewColor: TColor); 35 procedure Sprite(Canvas: TDpiCanvas; HGr: TGraphicSet; xDst, yDst, Width, Height, xGr, yGr: integer);34 procedure Sprite(Canvas: TDpiCanvas; HGr: TGraphicSet; xDst, yDst, Width, Height, xGr, yGr: Integer); 36 35 overload; 37 procedure Sprite(dst: TDpiBitmap; HGr: TGraphicSet; xDst, yDst, Width, Height, xGr, yGr: integer);36 procedure Sprite(dst: TDpiBitmap; HGr: TGraphicSet; xDst, yDst, Width, Height, xGr, yGr: Integer); 38 37 overload; 39 38 procedure MakeBlue(Dst: TDpiBitmap; X, Y, Width, Height: Integer); … … 46 45 procedure ImageOp_CBC(Dst, Src: TDpiBitmap; xDst, yDst, xSrc, ySrc, Width, Height, 47 46 Color0, Color2: Integer); 48 procedure ImageOp_CCC(bmp: TDpiBitmap; x, y, Width, Height, Color0, Color1, Color2: Integer);49 function DpiBit Canvas(DestCanvas: TDpiCanvas; X, Y, Width, Height: Integer;47 procedure ImageOp_CCC(bmp: TDpiBitmap; X, Y, Width, Height, Color0, Color1, Color2: Integer); 48 function DpiBitBltCanvas(DestCanvas: TDpiCanvas; X, Y, Width, Height: Integer; 50 49 SrcCanvas: TDpiCanvas; XSrc, YSrc: Integer; Rop: DWORD = SRCCOPY): Boolean; overload; 51 function DpiBit Canvas(Dest: TDpiCanvas; DestRect: TRect;50 function DpiBitBltCanvas(Dest: TDpiCanvas; DestRect: TRect; 52 51 Src: TDpiCanvas; SrcPos: TPoint; Rop: DWORD = SRCCOPY): Boolean; overload; 53 52 function BitBltBitmap(Dest: TDpiBitmap; X, Y, Width, Height: Integer; … … 55 54 function BitBltBitmap(Dest: TDpiBitmap; DestRect: TRect; 56 55 Src: TDpiBitmap; SrcPos: TPoint; Rop: DWORD = SRCCOPY): Boolean; overload; 57 procedure SLine( ca: TDpiCanvas; x0, x1, y: integer; cl: TColor);58 procedure DLine( ca: TDpiCanvas; x0, x1, y: integer; cl0, cl1: TColor);59 procedure Frame( ca: TDpiCanvas; x0, y0, x1, y1: integer; cl0, cl1: TColor);60 procedure RFrame( ca: TDpiCanvas; x0, y0, x1, y1: integer; cl0, cl1: TColor);61 procedure CFrame( ca: TDpiCanvas; x0, y0, x1, y1, Corner: integer; cl: TColor);62 procedure FrameImage( ca: TDpiCanvas; Src: TDpiBitmap;63 x, y, Width, Height, xSrc, ySrc: integer; IsControl: boolean = False);64 procedure GlowFrame(Dst: TDpiBitmap; x0, y0, Width, Height: integer; cl: TColor);56 procedure SLine(Canvas: TDpiCanvas; x0, x1, Y: Integer; cl: TColor); 57 procedure DLine(Canvas: TDpiCanvas; x0, x1, Y: Integer; cl0, cl1: TColor); 58 procedure Frame(Canvas: TDpiCanvas; x0, y0, x1, y1: Integer; cl0, cl1: TColor); 59 procedure RFrame(Canvas: TDpiCanvas; x0, y0, x1, y1: Integer; cl0, cl1: TColor); 60 procedure CFrame(Canvas: TDpiCanvas; x0, y0, x1, y1, Corner: Integer; cl: TColor); 61 procedure FrameImage(Canvas: TDpiCanvas; Src: TDpiBitmap; 62 X, Y, Width, Height, xSrc, ySrc: Integer; IsControl: Boolean = False); 63 procedure GlowFrame(Dst: TDpiBitmap; x0, y0, Width, Height: Integer; cl: TColor); 65 64 procedure InitOrnament; 66 procedure InitCityMark(T : TTexture);67 procedure Fill( ca: TDpiCanvas; Left, Top, Width, Height, xOffset, yOffset: integer); overload;65 procedure InitCityMark(Texture: TTexture); 66 procedure Fill(Canvas: TDpiCanvas; Left, Top, Width, Height, xOffset, yOffset: Integer); overload; 68 67 procedure Fill(Canvas: TDpiCanvas; Rect: TRect; Offset: TPoint); overload; 69 procedure FillLarge( ca: TDpiCanvas; x0, y0, x1, y1, xm: integer);70 procedure FillSeamless( ca: TDpiCanvas; Left, Top, Width, Height, xOffset, yOffset: integer;68 procedure FillLarge(Canvas: TDpiCanvas; x0, y0, x1, y1, xm: Integer); 69 procedure FillSeamless(Canvas: TDpiCanvas; Left, Top, Width, Height, xOffset, yOffset: Integer; 71 70 const Texture: TDpiBitmap); 72 procedure FillRectSeamless( ca: TDpiCanvas; x0, y0, x1, y1, xOffset, yOffset: integer;71 procedure FillRectSeamless(Canvas: TDpiCanvas; x0, y0, x1, y1, xOffset, yOffset: Integer; 73 72 const Texture: TDpiBitmap); 74 procedure PaintBackground(Form: TDpiForm; Left, Top, Width, Height: integer);75 procedure Corner( ca: TDpiCanvas; x, y, Kind: integer; T: TTexture);76 procedure BiColorTextOut( ca: TDpiCanvas; clMain, clBack: TColor; x, y: integer; s: string);77 procedure LoweredTextOut( ca: TDpiCanvas; cl: TColor; T: TTexture;78 x, y: integer; s: string);79 function BiColorTextWidth( ca: TDpiCanvas; s: string): integer;80 procedure RisedTextOut( ca: TDpiCanvas; x, y: integer; s: string);81 procedure LightGradient( ca: TDpiCanvas; x, y, Width, Color: integer);82 procedure DarkGradient( ca: TDpiCanvas; x, y, Width, Kind: integer);83 procedure VLightGradient( ca: TDpiCanvas; x, y, Height, Color: integer);84 procedure VDarkGradient( ca: TDpiCanvas; x, y, Height, Kind: integer);73 procedure PaintBackground(Form: TDpiForm; Left, Top, Width, Height: Integer); 74 procedure Corner(Canvas: TDpiCanvas; X, Y, Kind: Integer; T: TTexture); 75 procedure BiColorTextOut(Canvas: TDpiCanvas; clMain, clBack: TColor; X, Y: Integer; S: string); 76 procedure LoweredTextOut(Canvas: TDpiCanvas; cl: TColor; T: TTexture; 77 X, Y: Integer; S: string); 78 function BiColorTextWidth(Canvas: TDpiCanvas; S: string): Integer; 79 procedure RisedTextOut(Canvas: TDpiCanvas; X, Y: Integer; S: string); 80 procedure LightGradient(Canvas: TDpiCanvas; X, Y, Width, Color: Integer); 81 procedure DarkGradient(Canvas: TDpiCanvas; X, Y, Width, Kind: Integer); 82 procedure VLightGradient(Canvas: TDpiCanvas; X, Y, Height, Color: Integer); 83 procedure VDarkGradient(Canvas: TDpiCanvas; X, Y, Height, Kind: Integer); 85 84 procedure UnderlinedTitleValue(Canvas: TDpiCanvas; Title, Value: string; X, Y, Width: Integer); 86 procedure NumberBar(dst: TDpiBitmap; x, y: integer; Cap: string; val: integer;85 procedure NumberBar(dst: TDpiBitmap; X, Y: Integer; Cap: string; val: Integer; 87 86 T: TTexture); 88 procedure CountBar(dst: TDpiBitmap; x, y, w: integer; Kind: integer;89 Cap: string; val: integer; T: TTexture);90 procedure PaintProgressBar( ca: TDpiCanvas; Kind, x, y, pos, Growth, max: integer;87 procedure CountBar(dst: TDpiBitmap; X, Y, W: Integer; Kind: Integer; 88 Cap: string; val: Integer; T: TTexture); 89 procedure PaintProgressBar(Canvas: TDpiCanvas; Kind, X, Y, Pos, Growth, Max: Integer; 91 90 T: TTexture); 92 procedure PaintRelativeProgressBar( ca: TDpiCanvas;93 Kind, x, y, size, pos, Growth, max: integer; IndicateComplete: boolean;91 procedure PaintRelativeProgressBar(Canvas: TDpiCanvas; 92 Kind, X, Y, size, Pos, Growth, Max: Integer; IndicateComplete: Boolean; 94 93 T: TTexture); 95 procedure PaintLogo(Canvas: TDpiCanvas; X, Y, LightColor, ShadeColor: integer);94 procedure PaintLogo(Canvas: TDpiCanvas; X, Y, LightColor, ShadeColor: Integer); 96 95 procedure LoadPhrases; 97 96 procedure Texturize(Dest, Texture: TDpiBitmap; TransparentColor: Cardinal); … … 149 148 Phrases2: TStringTable; 150 149 GrExt: TGraphicSets; 150 151 151 HGrSystem: TGraphicSet; 152 HGrSystem2: TGraphicSet;153 ClickFrameColor: Integer;154 MainTexture: TTexture;155 Templates: TGraphicSet;156 Colors: TDpiBitmap;157 Paper: TDpiBitmap;158 BigImp: TDpiBitmap;159 LogoBuffer: TDpiBitmap;160 FullScreen: Boolean;161 GenerateNames: Boolean;162 InitOrnamentDone: Boolean;163 Phrases2FallenBackToEnglish: Boolean;164 165 // Graphic set items166 152 CityMark1: TGraphicSetItem; 167 153 CityMark2: TGraphicSetItem; 154 155 HGrSystem2: TGraphicSet; 168 156 Ornament: TGraphicSetItem; 157 GBrainNoTerm: TGraphicSetItem; 158 GBrainSuperVirtual: TGraphicSetItem; 159 GBrainTerm: TGraphicSetItem; 160 GBrainRandom: TGraphicSetItem; 161 162 Templates: TGraphicSet; 169 163 Logo: TGraphicSetItem; 170 164 BigBook: TGraphicSetItem; … … 180 174 WeightOff: TGraphicSetItem; 181 175 176 ClickFrameColor: Integer; 177 MainTexture: TTexture; 178 Colors: TDpiBitmap; 179 Paper: TDpiBitmap; 180 BigImp: TDpiBitmap; 181 LogoBuffer: TDpiBitmap; 182 FullScreen: Boolean; 183 GenerateNames: Boolean; 184 InitOrnamentDone: Boolean; 185 Phrases2FallenBackToEnglish: Boolean; 186 182 187 UniFont: array [TFontType] of TDpiFont; 183 188 Gamma: Integer; // global gamma correction (cent) … … 192 197 193 198 uses 194 Directories, Sound, UPixelPointer;199 Directories, Sound, PixelPointer; 195 200 196 201 var 197 202 {$IFDEF WINDOWS} 198 203 StartResolution: TDeviceMode; 199 ResolutionChanged: boolean;204 ResolutionChanged: Boolean; 200 205 {$ENDIF} 201 206 … … 203 208 204 209 {$IFDEF WINDOWS} 205 function ChangeResolution( x, y, bpp, freq: integer): boolean;210 function ChangeResolution(X, Y, bpp, freq: Integer): Boolean; 206 211 var 207 212 DevMode: TDeviceMode; … … 210 215 DevMode.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT or DM_BITSPERPEL or 211 216 DM_DISPLAYFREQUENCY; 212 DevMode.dmPelsWidth := x;213 DevMode.dmPelsHeight := y;217 DevMode.dmPelsWidth := X; 218 DevMode.dmPelsHeight := Y; 214 219 DevMode.dmBitsPerPel := bpp; 215 220 DevMode.dmDisplayFrequency := freq; … … 311 316 end; 312 317 313 procedure BtnFrame( ca: TDpiCanvas; p: TRect; T: TTexture);314 begin 315 RFrame( ca, p.Left - 1, p.Top - 1, p.Right, p.Bottom, T.ColorBevelShade,318 procedure BtnFrame(Canvas: TDpiCanvas; P: TRect; T: TTexture); 319 begin 320 RFrame(Canvas, P.Left - 1, P.Top - 1, P.Right, P.Bottom, T.ColorBevelShade, 316 321 T.ColorBevelLight); 317 322 end; 318 323 319 procedure EditFrame( ca: TDpiCanvas; p: TRect; T: TTexture);320 begin 321 Frame( ca, p.Left - 1, p.Top - 1, p.Right, p.Bottom, $000000, $000000);322 Frame( ca, p.Left - 2, p.Top - 2, p.Right + 1, p.Bottom + 1, $000000, $000000);323 Frame( ca, p.Left - 3, p.Top - 3, p.Right + 2, p.Bottom + 1, $000000, $000000);324 RFrame( ca, p.Left - 4, p.Top - 4, p.Right + 3, p.Bottom + 2, T.ColorBevelShade,324 procedure EditFrame(Canvas: TDpiCanvas; P: TRect; T: TTexture); 325 begin 326 Frame(Canvas, P.Left - 1, P.Top - 1, P.Right, P.Bottom, $000000, $000000); 327 Frame(Canvas, P.Left - 2, P.Top - 2, P.Right + 1, P.Bottom + 1, $000000, $000000); 328 Frame(Canvas, P.Left - 3, P.Top - 3, P.Right + 2, P.Bottom + 1, $000000, $000000); 329 RFrame(Canvas, P.Left - 4, P.Top - 4, P.Right + 3, P.Bottom + 2, T.ColorBevelShade, 325 330 T.ColorBevelLight); 326 331 end; … … 328 333 function HexCharToInt(X: Char): Integer; 329 334 begin 330 case xof335 case X of 331 336 '0' .. '9': Result := Ord(X) - Ord('0'); 332 337 'A' .. 'F': Result := Ord(X) - Ord('A') + 10; … … 364 369 begin 365 370 Bitmap.BeginUpdate; 366 PixelPtr := PixelPointer(Bitmap);371 PixelPtr := TPixelPointer.Create(Bitmap); 367 372 for Y := 0 to ScaleToNative(Bitmap.Height) - 1 do begin 368 373 for X := 0 to ScaleToNative(Bitmap.Width) - 1 do begin … … 381 386 begin 382 387 //Dst.SetSize(Src.Width, Src.Height); 383 SrcPtr := PixelPointer(Src);384 DstPtr := PixelPointer(Dst);388 SrcPtr := TPixelPointer.Create(Src); 389 DstPtr := TPixelPointer.Create(Dst); 385 390 for Y := 0 to ScaleToNative(Src.Height - 1) do begin 386 391 for X := 0 to ScaleToNative(Src.Width - 1) do begin … … 483 488 end; 484 489 485 function LoadGraphicSet(const Name: string ): TGraphicSet;486 var 487 x: Integer;488 y: Integer;490 function LoadGraphicSet(const Name: string; Transparency: Boolean = True): TGraphicSet; 491 var 492 X: Integer; 493 Y: Integer; 489 494 OriginalColor: Integer; 490 495 FileName: string; … … 508 513 Result.ResetPixUsed; 509 514 510 Result.Mask.SetSize(Result.Data.Width, Result.Data.Height); 511 512 Result.Data.BeginUpdate; 513 Result.Mask.BeginUpdate; 514 DataPixel := PixelPointer(Result.Data); 515 MaskPixel := PixelPointer(Result.Mask); 516 for y := 0 to ScaleToNative(Result.Data.Height) - 1 do begin 517 for x := 0 to ScaleToNative(Result.Data.Width) - 1 do begin 518 OriginalColor := DataPixel.Pixel^.ARGB and $FFFFFF; 519 if (OriginalColor = TransparentColor1) or (OriginalColor = TransparentColor2) then begin 520 MaskPixel.Pixel^.R := $FF; 521 MaskPixel.Pixel^.G := $FF; 522 MaskPixel.Pixel^.B := $FF; 523 DataPixel.Pixel^.R := 0; 524 DataPixel.Pixel^.G := 0; 525 DataPixel.Pixel^.B := 0; 526 end else begin 527 MaskPixel.Pixel^.R := $00; 528 MaskPixel.Pixel^.G := $00; 529 MaskPixel.Pixel^.B := $00; 515 if Transparency then begin 516 Result.Mask.SetSize(Result.Data.Width, Result.Data.Height); 517 518 Result.Data.BeginUpdate; 519 Result.Mask.BeginUpdate; 520 DataPixel := TPixelPointer.Create(Result.Data); 521 MaskPixel := TPixelPointer.Create(Result.Mask); 522 for Y := 0 to ScaleToNative(Result.Data.Height) - 1 do begin 523 for X := 0 to ScaleToNative(Result.Data.Width) - 1 do begin 524 OriginalColor := DataPixel.Pixel^.ARGB and $FFFFFF; 525 if (OriginalColor = TransparentColor1) or (OriginalColor = TransparentColor2) then begin 526 MaskPixel.Pixel^.R := $FF; 527 MaskPixel.Pixel^.G := $FF; 528 MaskPixel.Pixel^.B := $FF; 529 DataPixel.Pixel^.R := 0; 530 DataPixel.Pixel^.G := 0; 531 DataPixel.Pixel^.B := 0; 532 end else begin 533 MaskPixel.Pixel^.R := $00; 534 MaskPixel.Pixel^.G := $00; 535 MaskPixel.Pixel^.B := $00; 536 end; 537 DataPixel.NextPixel; 538 MaskPixel.NextPixel; 530 539 end; 531 DataPixel.Next Pixel;532 MaskPixel.Next Pixel;540 DataPixel.NextLine; 541 MaskPixel.NextLine; 533 542 end; 534 DataPixel.NextLine; 535 MaskPixel.NextLine; 536 end; 537 Result.Data.EndUpdate; 538 Result.Mask.EndUpdate; 539 540 if Gamma <> 100 then 541 ApplyGammaToBitmap(Result.Data); 542 end; 543 end; 544 545 function LoadGraphicSet2(const Name: string): TGraphicSet; 546 var 547 FileName: string; 548 begin 549 Result := GrExt.SearchByName(Name); 550 if not Assigned(Result) then begin 551 Result := GrExt.AddNew(Name); 552 FileName := GetGraphicsDir + DirectorySeparator + Name; 553 if not LoadGraphicFile(Result.Data, FileName, [gfNoGamma]) then begin 554 Result := nil; 555 Exit; 556 end; 557 558 FileName := ExtractFileNameWithoutExt(FileName) + GraphicSetFileExt; 559 if FileExists(FileName) then 560 Result.LoadFromFile(FileName); 561 562 Result.ResetPixUsed; 563 end; 564 end; 565 566 procedure Dump(dst: TDpiBitmap; HGr: TGraphicSet; xDst, yDst, Width, Height, xGr, yGr: integer); 567 begin 568 DpiBitCanvas(dst.Canvas, xDst, yDst, Width, Height, 543 Result.Data.EndUpdate; 544 Result.Mask.EndUpdate; 545 546 if Gamma <> 100 then 547 ApplyGammaToBitmap(Result.Data); 548 end; 549 end; 550 end; 551 552 procedure Dump(dst: TDpiBitmap; HGr: TGraphicSet; xDst, yDst, Width, Height, xGr, yGr: Integer); 553 begin 554 DpiBitBltCanvas(dst.Canvas, xDst, yDst, Width, Height, 569 555 HGr.Data.Canvas, xGr, yGr); 570 556 end; … … 576 562 begin 577 563 Dst.BeginUpdate; 578 PixelPtr := PixelPointer(Dst, ScaleToNative(X), ScaleToNative(Y));564 PixelPtr := TPixelPointer.Create(Dst, ScaleToNative(X), ScaleToNative(Y)); 579 565 for YY := 0 to ScaleToNative(Height) - 1 do begin 580 566 for XX := 0 to ScaleToNative(Width) - 1 do begin … … 595 581 begin 596 582 Dst.BeginUpdate; 597 PixelPtr := PixelPointer(Dst, ScaleToNative(X), ScaleToNative(Y));583 PixelPtr := TPixelPointer.Create(Dst, ScaleToNative(X), ScaleToNative(Y)); 598 584 for yy := 0 to ScaleToNative(Height) - 1 do begin 599 585 for xx := 0 to ScaleToNative(Width) - 1 do begin … … 615 601 begin 616 602 Dst.BeginUpdate; 617 PixelPtr := PixelPointer(Dst, ScaleToNative(X), ScaleToNative(Y));603 PixelPtr := TPixelPointer.Create(Dst, ScaleToNative(X), ScaleToNative(Y)); 618 604 for YY := 0 to ScaleToNative(Height) - 1 do begin 619 605 for XX := 0 to ScaleToNative(Width) - 1 do begin … … 662 648 Height := ScaleToNative(dst.Height) - yDst; 663 649 if (Width < 0) or (Height < 0) then 664 exit;650 Exit; 665 651 666 652 dst.BeginUpdate; 667 653 Src.BeginUpdate; 668 PixelDst := PixelPointer(Dst, xDst, yDst);669 PixelSrc := PixelPointer(Src, xSrc, ySrc);654 PixelDst := TPixelPointer.Create(Dst, xDst, yDst); 655 PixelSrc := TPixelPointer.Create(Src, xSrc, ySrc); 670 656 for Y := 0 to Height - 1 do begin 671 657 for X := 0 to Width - 1 do begin 672 658 Brightness := PixelSrc.Pixel^.B; // One byte for 8-bit color 673 test := (PixelDst.Pixel^.R * Brightness) shr 7;674 if test >= 256 then659 Test := (PixelDst.Pixel^.R * Brightness) shr 7; 660 if Test >= 256 then 675 661 PixelDst.Pixel^.R := 255 676 662 else 677 PixelDst.Pixel^.R := test; // Red678 test := (PixelDst.Pixel^.G * Brightness) shr 7;679 if test >= 256 then663 PixelDst.Pixel^.R := Test; // Red 664 Test := (PixelDst.Pixel^.G * Brightness) shr 7; 665 if Test >= 256 then 680 666 PixelDst.Pixel^.G := 255 681 667 else 682 PixelDst.Pixel^.G := test; // Green683 test := (PixelDst.Pixel^.B * Brightness) shr 7;684 if test >= 256 then668 PixelDst.Pixel^.G := Test; // Green 669 Test := (PixelDst.Pixel^.B * Brightness) shr 7; 670 if Test >= 256 then 685 671 PixelDst.Pixel^.R := 255 686 672 else … … 728 714 Height := ScaleToNative(dst.Height) - yDst; 729 715 if (Width < 0) or (Height < 0) then 730 exit;716 Exit; 731 717 732 718 Src.BeginUpdate; 733 719 dst.BeginUpdate; 734 SrcPixel := PixelPointer(Src, xSrc, ySrc);735 DstPixel := PixelPointer(Dst, xDst, yDst);720 SrcPixel := TPixelPointer.Create(Src, xSrc, ySrc); 721 DstPixel := TPixelPointer.Create(Dst, xDst, yDst); 736 722 for iy := 0 to Height - 1 do begin 737 723 for ix := 0 to Width - 1 do begin … … 777 763 // R channel = Color2 amp 778 764 var 779 ix, iy, amp0, amp1, trans, Value: integer;765 ix, iy, amp0, amp1, trans, Value: Integer; 780 766 SrcPixel: TPixelPointer; 781 767 DstPixel: TPixelPointer; … … 789 775 Src.BeginUpdate; 790 776 Dst.BeginUpdate; 791 SrcPixel := PixelPointer(Src, xSrc, ySrc);792 DstPixel := PixelPointer(Dst, xDst, yDst);777 SrcPixel := TPixelPointer.Create(Src, xSrc, ySrc); 778 DstPixel := TPixelPointer.Create(Dst, xDst, yDst); 793 779 for iy := 0 to Height - 1 do begin 794 780 for ix := 0 to Width - 1 do begin … … 819 805 end; 820 806 821 procedure ImageOp_CCC(bmp: TDpiBitmap; x, y, Width, Height, Color0, Color1, Color2: Integer);807 procedure ImageOp_CCC(bmp: TDpiBitmap; X, Y, Width, Height, Color0, Color1, Color2: Integer); 822 808 // Bmp is template 823 809 // B channel = Color0 amp, 128=original brightness … … 825 811 // R channel = Color2 amp, 128=original brightness 826 812 var 827 i, Red, Green: Integer;813 I, Red, Green: Integer; 828 814 PixelPtr: TPixelPointer; 829 815 begin … … 833 819 Y := ScaleToNative(Y); 834 820 bmp.BeginUpdate; 835 assert(bmp.PixelFormat = pf24bit);836 Height := y+ Height;837 PixelPtr := PixelPointer(Bmp, x, y);838 while y< Height do begin839 for i:= 0 to Width - 1 do begin821 Assert(bmp.PixelFormat = pf24bit); 822 Height := Y + Height; 823 PixelPtr := TPixelPointer.Create(Bmp, X, Y); 824 while Y < Height do begin 825 for I := 0 to Width - 1 do begin 840 826 Red := ((PixelPtr.Pixel^.B * (Color0 and $0000FF) + PixelPtr.Pixel^.G * 841 827 (Color1 and $0000FF) + PixelPtr.Pixel^.R * (Color2 and $0000FF)) shr 8) and $ff; … … 850 836 PixelPtr.NextPixel; 851 837 end; 852 Inc( y);838 Inc(Y); 853 839 PixelPtr.NextLine; 854 840 end; … … 856 842 end; 857 843 858 procedure Sprite(Canvas: TDpiCanvas; HGr: TGraphicSet; xDst, yDst, Width, Height, xGr, yGr: integer);859 begin 860 DpiBit Canvas(Canvas, xDst, yDst, Width, Height,844 procedure Sprite(Canvas: TDpiCanvas; HGr: TGraphicSet; xDst, yDst, Width, Height, xGr, yGr: Integer); 845 begin 846 DpiBitBltCanvas(Canvas, xDst, yDst, Width, Height, 861 847 HGr.Mask.Canvas, xGr, yGr, SRCAND); 862 DpiBit Canvas(Canvas, xDst, yDst, Width, Height,848 DpiBitBltCanvas(Canvas, xDst, yDst, Width, Height, 863 849 HGr.Data.Canvas, xGr, yGr, SRCPAINT); 864 850 end; 865 851 866 procedure Sprite(dst: TDpiBitmap; HGr: TGraphicSet; xDst, yDst, Width, Height, xGr, yGr: integer);867 begin 868 DpiBit Canvas(dst.Canvas, xDst, yDst, Width, Height,852 procedure Sprite(dst: TDpiBitmap; HGr: TGraphicSet; xDst, yDst, Width, Height, xGr, yGr: Integer); 853 begin 854 DpiBitBltCanvas(dst.Canvas, xDst, yDst, Width, Height, 869 855 HGr.Mask.Canvas, xGr, yGr, SRCAND); 870 DpiBit Canvas(dst.Canvas, xDst, yDst, Width, Height,856 DpiBitBltCanvas(dst.Canvas, xDst, yDst, Width, Height, 871 857 HGr.Data.Canvas, xGr, yGr, SRCPAINT); 872 858 end; 873 859 874 function DpiBit Canvas(DestCanvas: TDpiCanvas; X, Y, Width, Height: Integer;860 function DpiBitBltCanvas(DestCanvas: TDpiCanvas; X, Y, Width, Height: Integer; 875 861 SrcCanvas: TDpiCanvas; XSrc, YSrc: Integer; Rop: DWORD = SRCCOPY): Boolean; 876 862 begin … … 883 869 end; 884 870 885 function DpiBit Canvas(Dest: TDpiCanvas; DestRect: TRect; Src: TDpiCanvas;871 function DpiBitBltCanvas(Dest: TDpiCanvas; DestRect: TRect; Src: TDpiCanvas; 886 872 SrcPos: TPoint; Rop: DWORD): Boolean; 887 873 begin 888 Result := DpiBit Canvas(Dest, DestRect.Left, DestRect.Top, DestRect.Width, DestRect.Height,874 Result := DpiBitBltCanvas(Dest, DestRect.Left, DestRect.Top, DestRect.Width, DestRect.Height, 889 875 Src, SrcPos.X, SrcPos.Y, Rop); 890 876 end; … … 893 879 Src: TDpiBitmap; XSrc, YSrc: Integer; Rop: DWORD): Boolean; 894 880 begin 895 Result := DpiBit Canvas(Dest.Canvas, X, Y, Width, Height, Src.Canvas, XSrc, YSrc, Rop);881 Result := DpiBitBltCanvas(Dest.Canvas, X, Y, Width, Height, Src.Canvas, XSrc, YSrc, Rop); 896 882 end; 897 883 … … 899 885 SrcPos: TPoint; Rop: DWORD): Boolean; 900 886 begin 901 Result := DpiBit Canvas(Dest.Canvas, DestRect, Src.Canvas, SrcPos, Rop);902 end; 903 904 procedure SLine( ca: TDpiCanvas; x0, x1, y: integer; cl: TColor);905 begin 906 with cado begin887 Result := DpiBitBltCanvas(Dest.Canvas, DestRect, Src.Canvas, SrcPos, Rop); 888 end; 889 890 procedure SLine(Canvas: TDpiCanvas; x0, x1, Y: Integer; cl: TColor); 891 begin 892 with Canvas do begin 907 893 Pen.Color := cl; 908 MoveTo(x0, y);909 LineTo(x1 + 1, y);910 end; 911 end; 912 913 procedure DLine( ca: TDpiCanvas; x0, x1, y: integer; cl0, cl1: TColor);914 begin 915 with cado begin894 MoveTo(x0, Y); 895 LineTo(x1 + 1, Y); 896 end; 897 end; 898 899 procedure DLine(Canvas: TDpiCanvas; x0, x1, Y: Integer; cl0, cl1: TColor); 900 begin 901 with Canvas do begin 916 902 Pen.Color := cl0; 917 MoveTo(x0, y);918 LineTo(x1, y);903 MoveTo(x0, Y); 904 LineTo(x1, Y); 919 905 Pen.Color := cl1; 920 MoveTo(x0 + 1, y+ 1);921 LineTo(x1 + 1, y+ 1);922 Pixels[x0, y+ 1] := cl0;923 Pixels[x1, y] := cl1;924 end; 925 end; 926 927 procedure Frame( ca: TDpiCanvas; x0, y0, x1, y1: integer; cl0, cl1: TColor);928 begin 929 with cado begin906 MoveTo(x0 + 1, Y + 1); 907 LineTo(x1 + 1, Y + 1); 908 Pixels[x0, Y + 1] := cl0; 909 Pixels[x1, Y] := cl1; 910 end; 911 end; 912 913 procedure Frame(Canvas: TDpiCanvas; x0, y0, x1, y1: Integer; cl0, cl1: TColor); 914 begin 915 with Canvas do begin 930 916 MoveTo(x0, y1); 931 917 Pen.Color := cl0; … … 938 924 end; 939 925 940 procedure RFrame( ca: TDpiCanvas; x0, y0, x1, y1: integer; cl0, cl1: TColor);941 begin 942 with cado begin926 procedure RFrame(Canvas: TDpiCanvas; x0, y0, x1, y1: Integer; cl0, cl1: TColor); 927 begin 928 with Canvas do begin 943 929 Pen.Color := cl0; 944 930 MoveTo(x0, y0 + 1); … … 954 940 end; 955 941 956 procedure CFrame( ca: TDpiCanvas; x0, y0, x1, y1, Corner: integer; cl: TColor);957 begin 958 with cado begin942 procedure CFrame(Canvas: TDpiCanvas; x0, y0, x1, y1, Corner: Integer; cl: TColor); 943 begin 944 with Canvas do begin 959 945 Pen.Color := cl; 960 946 MoveTo(x0, y0 + Corner - 1); … … 973 959 end; 974 960 975 procedure FrameImage( ca: TDpiCanvas; Src: TDpiBitmap;976 x, y, Width, Height, xSrc, ySrc: integer; IsControl: boolean = False);961 procedure FrameImage(Canvas: TDpiCanvas; Src: TDpiBitmap; 962 X, Y, Width, Height, xSrc, ySrc: Integer; IsControl: Boolean = False); 977 963 begin 978 964 if IsControl then begin 979 Frame( ca, x - 1, y - 1, x + Width, y+ Height, $B0B0B0, $FFFFFF);980 RFrame( ca, x - 2, y - 2, x + Width + 1, y+ Height + 1, $FFFFFF, $B0B0B0);965 Frame(Canvas, X - 1, Y - 1, X + Width, Y + Height, $B0B0B0, $FFFFFF); 966 RFrame(Canvas, X - 2, Y - 2, X + Width + 1, Y + Height + 1, $FFFFFF, $B0B0B0); 981 967 end else 982 Frame( ca, x - 1, y - 1, x + Width, y+ Height, $000000, $000000);983 DpiBit Canvas(ca, x, y, Width, Height, Src.Canvas, xSrc, ySrc);968 Frame(Canvas, X - 1, Y - 1, X + Width, Y + Height, $000000, $000000); 969 DpiBitBltCanvas(Canvas, X, Y, Width, Height, Src.Canvas, xSrc, ySrc); 984 970 end; 985 971 986 972 procedure GlowFrame(Dst: TDpiBitmap; x0, y0, Width, Height: Integer; cl: TColor); 987 973 var 988 x, y, ch, r: Integer;974 X, Y, ch, R: Integer; 989 975 DstPtr: TPixelPointer; 990 976 DpiGlowRange: Integer; … … 996 982 Height := ScaleToNative(Height); 997 983 Dst.BeginUpdate; 998 DstPtr := PixelPointer(Dst, x0 - DpiGlowRange + 1, y0 - DpiGlowRange + 1);999 for y:= -DpiGlowRange + 1 to Height - 1 + DpiGlowRange - 1 do begin1000 for x:= -DpiGlowRange + 1 to Width - 1 + DpiGlowRange - 1 do begin1001 if x< 0 then1002 if y< 0 then1003 r := round(sqrt(sqr(x) + sqr(y)))1004 else if y>= Height then1005 r := round(sqrt(sqr(x) + sqr(y- (Height - 1))))984 DstPtr := TPixelPointer.Create(Dst, x0 - DpiGlowRange + 1, y0 - DpiGlowRange + 1); 985 for Y := -DpiGlowRange + 1 to Height - 1 + DpiGlowRange - 1 do begin 986 for X := -DpiGlowRange + 1 to Width - 1 + DpiGlowRange - 1 do begin 987 if X < 0 then 988 if Y < 0 then 989 R := round(sqrt(sqr(X) + sqr(Y))) 990 else if Y >= Height then 991 R := round(sqrt(sqr(X) + sqr(Y - (Height - 1)))) 1006 992 else 1007 r := -x1008 else if x>= Width then1009 if y< 0 then1010 r := round(sqrt(sqr(x - (Width - 1)) + sqr(y)))1011 else if y>= Height then1012 r := round(sqrt(sqr(x - (Width - 1)) + sqr(y- (Height - 1))))993 R := -X 994 else if X >= Width then 995 if Y < 0 then 996 R := round(sqrt(sqr(X - (Width - 1)) + sqr(Y))) 997 else if Y >= Height then 998 R := round(sqrt(sqr(X - (Width - 1)) + sqr(Y - (Height - 1)))) 1013 999 else 1014 r := x- (Width - 1)1015 else if y< 0 then1016 r := -y1017 else if y>= Height then1018 r := y- (Height - 1)1000 R := X - (Width - 1) 1001 else if Y < 0 then 1002 R := -Y 1003 else if Y >= Height then 1004 R := Y - (Height - 1) 1019 1005 else begin 1020 1006 DstPtr.NextPixel; 1021 1007 continue; 1022 1008 end; 1023 if r= 0 then1024 r:= 1;1025 if r< DpiGlowRange then1009 if R = 0 then 1010 R := 1; 1011 if R < DpiGlowRange then 1026 1012 for ch := 0 to 2 do 1027 1013 DstPtr.Pixel^.Planes[2 - ch] := 1028 (DstPtr.Pixel^.Planes[2 - ch] * ( r- 1) + (cl shr (8 * ch) and $FF) *1029 (DpiGlowRange - r)) div (DpiGlowRange - 1);1014 (DstPtr.Pixel^.Planes[2 - ch] * (R - 1) + (cl shr (8 * ch) and $FF) * 1015 (DpiGlowRange - R)) div (DpiGlowRange - 1); 1030 1016 DstPtr.NextPixel; 1031 1017 end; … … 1048 1034 MainTexture.ColorBevelLight and $FCFCFC shr 2); 1049 1035 HGrSystem2.Data.BeginUpdate; 1050 PixelPtr := PixelPointer(HGrSystem2.Data, ScaleToNative(Ornament.Left), ScaleToNative(Ornament.Top)); 1036 PixelPtr := TPixelPointer.Create(HGrSystem2.Data, ScaleToNative(Ornament.Left), 1037 ScaleToNative(Ornament.Top)); 1051 1038 if PixelPtr.BytesPerPixel = 3 then begin 1052 1039 for Y := 0 to ScaleToNative(Ornament.Height) - 1 do begin … … 1074 1061 end; 1075 1062 1076 procedure InitCityMark(T : TTexture);1077 var 1078 x: Integer;1079 y: Integer;1063 procedure InitCityMark(Texture: TTexture); 1064 var 1065 X: Integer; 1066 Y: Integer; 1080 1067 Intensity: Integer; 1081 1068 begin 1082 for x:= 0 to CityMark1.Width - 1 do begin1083 for y:= 0 to CityMark1.Height - 1 do begin1084 if HGrSystem.Mask.Canvas.Pixels[CityMark1.Left + x, CityMark1.Top + y] = 0 then1069 for X := 0 to CityMark1.Width - 1 do begin 1070 for Y := 0 to CityMark1.Height - 1 do begin 1071 if HGrSystem.Mask.Canvas.Pixels[CityMark1.Left + X, CityMark1.Top + Y] = 0 then 1085 1072 begin 1086 1073 Intensity := HGrSystem.Data.Canvas.Pixels[CityMark1.Left + 1087 x, CityMark1.Top + y] and $FF;1088 HGrSystem.Data.Canvas.Pixels[CityMark2.Left + x, CityMark2.Top + y] :=1089 T .ColorMark and $FF * Intensity div $FF + T.ColorMark shr 8 and1090 $FF * Intensity div $FF shl 8 + T .ColorMark shr 16 and1074 X, CityMark1.Top + Y] and $FF; 1075 HGrSystem.Data.Canvas.Pixels[CityMark2.Left + X, CityMark2.Top + Y] := 1076 Texture.ColorMark and $FF * Intensity div $FF + Texture.ColorMark shr 8 and 1077 $FF * Intensity div $FF shl 8 + Texture.ColorMark shr 16 and 1091 1078 $FF * Intensity div $FF shl 16; 1092 1079 end; 1093 1080 end; 1094 1081 end; 1095 DpiBit Canvas(HGrSystem.Mask.Canvas, CityMark2.Left, CityMark2.Top, CityMark1.Width, CityMark1.Width,1082 DpiBitBltCanvas(HGrSystem.Mask.Canvas, CityMark2.Left, CityMark2.Top, CityMark1.Width, CityMark1.Width, 1096 1083 HGrSystem.Mask.Canvas, CityMark1.Left, CityMark1.Top); 1097 1084 end; 1098 1085 1099 procedure Fill( ca: TDpiCanvas; Left, Top, Width, Height, xOffset, yOffset: Integer);1100 begin 1101 Assert((Left + xOffset >= 0) and (Left + xOffset + Width <= MainTexture.Width) and1102 (Top + yOffset >= 0) and (Top + yOffset + Height <= MainTexture.Height));1103 DpiBit Canvas(ca, Left, Top, Width, Height, MainTexture.Image.Canvas,1086 procedure Fill(Canvas: TDpiCanvas; Left, Top, Width, Height, xOffset, yOffset: Integer); 1087 begin 1088 //Assert((Left + xOffset >= 0) and (Left + xOffset + Width <= MainTexture.Width) and 1089 // (Top + yOffset >= 0) and (Top + yOffset + Height <= MainTexture.Height)); 1090 DpiBitBltCanvas(Canvas, Left, Top, Width, Height, MainTexture.Image.Canvas, 1104 1091 Left + xOffset, Top + yOffset); 1105 1092 end; … … 1110 1097 end; 1111 1098 1112 procedure FillLarge( ca: TDpiCanvas; x0, y0, x1, y1, xm: Integer);1099 procedure FillLarge(Canvas: TDpiCanvas; x0, y0, x1, y1, xm: Integer); 1113 1100 1114 1101 function Band(I: Integer): Integer; 1115 1102 var 1116 n: integer;1103 N: Integer; 1117 1104 begin 1118 n:= ((MainTexture.Height div 2) div (y1 - y0)) * 2;1105 N := ((MainTexture.Height div 2) div (y1 - y0)) * 2; 1119 1106 while MainTexture.Height div 2 + (I + 1) * (y1 - y0) > MainTexture.Height do 1120 Dec(I, n);1107 Dec(I, N); 1121 1108 while MainTexture.Height div 2 + I * (y1 - y0) < 0 do 1122 Inc(I, n);1109 Inc(I, N); 1123 1110 Result := I; 1124 1111 end; … … 1128 1115 begin 1129 1116 for I := 0 to (x1 - xm) div MainTexture.Width - 1 do 1130 DpiBit Canvas(ca, xm + I * MainTexture.Width, y0, MainTexture.Width, y1 - y0,1117 DpiBitBltCanvas(Canvas, xm + I * MainTexture.Width, y0, MainTexture.Width, y1 - y0, 1131 1118 MainTexture.Image.Canvas, 0, MainTexture.Height div 2 + Band(I) * 1132 1119 (y1 - y0)); 1133 DpiBit Canvas(ca, xm + ((x1 - xm) div MainTexture.Width) * MainTexture.Width, y0,1120 DpiBitBltCanvas(Canvas, xm + ((x1 - xm) div MainTexture.Width) * MainTexture.Width, y0, 1134 1121 x1 - (xm + ((x1 - xm) div MainTexture.Width) * MainTexture.Width), y1 - y0, 1135 1122 MainTexture.Image.Canvas, 0, MainTexture.Height div 2 + Band( 1136 1123 (x1 - xm) div MainTexture.Width) * (y1 - y0)); 1137 1124 for I := 0 to (xm - x0) div MainTexture.Width - 1 do 1138 DpiBit Canvas(ca, xm - (I + 1) * MainTexture.Width, y0, MainTexture.Width, y1 - y0,1125 DpiBitBltCanvas(Canvas, xm - (I + 1) * MainTexture.Width, y0, MainTexture.Width, y1 - y0, 1139 1126 MainTexture.Image.Canvas, 0, MainTexture.Height div 2 + 1140 1127 Band(-I - 1) * (y1 - y0)); 1141 DpiBit Canvas(ca, x0, y0, xm - ((xm - x0) div MainTexture.Width) *1128 DpiBitBltCanvas(Canvas, x0, y0, xm - ((xm - x0) div MainTexture.Width) * 1142 1129 MainTexture.Width - x0, y1 - y0, MainTexture.Image.Canvas, 1143 1130 ((xm - x0) div MainTexture.Width + 1) * MainTexture.Width - (xm - x0), … … 1145 1132 end; 1146 1133 1147 procedure FillSeamless( ca: TDpiCanvas; Left, Top, Width, Height, xOffset, yOffset: Integer;1134 procedure FillSeamless(Canvas: TDpiCanvas; Left, Top, Width, Height, xOffset, yOffset: Integer; 1148 1135 const Texture: TDpiBitmap); 1149 1136 var 1150 x, y, x0cut, y0cut, x1cut, y1cut: Integer;1137 X, Y, x0cut, y0cut, x1cut, y1cut: Integer; 1151 1138 begin 1152 1139 while xOffset < 0 do … … 1154 1141 while yOffset < 0 do 1155 1142 Inc(yOffset, Texture.Height); 1156 for y:= (Top + yOffset) div Texture.Height to (Top + yOffset + Height - 1) div1143 for Y := (Top + yOffset) div Texture.Height to (Top + yOffset + Height - 1) div 1157 1144 Texture.Height do 1158 1145 begin 1159 y0cut := Top + yOffset - y* Texture.Height;1146 y0cut := Top + yOffset - Y * Texture.Height; 1160 1147 if y0cut < 0 then 1161 1148 y0cut := 0; 1162 y1cut := ( y+ 1) * Texture.Height - (Top + yOffset + Height);1149 y1cut := (Y + 1) * Texture.Height - (Top + yOffset + Height); 1163 1150 if y1cut < 0 then 1164 1151 y1cut := 0; 1165 for x:= (Left + xOffset) div Texture.Width to (Left + xOffset + Width - 1) div1152 for X := (Left + xOffset) div Texture.Width to (Left + xOffset + Width - 1) div 1166 1153 Texture.Width do 1167 1154 begin 1168 x0cut := Left + xOffset - x* Texture.Width;1155 x0cut := Left + xOffset - X * Texture.Width; 1169 1156 if x0cut < 0 then 1170 1157 x0cut := 0; 1171 x1cut := ( x+ 1) * Texture.Width - (Left + xOffset + Width);1158 x1cut := (X + 1) * Texture.Width - (Left + xOffset + Width); 1172 1159 if x1cut < 0 then 1173 1160 x1cut := 0; 1174 DpiBit Canvas(ca, x* Texture.Width + x0cut - xOffset,1175 y* Texture.Height + y0cut - yOffset, Texture.Width - x0cut - x1cut,1161 DpiBitBltCanvas(Canvas, X * Texture.Width + x0cut - xOffset, 1162 Y * Texture.Height + y0cut - yOffset, Texture.Width - x0cut - x1cut, 1176 1163 Texture.Height - y0cut - y1cut, Texture.Canvas, x0cut, y0cut); 1177 1164 end; … … 1179 1166 end; 1180 1167 1181 procedure FillRectSeamless( ca: TDpiCanvas; x0, y0, x1, y1, xOffset, yOffset: Integer;1168 procedure FillRectSeamless(Canvas: TDpiCanvas; x0, y0, x1, y1, xOffset, yOffset: Integer; 1182 1169 const Texture: TDpiBitmap); 1183 1170 begin 1184 FillSeamless( ca, x0, y0, x1 - x0, y1 - y0, xOffset, yOffset, Texture);1171 FillSeamless(Canvas, x0, y0, x1 - x0, y1 - y0, xOffset, yOffset, Texture); 1185 1172 end; 1186 1173 … … 1191 1178 end; 1192 1179 1193 procedure Corner( ca: TDpiCanvas; x, y, Kind: Integer; T: TTexture);1194 begin 1195 { DpiBit Canvas(ca,x,y,8,8,T.HGr.Mask.Canvas,1180 procedure Corner(Canvas: TDpiCanvas; X, Y, Kind: Integer; T: TTexture); 1181 begin 1182 { DpiBitBltCanvas(Canvas,x,y,8,8,T.HGr.Mask.Canvas, 1196 1183 T.xGr+29+Kind*9,T.yGr+89,SRCAND); 1197 DpiBit Canvas(ca,x,y,8,8,T.HGr.Data.Canvas,1184 DpiBitBltCanvas(Canvas,X,Y,8,8,T.HGr.Data.Canvas, 1198 1185 T.xGr+29+Kind*9,T.yGr+89,SRCPAINT); } 1199 1186 end; 1200 1187 1201 procedure BiColorTextOut( ca: TDpiCanvas; clMain, clBack: TColor; x, y: Integer; s: string);1202 1203 procedure PaintIcon( x, y, Kind: Integer);1188 procedure BiColorTextOut(Canvas: TDpiCanvas; clMain, clBack: TColor; X, Y: Integer; S: string); 1189 1190 procedure PaintIcon(X, Y, Kind: Integer); 1204 1191 begin 1205 DpiBit Canvas(ca, x, y+ 6, 10, 10, HGrSystem.Mask.Canvas,1192 DpiBitBltCanvas(Canvas, X, Y + 6, 10, 10, HGrSystem.Mask.Canvas, 1206 1193 66 + Kind mod 11 * 11, 115 + Kind div 11 * 11, SRCAND); 1207 DpiBit Canvas(ca, x, y+ 6, 10, 10, HGrSystem.Data.Canvas,1194 DpiBitBltCanvas(Canvas, X, Y + 6, 10, 10, HGrSystem.Data.Canvas, 1208 1195 66 + Kind mod 11 * 11, 115 + Kind div 11 * 11, SRCPAINT); 1209 1196 end; 1210 1197 1211 1198 var 1212 p, xp: Integer;1199 P, xp: Integer; 1213 1200 sp: string; 1214 1201 shadow: Boolean; 1215 1202 Text: string; 1216 1203 begin 1217 Inc( x);1218 Inc( y);1204 Inc(X); 1205 Inc(Y); 1219 1206 for shadow := True downto False do 1220 with cado1207 with Canvas do 1221 1208 if not shadow or (clBack <> $7F007F) then 1222 1209 begin … … 1225 1212 else 1226 1213 Font.Color := clMain; 1227 sp := s;1228 xp := x;1214 sp := S; 1215 xp := X; 1229 1216 repeat 1230 p := pos('%', sp);1231 if ( p = 0) or (p+ 1 > Length(sp)) or not1232 (sp[ p+ 1] in ['c', 'f', 'l', 'm', 'n', 'o', 'p', 'r', 't', 'w']) then1217 P := Pos('%', sp); 1218 if (P = 0) or (P + 1 > Length(sp)) or not 1219 (sp[P + 1] in ['c', 'f', 'l', 'm', 'n', 'o', 'p', 'r', 't', 'w']) then 1233 1220 begin 1234 ca.Textout(xp, y, sp);1221 Canvas.Textout(xp, Y, sp); 1235 1222 Break; 1236 1223 end 1237 1224 else 1238 1225 begin 1239 Text := Copy(sp, 1, p- 1);1240 Textout(xp, y, Text);1241 Inc(xp, ca.TextWidth(Text));1226 Text := Copy(sp, 1, P - 1); 1227 Textout(xp, Y, Text); 1228 Inc(xp, Canvas.TextWidth(Text)); 1242 1229 if not shadow then 1243 case sp[ p+ 1] of1244 'c': PaintIcon(xp + 1, y, 6);1245 'f': PaintIcon(xp + 1, y, 0);1246 'l': PaintIcon(xp + 1, y, 8);1247 'm': PaintIcon(xp + 1, y, 17);1248 'n': PaintIcon(xp + 1, y, 7);1249 'o': PaintIcon(xp + 1, y, 16);1250 'p': PaintIcon(xp + 1, y, 2);1251 'r': PaintIcon(xp + 1, y, 12);1252 't': PaintIcon(xp + 1, y, 4);1253 'w': PaintIcon(xp + 1, y, 13);1230 case sp[P + 1] of 1231 'c': PaintIcon(xp + 1, Y, 6); 1232 'f': PaintIcon(xp + 1, Y, 0); 1233 'l': PaintIcon(xp + 1, Y, 8); 1234 'm': PaintIcon(xp + 1, Y, 17); 1235 'n': PaintIcon(xp + 1, Y, 7); 1236 'o': PaintIcon(xp + 1, Y, 16); 1237 'p': PaintIcon(xp + 1, Y, 2); 1238 'r': PaintIcon(xp + 1, Y, 12); 1239 't': PaintIcon(xp + 1, Y, 4); 1240 'w': PaintIcon(xp + 1, Y, 13); 1254 1241 end; 1255 1242 Inc(xp, 10); 1256 Delete(sp, 1, p+ 1);1243 Delete(sp, 1, P + 1); 1257 1244 end; 1258 1245 until False; 1259 Dec( x);1260 Dec( y);1246 Dec(X); 1247 Dec(Y); 1261 1248 end; 1262 1249 end; 1263 1250 1264 function BiColorTextWidth( ca: TDpiCanvas; s: string): Integer;1251 function BiColorTextWidth(Canvas: TDpiCanvas; S: string): Integer; 1265 1252 var 1266 1253 P: Integer; … … 1268 1255 Result := 1; 1269 1256 repeat 1270 P := Pos('%', s);1271 if (P = 0) or (P = Length( s)) then1257 P := Pos('%', S); 1258 if (P = 0) or (P = Length(S)) then 1272 1259 begin 1273 Inc(Result, ca.TextWidth(s));1260 Inc(Result, Canvas.TextWidth(S)); 1274 1261 Break; 1275 1262 end 1276 1263 else 1277 1264 begin 1278 if not ( s[P + 1] in ['c', 'f', 'l', 'm', 'n', 'o', 'p', 'r', 't', 'w'])1265 if not (S[P + 1] in ['c', 'f', 'l', 'm', 'n', 'o', 'p', 'r', 't', 'w']) 1279 1266 then 1280 Inc(Result, ca.TextWidth(copy(s, 1, P + 1)))1267 Inc(Result, Canvas.TextWidth(Copy(S, 1, P + 1))) 1281 1268 else 1282 Inc(Result, ca.TextWidth(copy(s, 1, P - 1)) + 10);1283 Delete( s, 1, P + 1);1269 Inc(Result, Canvas.TextWidth(Copy(S, 1, P - 1)) + 10); 1270 Delete(S, 1, P + 1); 1284 1271 end; 1285 1272 until False; 1286 1273 end; 1287 1274 1288 procedure LoweredTextOut( ca: TDpiCanvas; cl: TColor; T: TTexture;1289 x, y: Integer; s: string);1275 procedure LoweredTextOut(Canvas: TDpiCanvas; cl: TColor; T: TTexture; 1276 X, Y: Integer; S: string); 1290 1277 begin 1291 1278 if cl = -2 then 1292 BiColorTextOut( ca, (T.ColorBevelShade and $FEFEFE) shr 1,1293 T.ColorBevelLight, x, y, s)1279 BiColorTextOut(Canvas, (T.ColorBevelShade and $FEFEFE) shr 1, 1280 T.ColorBevelLight, X, Y, S) 1294 1281 else if cl < 0 then 1295 BiColorTextOut( ca, T.ColorTextShade, T.ColorTextLight, x, y, s)1282 BiColorTextOut(Canvas, T.ColorTextShade, T.ColorTextLight, X, Y, S) 1296 1283 else 1297 BiColorTextOut( ca, cl, T.ColorTextLight, x, y, s);1298 end; 1299 1300 procedure RisedTextOut( ca: TDpiCanvas; x, y: integer; s: string);1301 begin 1302 BiColorTextOut( ca, $FFFFFF, $000000, x, y, s);1303 end; 1304 1305 procedure Gradient( ca: TDpiCanvas; x, y, dx, dy, Width, Height, Color: Integer;1306 Brightness: array of integer);1307 var 1308 i, r, g, b: Integer;1309 begin 1310 for i:= 0 to Length(Brightness) - 1 do begin // gradient1311 r := Color and $FF + Brightness[i];1312 if r< 0 then1313 r:= 01314 else if r>= 256 then1315 r:= 255;1316 g := Color shr 8 and $FF + Brightness[i];1317 if g< 0 then1318 g:= 01319 else if g>= 256 then1320 g:= 255;1321 b := Color shr 16 and $FF + Brightness[i];1322 if b< 0 then1323 b:= 01324 else if b>= 256 then1325 b:= 255;1326 ca.Pen.Color := r + g shl 8 + bshl 16;1327 ca.MoveTo(x + dx * i, y + dy * i);1328 ca.LineTo(x + dx * i + Width, y + dy * i+ Height);1329 end; 1330 ca.Pen.Color := $000000;1331 ca.MoveTo(x + 1, y+ 16 * dy + Height);1332 ca.LineTo(x + 16 * dx + Width, y+ 16 * dy + Height);1333 ca.LineTo(x + 16 * dx + Width, y);1334 end; 1335 1336 procedure LightGradient( ca: TDpiCanvas; x, y, Width, Color: Integer);1284 BiColorTextOut(Canvas, cl, T.ColorTextLight, X, Y, S); 1285 end; 1286 1287 procedure RisedTextOut(Canvas: TDpiCanvas; X, Y: Integer; S: string); 1288 begin 1289 BiColorTextOut(Canvas, $FFFFFF, $000000, X, Y, S); 1290 end; 1291 1292 procedure Gradient(Canvas: TDpiCanvas; X, Y, dx, dy, Width, Height, Color: Integer; 1293 Brightness: array of Integer); 1294 var 1295 I, R, G, B: Integer; 1296 begin 1297 for I := 0 to Length(Brightness) - 1 do begin // gradient 1298 R := Color and $FF + Brightness[I]; 1299 if R < 0 then 1300 R := 0 1301 else if R >= 256 then 1302 R := 255; 1303 G := Color shr 8 and $FF + Brightness[I]; 1304 if G < 0 then 1305 G := 0 1306 else if G >= 256 then 1307 G := 255; 1308 B := Color shr 16 and $FF + Brightness[I]; 1309 if B < 0 then 1310 B := 0 1311 else if B >= 256 then 1312 B := 255; 1313 Canvas.Pen.Color := R + G shl 8 + B shl 16; 1314 Canvas.MoveTo(X + dx * I, Y + dy * I); 1315 Canvas.LineTo(X + dx * I + Width, Y + dy * I + Height); 1316 end; 1317 Canvas.Pen.Color := $000000; 1318 Canvas.MoveTo(X + 1, Y + 16 * dy + Height); 1319 Canvas.LineTo(X + 16 * dx + Width, Y + 16 * dy + Height); 1320 Canvas.LineTo(X + 16 * dx + Width, Y); 1321 end; 1322 1323 procedure LightGradient(Canvas: TDpiCanvas; X, Y, Width, Color: Integer); 1337 1324 const 1338 Brightness: array [0 .. 15] of integer =1325 Brightness: array [0 .. 15] of Integer = 1339 1326 (16, 12, 8, 4, 0, -4, -8, -12, -16, -20, -24, -28, -32, -36, -40, -44); 1340 1327 begin 1341 Gradient( ca, x, y, 0, 1, Width, 0, Color, Brightness);1342 end; 1343 1344 procedure DarkGradient( ca: TDpiCanvas; x, y, Width, Kind: Integer);1328 Gradient(Canvas, X, Y, 0, 1, Width, 0, Color, Brightness); 1329 end; 1330 1331 procedure DarkGradient(Canvas: TDpiCanvas; X, Y, Width, Kind: Integer); 1345 1332 const 1346 Brightness: array [0 .. 15] of integer =1333 Brightness: array [0 .. 15] of Integer = 1347 1334 (16, 12, 8, 4, 0, -4, -8, -12 - 24, -16 + 16, -20, -24, -28, -32, -36, -40, -44); 1348 1335 begin 1349 Gradient( ca, x, y, 0, 1, Width, 0, HGrSystem.Data.Canvas.Pixels1336 Gradient(Canvas, X, Y, 0, 1, Width, 0, HGrSystem.Data.Canvas.Pixels 1350 1337 [187, 137 + Kind], Brightness); 1351 1338 end; 1352 1339 1353 procedure VLightGradient( ca: TDpiCanvas; x, y, Height, Color: Integer);1340 procedure VLightGradient(Canvas: TDpiCanvas; X, Y, Height, Color: Integer); 1354 1341 const 1355 Brightness: array [0 .. 15] of integer =1342 Brightness: array [0 .. 15] of Integer = 1356 1343 (16, 12, 8, 4, 0, -4, -8, -12, -16, -20, -24, -28, -32, -36, -40, -44); 1357 1344 begin 1358 Gradient( ca, x, y, 1, 0, 0, Height, Color, Brightness);1359 end; 1360 1361 procedure VDarkGradient( ca: TDpiCanvas; x, y, Height, Kind: Integer);1345 Gradient(Canvas, X, Y, 1, 0, 0, Height, Color, Brightness); 1346 end; 1347 1348 procedure VDarkGradient(Canvas: TDpiCanvas; X, Y, Height, Kind: Integer); 1362 1349 const 1363 Brightness: array [0 .. 15] of integer =1350 Brightness: array [0 .. 15] of Integer = 1364 1351 (16, 12, 8, 4, 0, -4, -8, -12 - 24, -16 + 16, -20, -24, -28, -32, -36, -40, -44); 1365 1352 begin 1366 Gradient( ca, x, y, 1, 0, 0, Height,1353 Gradient(Canvas, X, Y, 1, 0, 0, Height, 1367 1354 HGrSystem.Data.Canvas.Pixels[187, 137 + Kind], Brightness); 1368 1355 end; … … 1375 1362 end; 1376 1363 1377 procedure NumberBar(dst: TDpiBitmap; x, y: integer; Cap: string;1364 procedure NumberBar(dst: TDpiBitmap; X, Y: Integer; Cap: string; 1378 1365 val: Integer; T: TTexture); 1379 1366 var 1380 s: string;1367 S: string; 1381 1368 begin 1382 1369 if val > 0 then 1383 1370 begin 1384 DLine(dst.Canvas, x - 2, x + 170, y+ 16, T.ColorBevelShade,1371 DLine(dst.Canvas, X - 2, X + 170, Y + 16, T.ColorBevelShade, 1385 1372 T.ColorBevelLight); 1386 LoweredTextOut(dst.Canvas, -1, T, x - 2, y, Cap);1387 s:= IntToStr(val);1388 RisedTextOut(dst.Canvas, x+ 170 - BiColorTextWidth(dst.Canvas,1389 s), y, s);1390 end; 1391 end; 1392 1393 procedure CountBar(dst: TDpiBitmap; x, y, w: Integer; Kind: Integer;1373 LoweredTextOut(dst.Canvas, -1, T, X - 2, Y, Cap); 1374 S := IntToStr(val); 1375 RisedTextOut(dst.Canvas, X + 170 - BiColorTextWidth(dst.Canvas, 1376 S), Y, S); 1377 end; 1378 end; 1379 1380 procedure CountBar(dst: TDpiBitmap; X, Y, W: Integer; Kind: Integer; 1394 1381 Cap: string; val: Integer; T: TTexture); 1395 1382 var 1396 i, sd, ld, cl, xIcon, yIcon: Integer;1397 s: string;1383 I, sd, ld, cl, xIcon, yIcon: Integer; 1384 S: string; 1398 1385 begin 1399 1386 // val:=random(40); //!!! … … 1407 1394 // DLine(dst.Canvas,x-2,x+170+32,y+16,T.ColorBevelShade,T.ColorBevelLight); 1408 1395 1409 xIcon := x- 5;1410 yIcon := y+ 15;1411 DLine(dst.Canvas, x - 2, xIcon + w+ 2, yIcon + 16, T.ColorBevelShade,1396 xIcon := X - 5; 1397 yIcon := Y + 15; 1398 DLine(dst.Canvas, X - 2, xIcon + W + 2, yIcon + 16, T.ColorBevelShade, 1412 1399 T.ColorBevelLight); 1413 1400 1414 s:= IntToStr(val);1401 S := IntToStr(val); 1415 1402 if val < 0 then 1416 1403 cl := $0000FF 1417 1404 else 1418 1405 cl := -1; 1419 LoweredTextOut(dst.Canvas, cl, T, x - 2, y, Cap);1406 LoweredTextOut(dst.Canvas, cl, T, X - 2, Y, Cap); 1420 1407 LoweredTextOut(dst.Canvas, cl, T, 1421 xIcon + w + 2 - BiColorTextWidth(dst.Canvas, s), yIcon, s);1408 xIcon + W + 2 - BiColorTextWidth(dst.Canvas, S), yIcon, S); 1422 1409 1423 1410 if (Kind = 12) and (val >= 100) then … … 1427 1414 if sd = 0 then 1428 1415 sd := 1; 1429 if sd < w- 44 then1416 if sd < W - 44 then 1430 1417 ld := sd 1431 1418 else 1432 ld := w- 44;1433 for i:= 0 to val mod 10 - 1 do1419 ld := W - 44; 1420 for I := 0 to val mod 10 - 1 do 1434 1421 begin 1435 DpiBit Canvas(dst.Canvas, xIcon + 4 + i* (14 * ld div sd), yIcon + 2 + 1, 14,1422 DpiBitBltCanvas(dst.Canvas, xIcon + 4 + I * (14 * ld div sd), yIcon + 2 + 1, 14, 1436 1423 14, HGrSystem.Mask.Canvas, 67 + Kind mod 8 * 15, 1437 1424 70 + Kind div 8 * 15, SRCAND); 1438 Sprite(dst, HGrSystem, xIcon + 3 + i* (14 * ld div sd), yIcon + 2,1425 Sprite(dst, HGrSystem, xIcon + 3 + I * (14 * ld div sd), yIcon + 2, 1439 1426 14, 14, 67 + Kind mod 8 * 15, 70 + Kind div 8 * 15); 1440 1427 end; 1441 for i:= 0 to val div 10 - 1 do1428 for I := 0 to val div 10 - 1 do 1442 1429 begin 1443 DpiBit Canvas(dst.Canvas, xIcon + 4 + (val mod 10) *1444 (14 * ld div sd) + i* (14 * ld div sd), yIcon + 3, 14, 14,1430 DpiBitBltCanvas(dst.Canvas, xIcon + 4 + (val mod 10) * 1431 (14 * ld div sd) + I * (14 * ld div sd), yIcon + 3, 14, 14, 1445 1432 HGrSystem.Mask.Canvas, 67 + 7 mod 8 * 15, 1446 1433 70 + 7 div 8 * 15, SRCAND); 1447 1434 Sprite(dst, HGrSystem, xIcon + 3 + (val mod 10) * 1448 (14 * ld div sd) + i* (14 * ld div sd), yIcon + 2, 14,1435 (14 * ld div sd) + I * (14 * ld div sd), yIcon + 2, 14, 1449 1436 14, 67 + 7 mod 8 * 15, 1450 1437 70 + 7 div 8 * 15); … … 1460 1447 if sd = 0 then 1461 1448 sd := 1; 1462 if sd < w- 44 then1449 if sd < W - 44 then 1463 1450 ld := sd 1464 1451 else 1465 ld := w- 44;1466 for i:= 0 to val div 10 - 1 do1452 ld := W - 44; 1453 for I := 0 to val div 10 - 1 do 1467 1454 begin 1468 DpiBit Canvas(dst.Canvas, xIcon + 4 + i* (14 * ld div sd), yIcon + 3, 14, 14,1455 DpiBitBltCanvas(dst.Canvas, xIcon + 4 + I * (14 * ld div sd), yIcon + 3, 14, 14, 1469 1456 HGrSystem.Mask.Canvas, 67 + Kind mod 8 * 15, 1470 1457 70 + Kind div 8 * 15, SRCAND); 1471 Sprite(dst, HGrSystem, xIcon + 3 + i* (14 * ld div sd), yIcon + 2,1458 Sprite(dst, HGrSystem, xIcon + 3 + I * (14 * ld div sd), yIcon + 2, 1472 1459 14, 14, 67 + Kind mod 8 * 15, 70 + Kind div 8 * 15); 1473 1460 end; 1474 for i:= 0 to val mod 10 - 1 do1461 for I := 0 to val mod 10 - 1 do 1475 1462 begin 1476 DpiBit Canvas(dst.Canvas, xIcon + 4 + (val div 10) *1477 (14 * ld div sd) + i* (10 * ld div sd), yIcon + 7, 10, 10,1463 DpiBitBltCanvas(dst.Canvas, xIcon + 4 + (val div 10) * 1464 (14 * ld div sd) + I * (10 * ld div sd), yIcon + 7, 10, 10, 1478 1465 HGrSystem.Mask.Canvas, 66 + Kind mod 11 * 11, 1479 1466 115 + Kind div 11 * 11, SRCAND); 1480 1467 Sprite(dst, HGrSystem, xIcon + 3 + (val div 10) * 1481 (14 * ld div sd) + i* (10 * ld div sd), yIcon + 6, 10,1468 (14 * ld div sd) + I * (10 * ld div sd), yIcon + 6, 10, 1482 1469 10, 66 + Kind mod 11 * 11, 1483 1470 115 + Kind div 11 * 11); … … 1487 1474 end; 1488 1475 1489 procedure PaintProgressBar( ca: TDpiCanvas; Kind, x, y, pos, Growth, max: Integer;1476 procedure PaintProgressBar(Canvas: TDpiCanvas; Kind, X, Y, Pos, Growth, Max: Integer; 1490 1477 T: TTexture); 1491 1478 var 1492 i: Integer;1493 begin 1494 if pos > max then1495 pos := max;1479 I: Integer; 1480 begin 1481 if Pos > Max then 1482 Pos := Max; 1496 1483 if Growth < 0 then 1497 1484 begin 1498 pos := pos + Growth;1499 if pos < 0 then1485 Pos := Pos + Growth; 1486 if Pos < 0 then 1500 1487 begin 1501 Growth := Growth - pos;1502 pos := 0;1488 Growth := Growth - Pos; 1489 Pos := 0; 1503 1490 end; 1504 1491 end 1505 else if pos + Growth > max then1506 Growth := max - pos;1507 Frame( ca, x - 1, y - 1, x + max, y+ 7, $000000, $000000);1508 RFrame( ca, x - 2, y - 2, x + max + 1, y+ 8, T.ColorBevelShade,1492 else if Pos + Growth > Max then 1493 Growth := Max - Pos; 1494 Frame(Canvas, X - 1, Y - 1, X + Max, Y + 7, $000000, $000000); 1495 RFrame(Canvas, X - 2, Y - 2, X + Max + 1, Y + 8, T.ColorBevelShade, 1509 1496 T.ColorBevelLight); 1510 with cado1497 with Canvas do 1511 1498 begin 1512 for i := 0 to pos div 8 - 1 do1513 DpiBit Canvas(ca, x + i * 8, y, 8, 7,1499 for I := 0 to Pos div 8 - 1 do 1500 DpiBitBltCanvas(Canvas, X + I * 8, Y, 8, 7, 1514 1501 HGrSystem.Data.Canvas, 104, 9 + 8 * Kind); 1515 DpiBit Canvas(ca, x + 8 * (pos div 8), y, pos - 8 * (pos div 8), 7,1502 DpiBitBltCanvas(Canvas, X + 8 * (Pos div 8), Y, Pos - 8 * (Pos div 8), 7, 1516 1503 HGrSystem.Data.Canvas, 104, 9 + 8 * Kind); 1517 1504 if Growth > 0 then 1518 1505 begin 1519 for i:= 0 to Growth div 8 - 1 do1520 DpiBit Canvas(ca, x + pos + i * 8, y, 8, 7,1506 for I := 0 to Growth div 8 - 1 do 1507 DpiBitBltCanvas(Canvas, X + Pos + I * 8, Y, 8, 7, 1521 1508 HGrSystem.Data.Canvas, 112, 9 + 8 * Kind); 1522 DpiBit Canvas(ca, x + pos + 8 * (Growth div 8), y,1509 DpiBitBltCanvas(Canvas, X + Pos + 8 * (Growth div 8), Y, 1523 1510 Growth - 8 * (Growth div 8), 7, HGrSystem.Data.Canvas, 1524 1511 112, 9 + 8 * Kind); … … 1526 1513 else if Growth < 0 then 1527 1514 begin 1528 for i:= 0 to -Growth div 8 - 1 do1529 DpiBit Canvas(ca, x + pos + i * 8, y, 8, 7,1515 for I := 0 to -Growth div 8 - 1 do 1516 DpiBitBltCanvas(Canvas, X + Pos + I * 8, Y, 8, 7, 1530 1517 HGrSystem.Data.Canvas, 104, 1); 1531 DpiBit Canvas(ca, x + pos + 8 * (-Growth div 8), y, -Growth -1518 DpiBitBltCanvas(Canvas, X + Pos + 8 * (-Growth div 8), Y, -Growth - 1532 1519 8 * (-Growth div 8), 7, 1533 1520 HGrSystem.Data.Canvas, 104, 1); 1534 1521 end; 1535 1522 Brush.Color := $000000; 1536 FillRect(Rect( x + pos + abs(Growth), y, x + max, y+ 7));1523 FillRect(Rect(X + Pos + abs(Growth), Y, X + Max, Y + 7)); 1537 1524 Brush.Style := bsClear; 1538 1525 end; … … 1540 1527 1541 1528 // pos and growth are relative to max, set size independent 1542 procedure PaintRelativeProgressBar( ca: TDpiCanvas;1543 Kind, x, y, size, pos, Growth, max: Integer; IndicateComplete: Boolean;1529 procedure PaintRelativeProgressBar(Canvas: TDpiCanvas; 1530 Kind, X, Y, size, Pos, Growth, Max: Integer; IndicateComplete: Boolean; 1544 1531 T: TTexture); 1545 1532 begin 1546 1533 if Growth > 0 then 1547 PaintProgressBar( ca, Kind, x, y, pos * size div max,1548 (Growth * size + max div 2) div max, size, T)1534 PaintProgressBar(Canvas, Kind, X, Y, Pos * size div Max, 1535 (Growth * size + Max div 2) div Max, size, T) 1549 1536 else 1550 PaintProgressBar( ca, Kind, x, y, pos * size div max,1551 (Growth * size - max div 2) div max, size, T);1552 if IndicateComplete and ( pos + Growth >= max) then1553 Sprite( ca, HGrSystem, x + size - 10, y- 7, 23, 16, 1, 129);1537 PaintProgressBar(Canvas, Kind, X, Y, Pos * size div Max, 1538 (Growth * size - Max div 2) div Max, size, T); 1539 if IndicateComplete and (Pos + Growth >= Max) then 1540 Sprite(Canvas, HGrSystem, X + size - 10, Y - 7, 23, 16, 1, 129); 1554 1541 end; 1555 1542 … … 1557 1544 begin 1558 1545 UnshareBitmap(LogoBuffer); 1559 DpiBit Canvas(LogoBuffer.Canvas, 0, 0, Logo.Width, Logo.Height, Canvas, X, Y);1546 DpiBitBltCanvas(LogoBuffer.Canvas, 0, 0, Logo.Width, Logo.Height, Canvas, X, Y); 1560 1547 ImageOp_BCC(LogoBuffer, Templates.Data, Point(0, 0), Logo.BoundsRect, 1561 1548 LightColor, ShadeColor); 1562 DpiBit Canvas(Canvas, X, Y, Logo.Width, Logo.Height, LogoBuffer.Canvas, 0, 0);1549 DpiBitBltCanvas(Canvas, X, Y, Logo.Width, Logo.Height, LogoBuffer.Canvas, 0, 0); 1563 1550 end; 1564 1551 … … 1602 1589 TexWidth := Texture.Width; 1603 1590 TexHeight := Texture.Height; 1604 DstPixel := PixelPointer(Dest);1605 SrcPixel := PixelPointer(Texture);1591 DstPixel := TPixelPointer.Create(Dest); 1592 SrcPixel := TPixelPointer.Create(Texture); 1606 1593 for Y := 0 to ScaleToNative(Dest.Height) - 1 do begin 1607 1594 for X := 0 to ScaleToNative(Dest.Width) - 1 do begin … … 1621 1608 procedure DarkenImage(Bitmap: TDpiBitmap; Change: Integer); 1622 1609 var 1623 x, y: integer;1610 X, Y: Integer; 1624 1611 PicturePixel: TPixelPointer; 1625 1612 begin 1626 1613 Bitmap.BeginUpdate; 1627 PicturePixel := PixelPointer(Bitmap);1628 for y:= 0 to ScaleToNative(Bitmap.Height) - 1 do begin1629 for x:= 0 to ScaleToNative(Bitmap.Width) - 1 do begin1614 PicturePixel := TPixelPointer.Create(Bitmap); 1615 for Y := 0 to ScaleToNative(Bitmap.Height) - 1 do begin 1616 for X := 0 to ScaleToNative(Bitmap.Width) - 1 do begin 1630 1617 PicturePixel.Pixel^.B := Max(PicturePixel.Pixel^.B - Change, 0); 1631 1618 PicturePixel.Pixel^.G := Max(PicturePixel.Pixel^.G - Change, 0); … … 1645 1632 1646 1633 procedure Gtk2Fix; 1634 {$IFDEF UNIX} 1647 1635 var 1648 1636 I: Integer; 1649 begin 1650 {$IFDEF LINUX} 1637 {$ENDIF} 1638 begin 1639 {$IFDEF UNIX} 1651 1640 // Wait and process messages little bit to avoid crash or force repaint under Gtk2 1652 1641 for I := 0 to 10 do begin … … 1661 1650 Section: TFontType; 1662 1651 FontScript: TextFile; 1663 Size: integer;1652 Size: Integer; 1664 1653 S: string; 1665 I: integer;1666 P: integer;1654 I: Integer; 1655 P: Integer; 1667 1656 begin 1668 1657 Section := ftNormal; … … 1671 1660 Reset(FontScript); 1672 1661 while not Eof(FontScript) do begin 1673 ReadLn(FontScript, s);1674 if s<> '' then1675 if s[1] = '#' then begin1676 s := TrimRight(s);1677 if s= '#SMALL' then Section := ftSmall1678 else if s= '#TINY' then Section := ftTiny1679 else if s= '#CAPTION' then Section := ftCaption1680 else if s= '#BUTTON' then Section := ftButton1662 ReadLn(FontScript, S); 1663 if S <> '' then 1664 if S[1] = '#' then begin 1665 S := TrimRight(S); 1666 if S = '#SMALL' then Section := ftSmall 1667 else if S = '#TINY' then Section := ftTiny 1668 else if S = '#CAPTION' then Section := ftCaption 1669 else if S = '#BUTTON' then Section := ftButton 1681 1670 else Section := ftNormal; 1682 1671 end else begin 1683 p := Pos(',', s);1684 if p> 0 then begin1685 UniFont[section].Name := Trim(Copy( s, 1, p- 1));1672 P := Pos(',', S); 1673 if P > 0 then begin 1674 UniFont[section].Name := Trim(Copy(S, 1, P - 1)); 1686 1675 Size := 0; 1687 for i := p + 1 to Length(s) do1688 case s[i] of1676 for I := P + 1 to Length(S) do 1677 case S[I] of 1689 1678 '0' .. '9': 1690 Size := Size * 10 + Byte( s[i]) - 48;1679 Size := Size * 10 + Byte(S[I]) - 48; 1691 1680 'B', 'b': 1692 1681 UniFont[section].Style := UniFont[section].Style + [fsBold]; … … 1731 1720 LoadPhrases; 1732 1721 LoadFonts; 1733 Templates := LoadGraphicSet 2('Templates.png');1722 Templates := LoadGraphicSet('Templates.png', False); 1734 1723 with Templates do begin 1735 1724 Logo := GetItem('Logo'); … … 1770 1759 1771 1760 HGrSystem := LoadGraphicSet('System.png'); 1772 CityMark1 := HGrSystem.GetItem('CityMark1'); 1773 CityMark2 := HGrSystem.GetItem('CityMark2'); 1761 with HGrSystem do begin 1762 CityMark1 := GetItem('CityMark1'); 1763 CityMark2 := GetItem('CityMark2'); 1764 end; 1774 1765 1775 1766 HGrSystem2 := LoadGraphicSet('System2.png'); 1776 Ornament := HGrSystem2.GetItem('Ornament'); 1767 with HGrSystem2 do begin 1768 Ornament := GetItem('Ornament'); 1769 GBrainNoTerm := GetItem('BrainNoTerm'); 1770 GBrainSuperVirtual := GetItem('BrainSuperVirtual'); 1771 GBrainTerm := GetItem('BrainTerm'); 1772 GBrainRandom := GetItem('BrainRandom'); 1773 end; 1777 1774 1778 1775 Colors := TDpiBitmap.Create; -
branches/highdpi/Packages/CevoComponents/Sound.pas
r405 r463 4 4 5 5 uses 6 UDpiControls, SysUtils, Classes, Graphics, Controls, Forms, fgl, FileUtil,6 UDpiControls, SysUtils, Classes, Graphics, Controls, Forms, Generics.Collections, FileUtil, 7 7 StringTables, Directories, LCLType 8 8 {$IFDEF WINDOWS}, MMSystem, Windows{$ENDIF} 9 {$IFDEF LINUX}, Process, AsyncProcess2{$ENDIF};9 {$IFDEF UNIX}, Process, AsyncProcess2{$ENDIF}; 10 10 11 11 type … … 29 29 TSound = class 30 30 private 31 {$IFDEF LINUX}31 {$IFDEF UNIX} 32 32 PlayCommand: string; 33 33 SoundPlayerAsyncProcess: TAsyncProcess; … … 55 55 SoundMode: TSoundMode; 56 56 SoundPlayer: TSoundPlayer; 57 SoundList: T FPGObjectList<TSound>;57 SoundList: TObjectList<TSound>; 58 58 PlayingSound: TSound; 59 59 … … 63 63 {$R *.lfm} 64 64 65 {$IFDEF LINUX}65 {$IFDEF UNIX} 66 66 resourcestring 67 67 SUnableToPlay = 'PlayStyle=%s: Unable to play %s Message:%s'; … … 88 88 end 89 89 {$ENDIF} 90 {$IFDEF LINUX}90 {$IFDEF UNIX} 91 91 PlayCommand := GetNonWindowsPlayCommand; 92 92 FDeviceID := 1; … … 100 100 mciSendCommand(FDeviceID, MCI_CLOSE, MCI_WAIT, 0); 101 101 {$ENDIF} 102 {$IFDEF LINUX}102 {$IFDEF UNIX} 103 103 FreeAndNil(SoundPlayerSyncProcess); 104 104 FreeAndNil(SoundPlayerAsyncProcess); … … 162 162 PlayParm: TMCI_Play_Parms; 163 163 {$ENDIF} 164 {$IFDEF LINUX}164 {$IFDEF UNIX} 165 165 var 166 166 L: TStringList; … … 175 175 end 176 176 {$ENDIF} 177 {$IFDEF LINUX}177 {$IFDEF UNIX} 178 178 // How to play in Linux? Use generic Linux commands 179 179 // Use asyncprocess to play sound as SND_ASYNC … … 232 232 mciSendCommand(FDeviceID, MCI_STOP, 0, 0); 233 233 {$ENDIF} 234 {$IFDEF LINUX}234 {$IFDEF UNIX} 235 235 if SoundPlayerSyncProcess <> nil then SoundPlayerSyncProcess.Terminate(1); 236 236 if SoundPlayerAsyncProcess <> nil then SoundPlayerAsyncProcess.Terminate(1); … … 280 280 begin 281 281 Result := 0; 282 while (Result < SoundList.Count) and (SoundList[ result].FFileName <> FileName) do282 while (Result < SoundList.Count) and (SoundList[Result].FFileName <> FileName) do 283 283 Inc(Result); 284 284 if Result = SoundList.Count then begin … … 333 333 procedure UnitInit; 334 334 begin 335 SoundList := T FPGObjectList<TSound>.Create;335 SoundList := TObjectList<TSound>.Create; 336 336 PlayingSound := nil; 337 337 SoundPlayer := nil; -
branches/highdpi/Packages/CevoComponents/StringTables.pas
r303 r463 16 16 constructor Create; 17 17 destructor Destroy; override; 18 function LoadFromFile(const FileName: String): boolean;19 function GetHandle(const Item: string): integer;20 function LookupByHandle(Handle: integer; Index: integer = -1): string;18 function LoadFromFile(const FileName: String): Boolean; 19 function GetHandle(const Item: string): Integer; 20 function LookupByHandle(Handle: Integer; Index: Integer = -1): string; 21 21 function Lookup(const Item: string; Index: Integer = -1): string; 22 function Search(const Content: string; var Handle, Index: integer): boolean;22 function Search(const Content: string; var Handle, Index: Integer): Boolean; 23 23 end; 24 24 … … 45 45 end; 46 46 47 function TStringTable.LoadFromFile(const FileName: String): boolean;47 function TStringTable.LoadFromFile(const FileName: String): Boolean; 48 48 begin 49 49 Result := True; … … 56 56 end; 57 57 58 function TStringTable.GetHandle(const Item: string): integer;58 function TStringTable.GetHandle(const Item: string): Integer; 59 59 var 60 60 I: Integer; … … 67 67 end; 68 68 69 function TStringTable.LookupByHandle(Handle: integer; Index: integer): string;69 function TStringTable.LookupByHandle(Handle: Integer; Index: Integer): string; 70 70 var 71 s: string;71 S: string; 72 72 begin 73 73 if Index < 0 then begin … … 77 77 end else begin 78 78 if Pos(' ', Lines[Handle]) = 0 then S := '' 79 else s:= Copy(Lines[Handle], Pos(' ', Lines[Handle]) + 1, MaxInt);79 else S := Copy(Lines[Handle], Pos(' ', Lines[Handle]) + 1, MaxInt); 80 80 while ((Handle + 1) < Lines.Count) and (Copy(Lines[Handle + 1], 1, 1) <> '#') do begin 81 81 Inc(Handle); 82 82 if (Length(Lines[Handle]) > 0) and (Lines[Handle][1] <> '''') then begin 83 if ( s <> '') and (s[Length(s)] <> '\') then84 s := s+ ' ';85 s := s+ Lines[Handle];83 if (S <> '') and (S[Length(S)] <> '\') then 84 S := S + ' '; 85 S := S + Lines[Handle]; 86 86 end; 87 87 end; … … 116 116 { might become necessary for 1.3 117 117 118 function TStringTable.Lookup(const Fallback: TStringTable; const Item: string; Index: integer): string;118 function TStringTable.Lookup(const Fallback: TStringTable; const Item: string; Index: Integer): string; 119 119 var 120 Handle: integer;120 Handle: Integer; 121 121 begin 122 122 Handle:=Gethandle(Item); 123 if Handle>=0 then result:=LookupByHandle(Handle, Index)124 else result:='';125 if result='' then126 result:=Fallback.Lookup(Item, Index);123 if Handle>=0 then Result:=LookupByHandle(Handle, Index) 124 else Result:=''; 125 if Result='' then 126 Result:=Fallback.Lookup(Item, Index); 127 127 end; 128 128 129 function TStringTable.TryLookup(const Item: string; Index: integer): string;129 function TStringTable.TryLookup(const Item: string; Index: Integer): string; 130 130 var 131 Handle: integer;131 Handle: Integer; 132 132 begin 133 133 Handle:=Gethandle(Item); 134 if Handle>=0 then result:=LookupByHandle(Handle, Index)135 else result:='';134 if Handle>=0 then Result:=LookupByHandle(Handle, Index) 135 else Result:=''; 136 136 end; } 137 137 138 138 function TStringTable.Search(const Content: string; 139 var Handle, Index: integer): boolean;139 var Handle, Index: Integer): Boolean; 140 140 var 141 h, i: integer;141 H, I: Integer; 142 142 UContent: string; 143 143 begin 144 144 UContent := UpperCase(Content); 145 h:= Handle;146 if h< 0 then147 i:= 0145 H := Handle; 146 if H < 0 then 147 I := 0 148 148 else 149 i:= Index + 1;149 I := Index + 1; 150 150 repeat 151 if h + i+ 1 >= Lines.Count then151 if H + I + 1 >= Lines.Count then 152 152 begin 153 result := false;154 exit;153 Result := False; 154 Exit; 155 155 end; 156 if Copy(Lines[ h + i+ 1], 1, 1) = '#' then156 if Copy(Lines[H + I + 1], 1, 1) = '#' then 157 157 begin 158 h := h + i+ 1;159 i:= -1;158 H := H + I + 1; 159 I := -1; 160 160 end; 161 if ( h >= 0) and not ((Length(Lines[h + i + 1]) > 0) and (Lines[h + i+ 1][1] in ['#', ':', ';'])) and162 (Pos(UContent, UpperCase(Lines[ h + i+ 1])) > 0) then161 if (H >= 0) and not ((Length(Lines[H + I + 1]) > 0) and (Lines[H + I + 1][1] in ['#', ':', ';'])) and 162 (Pos(UContent, UpperCase(Lines[H + I + 1])) > 0) then 163 163 begin 164 Index := i;165 Handle := h;164 Index := I; 165 Handle := H; 166 166 Result := True; 167 167 Exit; -
branches/highdpi/Packages/CevoComponents/Texture.pas
r462 r463 1 unit UTexture; 2 3 {$mode objfpc}{$H+} 1 unit Texture; 4 2 5 3 interface … … 97 95 end. 98 96 97 98 -
branches/highdpi/Packages/Common/AboutDialog.pas
r462 r463 1 unit UAboutDialog; 2 3 {$mode delphi} 1 unit AboutDialog; 4 2 5 3 interface … … 7 5 uses 8 6 Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, Menus, 9 StdCtrls, ExtCtrls, UApplicationInfo, UCommon, UTranslator, UTheme, UFormAbout;7 ExtCtrls, ApplicationInfo, Common, Translator, Theme, FormAbout; 10 8 11 9 type … … 16 14 private 17 15 FApplicationInfo: TApplicationInfo; 18 F CoolTranslator: TTranslator;16 FTranslator: TTranslator; 19 17 FThemeManager: TThemeManager; 20 18 public … … 22 20 procedure Show; 23 21 published 24 property CoolTranslator: TTranslator read FCoolTranslator write FCoolTranslator;22 property Translator: TTranslator read FTranslator write FTranslator; 25 23 property ThemeManager: TThemeManager read FThemeManager write FThemeManager; 26 24 property ApplicationInfo: TApplicationInfo read FApplicationInfo write … … 52 50 53 51 end. 54 -
branches/highdpi/Packages/Common/ApplicationInfo.pas
r462 r463 1 unit UApplicationInfo; 2 3 {$mode delphi} 1 unit ApplicationInfo; 4 2 5 3 interface 6 4 7 5 uses 8 UDpiControls, SysUtils, Classes, Forms, URegistry, Controls, Graphics, LCLType;6 UDpiControls, SysUtils, Classes, Forms, RegistryEx, Controls, Graphics, LCLType; 9 7 10 8 type … … 59 57 procedure Register; 60 58 59 61 60 implementation 62 61 -
branches/highdpi/Packages/Common/Common.Delay.pas
r462 r463 1 unit UDelay; 2 3 {$mode delphi} 1 unit Common.Delay; 4 2 5 3 interface … … 73 71 74 72 end. 75 -
branches/highdpi/Packages/Common/Common.lpk
r405 r463 1 1 <?xml version="1.0" encoding="UTF-8"?> 2 2 <CONFIG> 3 <Package Version=" 4">3 <Package Version="5"> 4 4 <PathDelim Value="\"/> 5 5 <Name Value="Common"/> … … 33 33 <Other> 34 34 <CompilerMessages> 35 <IgnoredMessages idx 5024="True"/>35 <IgnoredMessages idx6058="True" idx5071="True" idx5024="True" idx3124="True" idx3123="True"/> 36 36 </CompilerMessages> 37 37 </Other> … … 41 41 Source: https://svn.zdechov.net/PascalClassLibrary/Common/"/> 42 42 <License Value="Copy left."/> 43 <Version Minor=" 8"/>44 <Files Count=" 27">43 <Version Minor="11"/> 44 <Files Count="33"> 45 45 <Item1> 46 46 <Filename Value="StopWatch.pas"/> … … 48 48 </Item1> 49 49 <Item2> 50 <Filename Value=" UCommon.pas"/>51 <UnitName Value=" UCommon"/>50 <Filename Value="Common.pas"/> 51 <UnitName Value="Common"/> 52 52 </Item2> 53 53 <Item3> 54 <Filename Value=" UDebugLog.pas"/>55 <HasRegisterProc Value="True"/> 56 <UnitName Value=" UDebugLog"/>54 <Filename Value="DebugLog.pas"/> 55 <HasRegisterProc Value="True"/> 56 <UnitName Value="DebugLog"/> 57 57 </Item3> 58 58 <Item4> 59 <Filename Value=" UDelay.pas"/>60 <UnitName Value=" UDelay"/>59 <Filename Value="Common.Delay.pas"/> 60 <UnitName Value="Common.Delay"/> 61 61 </Item4> 62 62 <Item5> 63 <Filename Value=" UPrefixMultiplier.pas"/>64 <HasRegisterProc Value="True"/> 65 <UnitName Value=" UPrefixMultiplier"/>63 <Filename Value="PrefixMultiplier.pas"/> 64 <HasRegisterProc Value="True"/> 65 <UnitName Value="PrefixMultiplier"/> 66 66 </Item5> 67 67 <Item6> 68 <Filename Value="U URI.pas"/>69 <UnitName Value="U URI"/>68 <Filename Value="URI.pas"/> 69 <UnitName Value="URI"/> 70 70 </Item6> 71 71 <Item7> 72 <Filename Value=" UThreading.pas"/>73 <UnitName Value=" UThreading"/>72 <Filename Value="Threading.pas"/> 73 <UnitName Value="Threading"/> 74 74 </Item7> 75 75 <Item8> 76 <Filename Value=" UMemory.pas"/>77 <UnitName Value=" UMemory"/>76 <Filename Value="Memory.pas"/> 77 <UnitName Value="Memory"/> 78 78 </Item8> 79 79 <Item9> 80 <Filename Value=" UResetableThread.pas"/>81 <UnitName Value=" UResetableThread"/>80 <Filename Value="ResetableThread.pas"/> 81 <UnitName Value="ResetableThread"/> 82 82 </Item9> 83 83 <Item10> 84 <Filename Value=" UPool.pas"/>85 <UnitName Value=" UPool"/>84 <Filename Value="Pool.pas"/> 85 <UnitName Value="Pool"/> 86 86 </Item10> 87 87 <Item11> 88 <Filename Value=" ULastOpenedList.pas"/>89 <HasRegisterProc Value="True"/> 90 <UnitName Value=" ULastOpenedList"/>88 <Filename Value="LastOpenedList.pas"/> 89 <HasRegisterProc Value="True"/> 90 <UnitName Value="LastOpenedList"/> 91 91 </Item11> 92 92 <Item12> 93 <Filename Value=" URegistry.pas"/>94 <UnitName Value=" URegistry"/>93 <Filename Value="RegistryEx.pas"/> 94 <UnitName Value="RegistryEx"/> 95 95 </Item12> 96 96 <Item13> 97 <Filename Value=" UJobProgressView.pas"/>98 <HasRegisterProc Value="True"/> 99 <UnitName Value=" UJobProgressView"/>97 <Filename Value="JobProgressView.pas"/> 98 <HasRegisterProc Value="True"/> 99 <UnitName Value="JobProgressView"/> 100 100 </Item13> 101 101 <Item14> 102 <Filename Value=" UXMLUtils.pas"/>103 <UnitName Value=" UXMLUtils"/>102 <Filename Value="XML.pas"/> 103 <UnitName Value="XML"/> 104 104 </Item14> 105 105 <Item15> 106 <Filename Value=" UApplicationInfo.pas"/>107 <HasRegisterProc Value="True"/> 108 <UnitName Value=" UApplicationInfo"/>106 <Filename Value="ApplicationInfo.pas"/> 107 <HasRegisterProc Value="True"/> 108 <UnitName Value="ApplicationInfo"/> 109 109 </Item15> 110 110 <Item16> 111 <Filename Value=" USyncCounter.pas"/>112 <UnitName Value=" USyncCounter"/>111 <Filename Value="SyncCounter.pas"/> 112 <UnitName Value="SyncCounter"/> 113 113 </Item16> 114 114 <Item17> 115 <Filename Value=" UPersistentForm.pas"/>116 <HasRegisterProc Value="True"/> 117 <UnitName Value=" UPersistentForm"/>115 <Filename Value="ListViewSort.pas"/> 116 <HasRegisterProc Value="True"/> 117 <UnitName Value="ListViewSort"/> 118 118 </Item17> 119 119 <Item18> 120 <Filename Value=" UFindFile.pas"/>121 <HasRegisterProc Value="True"/> 122 <UnitName Value=" UFindFile"/>120 <Filename Value="PersistentForm.pas"/> 121 <HasRegisterProc Value="True"/> 122 <UnitName Value="PersistentForm"/> 123 123 </Item18> 124 124 <Item19> 125 <Filename Value=" UScaleDPI.pas"/>126 <HasRegisterProc Value="True"/> 127 <UnitName Value=" UScaleDPI"/>125 <Filename Value="FindFile.pas"/> 126 <HasRegisterProc Value="True"/> 127 <UnitName Value="FindFile"/> 128 128 </Item19> 129 129 <Item20> 130 <Filename Value=" UTheme.pas"/>131 <HasRegisterProc Value="True"/> 132 <UnitName Value=" UTheme"/>130 <Filename Value="ScaleDPI.pas"/> 131 <HasRegisterProc Value="True"/> 132 <UnitName Value="ScaleDPI"/> 133 133 </Item20> 134 134 <Item21> 135 <Filename Value="UStringTable.pas"/> 136 <UnitName Value="UStringTable"/> 135 <Filename Value="Theme.pas"/> 136 <HasRegisterProc Value="True"/> 137 <UnitName Value="Theme"/> 137 138 </Item21> 138 139 <Item22> 139 <Filename Value=" UGeometric.pas"/>140 <UnitName Value=" UGeometric"/>140 <Filename Value="StringTable.pas"/> 141 <UnitName Value="StringTable"/> 141 142 </Item22> 142 143 <Item23> 143 <Filename Value="UTranslator.pas"/> 144 <HasRegisterProc Value="True"/> 145 <UnitName Value="UTranslator"/> 144 <Filename Value="MetaCanvas.pas"/> 145 <UnitName Value="MetaCanvas"/> 146 146 </Item23> 147 147 <Item24> 148 <Filename Value=" ULanguages.pas"/>149 <UnitName Value=" ULanguages"/>148 <Filename Value="Geometric.pas"/> 149 <UnitName Value="Geometric"/> 150 150 </Item24> 151 151 <Item25> 152 <Filename Value="UFormAbout.pas"/> 153 <UnitName Value="UFormAbout"/> 152 <Filename Value="Translator.pas"/> 153 <HasRegisterProc Value="True"/> 154 <UnitName Value="Translator"/> 154 155 </Item25> 155 156 <Item26> 156 <Filename Value="UAboutDialog.pas"/> 157 <HasRegisterProc Value="True"/> 158 <UnitName Value="UAboutDialog"/> 157 <Filename Value="Languages.pas"/> 158 <UnitName Value="Languages"/> 159 159 </Item26> 160 160 <Item27> 161 <Filename Value=" UPixelPointer.pas"/>162 <UnitName Value=" UPixelPointer"/>161 <Filename Value="FormAbout.pas"/> 162 <UnitName Value="FormAbout"/> 163 163 </Item27> 164 <Item28> 165 <Filename Value="AboutDialog.pas"/> 166 <HasRegisterProc Value="True"/> 167 <UnitName Value="AboutDialog"/> 168 </Item28> 169 <Item29> 170 <Filename Value="PixelPointer.pas"/> 171 <UnitName Value="PixelPointer"/> 172 </Item29> 173 <Item30> 174 <Filename Value="DataFile.pas"/> 175 <UnitName Value="DataFile"/> 176 </Item30> 177 <Item31> 178 <Filename Value="TestCase.pas"/> 179 <UnitName Value="TestCase"/> 180 </Item31> 181 <Item32> 182 <Filename Value="Generics.pas"/> 183 <UnitName Value="Generics"/> 184 </Item32> 185 <Item33> 186 <Filename Value="CommonPackage.pas"/> 187 <Type Value="Main Unit"/> 188 <UnitName Value="CommonPackage"/> 189 </Item33> 164 190 </Files> 191 <CompatibilityMode Value="True"/> 165 192 <i18n> 166 193 <EnableI18N Value="True"/> -
branches/highdpi/Packages/Common/Common.pas
r462 r463 1 unit UCommon; 2 3 {$mode delphi} 1 unit Common; 4 2 5 3 interface 6 4 7 5 uses 8 {$ ifdef Windows}Windows,{$endif}9 {$ ifdef Linux}baseunix,{$endif}10 Classes, SysUtils, StrUtils, Dialogs, Process, LCLIntf, 11 FileUtil ; //, ShFolder, ShellAPI;6 {$IFDEF WINDOWS}Windows,{$ENDIF} 7 {$IFDEF UNIX}baseunix,{$ENDIF} 8 Classes, SysUtils, StrUtils, Dialogs, Process, LCLIntf, Graphics, 9 FileUtil, Generics.Collections; //, ShFolder, ShellAPI; 12 10 13 11 type 14 12 TArrayOfByte = array of Byte; 15 TArrayOfString = array of string;16 13 TExceptionEvent = procedure(Sender: TObject; E: Exception) of object; 17 14 … … 35 32 DLLHandle1: HModule; 36 33 37 {$IFDEF Windows} 38 GetUserNameEx: procedure (NameFormat: DWORD; 39 lpNameBuffer: LPSTR; nSize: PULONG); stdcall; 40 {$ENDIF} 41 42 function IntToBin(Data: Int64; Count: Byte): string; 34 {$IFDEF WINDOWS} 35 GetUserNameEx: procedure (NameFormat: DWORD; 36 lpNameBuffer: LPSTR; nSize: PULONG); stdcall; 37 {$ENDIF} 38 39 const 40 clLightBlue = TColor($FF8080); 41 clLightGreen = TColor($80FF80); 42 clLightRed = TColor($8080FF); 43 44 function AddLeadingZeroes(const aNumber, Length : integer) : string; 43 45 function BinToInt(BinStr: string): Int64; 44 function TryHexToInt(Data: string; var Value: Integer): Boolean;45 function TryBinToInt(Data: string; var Value: Integer): Boolean;46 46 function BinToHexString(Source: AnsiString): string; 47 47 //function DelTree(DirName : string): Boolean; … … 49 49 function BCDToInt(Value: Byte): Byte; 50 50 function CompareByteArray(Data1, Data2: TArrayOfByte): Boolean; 51 procedure CopyStringArray(Dest: TStringArray; Source: array of string); 52 function CombinePaths(Path1, Path2: string): string; 53 function ComputerName: string; 54 procedure DeleteFiles(APath, AFileSpec: string); 55 function Explode(Separator: Char; Data: string): TStringArray; 56 procedure ExecuteProgram(Executable: string; Parameters: array of string); 57 procedure FileDialogUpdateFilterFileType(FileDialog: TOpenDialog); 58 procedure FreeThenNil(var Obj); 59 function GetDirCount(Dir: string): Integer; 51 60 function GetUserName: string; 52 function LoggedOnUserNameEx(Format: TUserNameFormat): string;53 function SplitString(var Text: string; Count: Word): string;54 61 function GetBitCount(Variable: QWord; MaxIndex: Integer): Integer; 55 62 function GetBit(Variable: QWord; Index: Byte): Boolean; 63 function GetStringPart(var Text: string; Separator: string): string; 64 function GenerateNewName(OldName: string): string; 65 function GetFileFilterItemExt(Filter: string; Index: Integer): string; 66 function IntToBin(Data: Int64; Count: Byte): string; 67 function Implode(Separator: Char; List: TList<string>): string; 68 function LastPos(const SubStr: String; const S: String): Integer; 69 function LoadFileToStr(const FileName: TFileName): AnsiString; 70 function LoggedOnUserNameEx(Format: TUserNameFormat): string; 71 function MergeArray(A, B: array of string): TStringArray; 72 function OccurenceOfChar(What: Char; Where: string): Integer; 73 procedure OpenWebPage(URL: string); 74 procedure OpenEmail(Email: string); 75 procedure OpenFileInShell(FileName: string); 76 function PosFromIndex(SubStr: string; Text: string; 77 StartIndex: Integer): Integer; 78 function PosFromIndexReverse(SubStr: string; Text: string; 79 StartIndex: Integer): Integer; 80 function RemoveQuotes(Text: string): string; 81 procedure SaveStringToFile(S, FileName: string); 56 82 procedure SetBit(var Variable: Int64; Index: Byte; State: Boolean); overload; 57 83 procedure SetBit(var Variable: QWord; Index: Byte; State: Boolean); overload; 58 84 procedure SetBit(var Variable: Cardinal; Index: Byte; State: Boolean); overload; 59 85 procedure SetBit(var Variable: Word; Index: Byte; State: Boolean); overload; 60 function AddLeadingZeroes(const aNumber, Length : integer) : string;61 function LastPos(const SubStr: String; const S: String): Integer;62 function GenerateNewName(OldName: string): string;63 function GetFileFilterItemExt(Filter: string; Index: Integer): string;64 procedure FileDialogUpdateFilterFileType(FileDialog: TOpenDialog);65 procedure DeleteFiles(APath, AFileSpec: string);66 procedure OpenWebPage(URL: string);67 procedure OpenFileInShell(FileName: string);68 procedure ExecuteProgram(Executable: string; Parameters: array of string);69 procedure FreeThenNil(var Obj);70 function RemoveQuotes(Text: string): string;71 function ComputerName: string;72 function OccurenceOfChar(What: Char; Where: string): Integer;73 function GetDirCount(Dir: string): Integer;74 function MergeArray(A, B: array of string): TArrayOfString;75 function LoadFileToStr(const FileName: TFileName): AnsiString;76 procedure SaveStringToFile(S, FileName: string);77 86 procedure SearchFiles(AList: TStrings; Dir: string; 78 87 FilterMethod: TFilterMethod = nil; FileNameMethod: TFileNameMethod = nil); 79 function GetStringPart(var Text: string; Separator: string): string;88 function SplitString(var Text: string; Count: Word): string; 80 89 function StripTags(const S: string): string; 81 function PosFromIndex(SubStr: string; Text: string; 82 StartIndex: Integer): Integer; 83 function PosFromIndexReverse(SubStr: string; Text: string; 84 StartIndex: Integer): Integer; 85 procedure CopyStringArray(Dest: TStringArray; Source: array of string); 90 function TryHexToInt(Data: string; out Value: Integer): Boolean; 91 function TryBinToInt(Data: string; out Value: Integer): Boolean; 92 procedure SortStrings(Strings: TStrings); 86 93 87 94 … … 244 251 end; 245 252 246 function TryHexToInt(Data: string; varValue: Integer): Boolean;253 function TryHexToInt(Data: string; out Value: Integer): Boolean; 247 254 var 248 255 I: Integer; … … 260 267 end; 261 268 262 function TryBinToInt(Data: string; varValue: Integer): Boolean;269 function TryBinToInt(Data: string; out Value: Integer): Boolean; 263 270 var 264 271 I: Integer; … … 288 295 end; 289 296 290 function Explode(Separator: char; Data: string): TArrayOfString; 291 begin 292 SetLength(Result, 0); 293 while Pos(Separator, Data) > 0 do begin 297 function Explode(Separator: Char; Data: string): TStringArray; 298 var 299 Index: Integer; 300 begin 301 Result := Default(TStringArray); 302 repeat 303 Index := Pos(Separator, Data); 304 if Index > 0 then begin 305 SetLength(Result, Length(Result) + 1); 306 Result[High(Result)] := Copy(Data, 1, Index - 1); 307 Delete(Data, 1, Index); 308 end else Break; 309 until False; 310 if Data <> '' then begin 294 311 SetLength(Result, Length(Result) + 1); 295 Result[High(Result)] := Copy(Data, 1, Pos(Separator, Data) - 1); 296 Delete(Data, 1, Pos(Separator, Data)); 297 end; 298 SetLength(Result, Length(Result) + 1); 299 Result[High(Result)] := Data; 300 end; 301 302 {$IFDEF Windows} 312 Result[High(Result)] := Data; 313 end; 314 end; 315 316 function Implode(Separator: Char; List: TList<string>): string; 317 var 318 I: Integer; 319 begin 320 Result := ''; 321 for I := 0 to List.Count - 1 do begin 322 Result := Result + List[I]; 323 if I < List.Count - 1 then Result := Result + Separator; 324 end; 325 end; 326 327 {$IFDEF WINDOWS} 303 328 function GetUserName: string; 304 329 const … … 308 333 begin 309 334 L := MAX_USERNAME_LENGTH + 2; 335 Result := Default(string); 310 336 SetLength(Result, L); 311 337 if Windows.GetUserName(PChar(Result), L) and (L > 0) then begin … … 321 347 end; 322 348 end; 323 {$ endif}349 {$ENDIF} 324 350 325 351 function ComputerName: string; 326 {$ ifdef mswindows}352 {$IFDEF WINDOWS} 327 353 const 328 354 INFO_BUFFER_SIZE = 32767; … … 339 365 end; 340 366 end; 341 {$ endif}342 {$ ifdef unix}367 {$ENDIF} 368 {$IFDEF UNIX} 343 369 var 344 370 Name: UtsName; 345 371 begin 372 Name := Default(UtsName); 346 373 fpuname(Name); 347 374 Result := Name.Nodename; 348 375 end; 349 {$ endif}350 351 {$ ifdef windows}376 {$ENDIF} 377 378 {$IFDEF WINDOWS} 352 379 function LoggedOnUserNameEx(Format: TUserNameFormat): string; 353 380 const … … 427 454 procedure LoadLibraries; 428 455 begin 429 {$IFDEF W indows}456 {$IFDEF WINDOWS} 430 457 DLLHandle1 := LoadLibrary('secur32.dll'); 431 458 if DLLHandle1 <> 0 then … … 438 465 procedure FreeLibraries; 439 466 begin 440 {$IFDEF W indows}467 {$IFDEF WINDOWS} 441 468 if DLLHandle1 <> 0 then FreeLibrary(DLLHandle1); 442 469 {$ENDIF} … … 471 498 end; 472 499 500 procedure OpenEmail(Email: string); 501 begin 502 OpenURL('mailto:' + Email); 503 end; 504 473 505 procedure OpenFileInShell(FileName: string); 474 506 begin … … 499 531 end; 500 532 501 function MergeArray(A, B: array of string): TArrayOfString; 502 var 503 I: Integer; 504 begin 533 function MergeArray(A, B: array of string): TStringArray; 534 var 535 I: Integer; 536 begin 537 Result := Default(TStringArray); 505 538 SetLength(Result, Length(A) + Length(B)); 506 539 for I := 0 to Length(A) - 1 do … … 669 702 end; 670 703 704 function CombinePaths(Path1, Path2: string): string; 705 begin 706 Result := Path1; 707 if Result <> '' then Result := Result + DirectorySeparator + Path2 708 else Result := Path2; 709 end; 710 711 procedure SortStrings(Strings: TStrings); 712 var 713 Tmp: TStringList; 714 begin 715 Strings.BeginUpdate; 716 try 717 if Strings is TStringList then begin 718 TStringList(Strings).Sort; 719 end else begin 720 Tmp := TStringList.Create; 721 try 722 Tmp.Assign(Strings); 723 Tmp.Sort; 724 Strings.Assign(Tmp); 725 finally 726 Tmp.Free; 727 end; 728 end; 729 finally 730 Strings.EndUpdate; 731 end; 732 end; 733 671 734 672 735 initialization … … 680 743 681 744 end. 745 -
branches/highdpi/Packages/Common/CommonPackage.pas
r462 r463 3 3 } 4 4 5 unit Common ;5 unit CommonPackage; 6 6 7 7 {$warn 5023 off : no warning about unused units} … … 9 9 10 10 uses 11 StopWatch, UCommon, UDebugLog, UDelay, UPrefixMultiplier, UURI, UThreading,12 UMemory, UResetableThread, UPool, ULastOpenedList, URegistry,13 UJobProgressView, UXMLUtils, UApplicationInfo, USyncCounter,14 UPersistentForm, UFindFile, UScaleDPI, UTheme, UStringTable, UGeometric,15 UTranslator, ULanguages, UFormAbout, UAboutDialog, UPixelPointer,11 StopWatch, Common, DebugLog, Common.Delay, PrefixMultiplier, URI, Threading, 12 Memory, ResetableThread, Pool, LastOpenedList, RegistryEx, JobProgressView, 13 XML, ApplicationInfo, SyncCounter, ListViewSort, PersistentForm, FindFile, 14 ScaleDPI, Theme, StringTable, MetaCanvas, Geometric, Translator, Languages, 15 FormAbout, AboutDialog, PixelPointer, DataFile, TestCase, Generics, 16 16 LazarusPackageIntf; 17 17 … … 20 20 procedure Register; 21 21 begin 22 RegisterUnit('UDebugLog', @UDebugLog.Register); 23 RegisterUnit('UPrefixMultiplier', @UPrefixMultiplier.Register); 24 RegisterUnit('ULastOpenedList', @ULastOpenedList.Register); 25 RegisterUnit('UJobProgressView', @UJobProgressView.Register); 26 RegisterUnit('UApplicationInfo', @UApplicationInfo.Register); 27 RegisterUnit('UPersistentForm', @UPersistentForm.Register); 28 RegisterUnit('UFindFile', @UFindFile.Register); 29 RegisterUnit('UScaleDPI', @UScaleDPI.Register); 30 RegisterUnit('UTheme', @UTheme.Register); 31 RegisterUnit('UTranslator', @UTranslator.Register); 32 RegisterUnit('UAboutDialog', @UAboutDialog.Register); 22 RegisterUnit('DebugLog', @DebugLog.Register); 23 RegisterUnit('PrefixMultiplier', @PrefixMultiplier.Register); 24 RegisterUnit('LastOpenedList', @LastOpenedList.Register); 25 RegisterUnit('JobProgressView', @JobProgressView.Register); 26 RegisterUnit('ApplicationInfo', @ApplicationInfo.Register); 27 RegisterUnit('ListViewSort', @ListViewSort.Register); 28 RegisterUnit('PersistentForm', @PersistentForm.Register); 29 RegisterUnit('FindFile', @FindFile.Register); 30 RegisterUnit('ScaleDPI', @ScaleDPI.Register); 31 RegisterUnit('Theme', @Theme.Register); 32 RegisterUnit('Translator', @Translator.Register); 33 RegisterUnit('AboutDialog', @AboutDialog.Register); 33 34 end; 34 35 -
branches/highdpi/Packages/Common/DebugLog.pas
r462 r463 1 unit UDebugLog; 2 3 {$mode delphi} 1 unit DebugLog; 4 2 5 3 interface 6 4 7 5 uses 8 Classes, SysUtils, FileUtil, fgl, SyncObjs;6 Classes, SysUtils, FileUtil, Generics.Collections, SyncObjs; 9 7 10 8 type … … 15 13 Group: string; 16 14 Text: string; 15 end; 16 17 TDebugLogItems = class(TObjectList<TDebugLogItem>) 17 18 end; 18 19 … … 29 30 procedure SetMaxCount(const AValue: Integer); 30 31 public 31 Items: T FPGObjectList<TDebugLogItem>;32 Items: TDebugLogItems; 32 33 Lock: TCriticalSection; 33 34 procedure Add(Text: string; Group: string = ''); … … 44 45 45 46 procedure Register; 47 46 48 47 49 implementation … … 117 119 begin 118 120 inherited; 119 Items := T FPGObjectList<TDebugLogItem>.Create;121 Items := TDebugLogItems.Create; 120 122 Lock := TCriticalSection.Create; 121 123 MaxCount := 100; … … 126 128 destructor TDebugLog.Destroy; 127 129 begin 128 Items.Free;129 Lock.Free;130 FreeAndNil(Items); 131 FreeAndNil(Lock); 130 132 inherited; 131 133 end; 132 134 133 135 end. 134 -
branches/highdpi/Packages/Common/FindFile.pas
r462 r463 19 19 } 20 20 21 unit UFindFile;21 unit FindFile; 22 22 23 23 interface … … 35 35 private 36 36 s : TStringList; 37 38 37 fSubFolder : boolean; 39 38 fAttr: TFileAttrib; 40 39 fPath : string; 41 40 fFileMask : string; 42 43 41 procedure SetPath(Value: string); 44 42 procedure FileSearch(const inPath : string); … … 46 44 constructor Create(AOwner: TComponent); override; 47 45 destructor Destroy; override; 48 49 46 function SearchForFiles: TStringList; 50 47 published … … 59 56 FilterAll = '*.*'; 60 57 {$ENDIF} 61 {$IFDEF LINUX}58 {$IFDEF UNIX} 62 59 FilterAll = '*'; 63 60 {$ENDIF} 64 61 65 62 procedure Register; 63 66 64 67 65 implementation … … 87 85 begin 88 86 s.Free; 89 inherited Destroy;87 inherited; 90 88 end; 91 89 … … 145 143 SysUtils.FindClose(Rec); 146 144 end; 147 end; 145 end; 148 146 149 147 end. 150 -
branches/highdpi/Packages/Common/FormAbout.lfm
r462 r463 1 1 object FormAbout: TDpiFormAbout 2 2 Left = 1014 3 Height = 4023 Height = 349 4 4 Top = 577 5 Width = 7025 Width = 609 6 6 Caption = 'About' 7 ClientHeight = 402 8 ClientWidth = 702 9 DesignTimePPI = 144 10 OnCreate = FormCreate 7 ClientHeight = 349 8 ClientWidth = 609 9 DesignTimePPI = 125 11 10 OnShow = FormShow 12 11 Position = poScreenCenter 13 LCLVersion = '2. 0.10.0'12 LCLVersion = '2.2.4.0' 14 13 object LabelDescription: TLabel 15 Left = 3016 Height = 2 417 Top = 1 3518 Width = 64214 Left = 26 15 Height = 22 16 Top = 117 17 Width = 557 19 18 Align = alTop 20 BorderSpacing.Left = 3021 BorderSpacing.Right = 3022 BorderSpacing.Bottom = 3019 BorderSpacing.Left = 26 20 BorderSpacing.Right = 26 21 BorderSpacing.Bottom = 26 23 22 Caption = 'Description' 24 23 ParentColor = False … … 27 26 end 28 27 object LabelContent: TLabel 29 Left = 3030 Height = 2 431 Top = 1 8932 Width = 64228 Left = 26 29 Height = 22 30 Top = 165 31 Width = 557 33 32 Align = alTop 34 BorderSpacing.Around = 3033 BorderSpacing.Around = 26 35 34 Caption = ' ' 36 35 ParentColor = False … … 39 38 object PanelTop: TDpiPanel 40 39 Left = 0 41 Height = 1 3540 Height = 117 42 41 Top = 0 43 Width = 70242 Width = 609 44 43 Align = alTop 45 44 BevelOuter = bvNone 46 ClientHeight = 1 3547 ClientWidth = 70245 ClientHeight = 117 46 ClientWidth = 609 48 47 FullRepaint = False 49 48 ParentFont = False 50 49 TabOrder = 0 51 50 object LabelAppName: TLabel 52 Left = 10853 Height = 8454 Top = 2055 Width = 56451 Left = 94 52 Height = 73 53 Top = 17 54 Width = 489 56 55 Anchors = [akTop, akLeft, akRight] 57 56 AutoSize = False 58 BorderSpacing.Around = 3057 BorderSpacing.Around = 26 59 58 Caption = 'Title' 60 Font.Height = - 6059 Font.Height = -52 61 60 ParentColor = False 62 61 ParentFont = False … … 64 63 end 65 64 object ImageLogo: TImage 66 Left = 2 467 Height = 7468 Top = 3069 Width = 7265 Left = 21 66 Height = 64 67 Top = 26 68 Width = 62 70 69 Proportional = True 71 70 Stretch = True … … 74 73 object PanelButtons: TDpiPanel 75 74 Left = 0 76 Height = 7577 Top = 32778 Width = 70275 Height = 65 76 Top = 284 77 Width = 609 79 78 Align = alBottom 80 79 BevelOuter = bvNone 81 ClientHeight = 7582 ClientWidth = 70280 ClientHeight = 65 81 ClientWidth = 609 83 82 TabOrder = 1 84 83 object ButtonHomePage: TButton 85 Left = 2 486 Height = 3 887 Top = 2 488 Width = 2 6484 Left = 21 85 Height = 33 86 Top = 21 87 Width = 229 89 88 Anchors = [akLeft, akBottom] 90 89 Caption = 'Home page' … … 94 93 end 95 94 object ButtonClose: TButton 96 Left = 53297 Height = 3 898 Top = 2 499 Width = 1 4095 Left = 461 96 Height = 33 97 Top = 21 98 Width = 122 100 99 Anchors = [akRight, akBottom] 101 100 Caption = 'Close' -
branches/highdpi/Packages/Common/FormAbout.pas
r462 r463 1 unit UFormAbout; 2 3 {$mode delphi} 1 unit FormAbout; 4 2 5 3 interface … … 7 5 uses 8 6 UDpiControls, Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, Menus, 9 StdCtrls, ExtCtrls, UApplicationInfo, UCommon, UTranslator, UTheme;7 StdCtrls, ExtCtrls, ApplicationInfo, Common, Translator, Theme; 10 8 11 9 type … … 22 20 PanelButtons: TDpiPanel; 23 21 procedure ButtonHomePageClick(Sender: TObject); 24 procedure FormCreate(Sender: TObject);25 22 procedure FormShow(Sender: TObject); 26 private27 { private declarations }28 23 public 29 24 AboutDialog: TObject; //TAboutDialog … … 37 32 38 33 uses 39 UAboutDialog;34 AboutDialog; 40 35 41 36 resourcestring … … 50 45 if Assigned(AboutDialog) then 51 46 with TAboutDialog(AboutDialog) do begin 52 if Assigned( CoolTranslator) then53 CoolTranslator.TranslateComponentRecursive(Self);47 if Assigned(Translator) then 48 Translator.TranslateComponentRecursive(Self); 54 49 if Assigned(ThemeManager) then 55 50 ThemeManager.UseTheme(Self); … … 79 74 end; 80 75 81 procedure TFormAbout.FormCreate(Sender: TObject);82 begin83 end;84 85 76 end. 86 -
branches/highdpi/Packages/Common/Geometric.pas
r462 r463 1 unit UGeometric; 2 3 {$mode delphi} 1 unit Geometric; 4 2 5 3 interface … … 10 8 type 11 9 TPointArray = array of TPoint; 10 11 { TVector } 12 13 TVector = record 14 Position: TPoint; 15 Direction: TPoint; 16 function GetLength: Double; 17 function GetAngle: Double; 18 procedure SetLength(Value: Double); 19 class function Create(P1, P2: TPoint): TVector; static; 20 end; 12 21 13 22 function Distance(P1, P2: TPoint): Integer; … … 15 24 function AddPoint(const P1, P2: TPoint): TPoint; 16 25 function SubPoint(const P1, P2: TPoint): TPoint; 17 function PointToLineDistance(const P, V, W: TPoint ): Integer;26 function PointToLineDistance(const P, V, W: TPoint; out Intersect: TPoint): Integer; 18 27 function ComparePoint(P1, P2: TPoint): Boolean; 19 28 function RotatePoint(Center, P: TPoint; Angle: Double): TPoint; … … 27 36 function ShiftRect(ARect: TRect; Delta: TPoint): TRect; 28 37 38 29 39 implementation 30 40 … … 51 61 end; 52 62 53 function PointToLineDistance(const P, V, W: TPoint ): Integer;63 function PointToLineDistance(const P, V, W: TPoint; out Intersect: TPoint): Integer; 54 64 var 55 65 l2, t: Double; … … 69 79 if T < 0 then begin 70 80 Result := Distance(P, V); // Beyond the 'v' end of the segment 71 exit; 81 Intersect := V; 82 Exit; 72 83 end 73 84 else if T > 1 then begin 74 85 Result := Distance(P, W); // Beyond the 'w' end of the segment 86 Intersect := W; 75 87 Exit; 76 88 end; … … 78 90 TT.Y := Trunc(V.Y + T * (W.Y - V.Y)); 79 91 Result := Distance(P, TT); 92 Intersect := TT; 80 93 end; 81 94 … … 96 109 I: Integer; 97 110 begin 111 Result := Default(TPointArray); 98 112 SetLength(Result, Length(P)); 99 113 for I := 0 to High(P) do … … 162 176 end; 163 177 178 { TVector } 179 180 function TVector.GetLength: Double; 181 begin 182 Result := Sqrt(Sqr(Direction.X) + Sqr(Direction.Y)); 183 end; 184 185 function TVector.GetAngle: Double; 186 begin 187 Result := ArcTan2(Direction.Y, Direction.X); 188 end; 189 190 procedure TVector.SetLength(Value: Double); 191 var 192 Angle: Double; 193 begin 194 Angle := GetAngle; 195 Direction := Point(Round(Cos(Angle) * Value), 196 Round(Sin(Angle) * Value)); 197 end; 198 199 class function TVector.Create(P1, P2: TPoint): TVector; 200 begin 201 Result.Position := P1; 202 Result.Direction := Point(P2.X - P1.X, P2.Y - P1.Y); 203 end; 164 204 165 205 end. -
branches/highdpi/Packages/Common/JobProgressView.lfm
r462 r463 1 1 object FormJobProgressView: TDpiFormJobProgressView 2 2 Left = 467 3 Height = 3453 Height = 414 4 4 Top = 252 5 Width = 5395 Width = 647 6 6 BorderIcons = [biSystemMenu] 7 ClientHeight = 3458 ClientWidth = 5399 DesignTimePPI = 1 207 ClientHeight = 414 8 ClientWidth = 647 9 DesignTimePPI = 144 10 10 OnClose = FormClose 11 11 OnCloseQuery = FormCloseQuery 12 12 OnCreate = FormCreate 13 OnDestroy = FormDestroy14 13 OnHide = FormHide 15 14 OnShow = FormShow 16 15 Position = poScreenCenter 17 LCLVersion = '2. 0.2.0'16 LCLVersion = '2.2.0.4' 18 17 object PanelOperationsTitle: TDpiPanel 19 18 Left = 0 20 Height = 3 219 Height = 38 21 20 Top = 0 22 Width = 53921 Width = 647 23 22 Align = alTop 24 23 BevelOuter = bvNone 25 ClientHeight = 3 226 ClientWidth = 53924 ClientHeight = 38 25 ClientWidth = 647 27 26 FullRepaint = False 28 27 TabOrder = 0 29 28 object LabelOperation: TLabel 30 Left = 831 Height = 2 032 Top = 833 Width = 7629 Left = 10 30 Height = 26 31 Top = 10 32 Width = 99 34 33 Caption = 'Operations:' 35 ParentColor = False36 34 ParentFont = False 37 35 end … … 39 37 object PanelLog: TDpiPanel 40 38 Left = 0 41 Height = 1 3342 Top = 2 1243 Width = 53939 Height = 161 40 Top = 253 41 Width = 647 44 42 Align = alClient 45 43 BevelOuter = bvSpace 46 ClientHeight = 1 3347 ClientWidth = 53944 ClientHeight = 161 45 ClientWidth = 647 48 46 TabOrder = 1 49 47 object MemoLog: TDpiMemo 50 Left = 851 Height = 1 1752 Top = 853 Width = 52348 Left = 10 49 Height = 141 50 Top = 10 51 Width = 627 54 52 Anchors = [akTop, akLeft, akRight, akBottom] 55 53 ReadOnly = True … … 60 58 object PanelProgress: TDpiPanel 61 59 Left = 0 62 Height = 5463 Top = 1 0664 Width = 53960 Height = 65 61 Top = 126 62 Width = 647 65 63 Align = alTop 66 64 BevelOuter = bvNone 67 ClientHeight = 5468 ClientWidth = 53965 ClientHeight = 65 66 ClientWidth = 647 69 67 TabOrder = 2 70 68 object ProgressBarPart: TProgressBar 71 Left = 1 072 Height = 2 473 Top = 2 474 Width = 52369 Left = 12 70 Height = 29 71 Top = 29 72 Width = 628 75 73 Anchors = [akTop, akLeft, akRight] 76 74 TabOrder = 0 77 75 end 78 76 object LabelEstimatedTimePart: TLabel 79 Left = 880 Height = 2 077 Left = 10 78 Height = 26 81 79 Top = -2 82 Width = 1 0380 Width = 132 83 81 Caption = 'Estimated time:' 84 ParentColor = False85 82 end 86 83 end 87 84 object PanelOperations: TDpiPanel 88 85 Left = 0 89 Height = 4290 Top = 6491 Width = 53986 Height = 50 87 Top = 76 88 Width = 647 92 89 Align = alTop 93 90 BevelOuter = bvNone 94 ClientHeight = 4295 ClientWidth = 53991 ClientHeight = 50 92 ClientWidth = 647 96 93 FullRepaint = False 97 94 TabOrder = 3 98 95 object ListViewJobs: TDpiListView 99 Left = 8100 Height = 3 2101 Top = 5102 Width = 52396 Left = 10 97 Height = 38 98 Top = 6 99 Width = 627 103 100 Anchors = [akTop, akLeft, akRight, akBottom] 104 101 AutoWidthLastColumn = True … … 107 104 Columns = < 108 105 item 109 Width = 523106 Width = 614 110 107 end> 111 108 OwnerData = True … … 120 117 object PanelProgressTotal: TDpiPanel 121 118 Left = 0 122 Height = 52123 Top = 1 60124 Width = 539119 Height = 62 120 Top = 191 121 Width = 647 125 122 Align = alTop 126 123 BevelOuter = bvNone 127 ClientHeight = 52128 ClientWidth = 539124 ClientHeight = 62 125 ClientWidth = 647 129 126 TabOrder = 4 130 127 object LabelEstimatedTimeTotal: TLabel 131 Left = 8132 Height = 2 0128 Left = 10 129 Height = 26 133 130 Top = 0 134 Width = 1 41131 Width = 178 135 132 Caption = 'Total estimated time:' 136 ParentColor = False137 133 end 138 134 object ProgressBarTotal: TProgressBar 139 Left = 8140 Height = 2 4141 Top = 2 4142 Width = 523135 Left = 10 136 Height = 29 137 Top = 29 138 Width = 627 143 139 Anchors = [akTop, akLeft, akRight] 144 140 TabOrder = 0 … … 147 143 object PanelText: TDpiPanel 148 144 Left = 0 149 Height = 3 2150 Top = 3 2151 Width = 539145 Height = 38 146 Top = 38 147 Width = 647 152 148 Align = alTop 153 149 BevelOuter = bvNone 154 ClientHeight = 3 2155 ClientWidth = 539150 ClientHeight = 38 151 ClientWidth = 647 156 152 TabOrder = 5 157 153 object LabelText: TLabel 158 Left = 8159 Height = 2 4160 Top = 8161 Width = 525154 Left = 10 155 Height = 29 156 Top = 10 157 Width = 630 162 158 Anchors = [akTop, akLeft, akRight] 163 159 AutoSize = False 164 ParentColor = False165 160 end 166 161 end 167 162 object ImageList1: TDpiImageList 168 BkColor = clForeground 169 left = 200 170 top = 8 163 Left = 240 164 Top = 10 171 165 Bitmap = { 172 4C69020000001000000010000000FF00FF00FF00FF00FF00FF00FF00FF00FF00 173 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 174 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 175 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 176 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 177 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 178 FF00000000FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 179 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF000000 180 00FF000000FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 181 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF0000 182 00FF000000FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 183 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF0000 184 00FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 185 FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FF0000 186 00FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FFFF00FF00FF00 187 FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FF000000FFFF00 188 FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FFFF00 189 FF00FF00FF00FF00FF00000000FF000000FF000000FF000000FFFF00FF00FF00 190 FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FF0000 191 00FFFF00FF00000000FF000000FF000000FF000000FFFF00FF00FF00FF00FF00 192 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF0000 193 00FF000000FF000000FF000000FF000000FFFF00FF00FF00FF00FF00FF00FF00 194 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF0000 195 00FF000000FF000000FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00 196 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF000000 197 00FF000000FF000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 198 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 199 FF00000000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 200 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 201 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 202 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 203 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 204 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 205 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 206 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 207 FF00FF00FF00FF00FF00FF00FF00000000FFFF00FF00FF00FF00FF00FF00FF00 208 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 209 FF00FF00FF00FF00FF00FF00FF00000000FF000000FFFF00FF00FF00FF00FF00 210 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 211 FF00FF00FF00FF00FF00FF00FF00000000FF000084FF000000FFFF00FF00FF00 212 FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FF0000 213 00FF000000FF000000FF000000FF000000FF0000FFFF000084FF000000FFFF00 214 FF00FF00FF00FF00FF00FF00FF00FF00FF00000000FF0000FFFF0000FFFF0000 215 FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF000084FF0000 216 00FFFF00FF00FF00FF00FF00FF00FF00FF00000000FF0000FFFF0000FFFF0000 217 FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000 218 84FF000000FFFF00FF00FF00FF00FF00FF00000000FF0000FFFF0000FFFF0000 219 FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000 220 FFFF000084FF000000FFFF00FF00FF00FF00000000FF0000FFFF0000FFFF0000 221 FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000 222 84FF000000FFFF00FF00FF00FF00FF00FF00000000FF0000FFFF0000FFFF0000 223 FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF000084FF0000 224 00FFFF00FF00FF00FF00FF00FF00FF00FF00000000FF000000FF000000FF0000 225 00FF000000FF000000FF000000FF000000FF0000FFFF000084FF000000FFFF00 226 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 227 FF00FF00FF00FF00FF00FF00FF00000000FF000084FF000000FFFF00FF00FF00 228 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 229 FF00FF00FF00FF00FF00FF00FF00000000FF000000FFFF00FF00FF00FF00FF00 230 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 231 FF00FF00FF00FF00FF00FF00FF00000000FFFF00FF00FF00FF00FF00FF00FF00 232 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 233 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 234 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 235 FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 236 FF00FF00FF00FF00FF00FF00FF00 166 4C7A0200000010000000100000006A0000000000000078DAE593490E00100C45 167 7B78F72E5684A63A1142C382BE4F0708F89C955117F4B016BE67B5FC6E96DB97 168 B0D4B9F4CD949F36DED1DF922B0F1BD11FAB5AFC68DE5C44D40220A9FA779EC8 169 6A349FD5A435E43CADA1E3678D73F773F1DBF3EFADFFEEFEBBF97F6696BE9D36 237 170 } 238 171 end … … 241 174 Interval = 100 242 175 OnTimer = TimerUpdateTimer 243 left = 320244 top = 8176 Left = 384 177 Top = 10 245 178 end 246 179 end -
branches/highdpi/Packages/Common/JobProgressView.pas
r462 r463 1 unit UJobProgressView; 2 3 {$MODE Delphi} 1 unit JobProgressView; 4 2 5 3 interface … … 7 5 uses 8 6 UDpiControls, SysUtils, Variants, Classes, Graphics, Controls, Forms, Syncobjs, 9 Dialogs, ComCtrls, StdCtrls, ExtCtrls, Contnrs, UThreading, Math,7 Dialogs, ComCtrls, StdCtrls, ExtCtrls, Generics.Collections, Threading, Math, 10 8 DateUtils; 11 9 … … 71 69 end; 72 70 73 TJobs = class(TObjectList )71 TJobs = class(TObjectList<TJob>) 74 72 end; 75 73 … … 105 103 procedure ReloadJobList; 106 104 procedure FormClose(Sender: TObject; var CloseAction: TCloseAction); 107 procedure FormDestroy(Sender: TObject);108 105 procedure ListViewJobsData(Sender: TObject; Item: TListItem); 109 106 procedure TimerUpdateTimer(Sender: TObject); … … 157 154 end; 158 155 159 //var160 // FormJobProgressView: TFormJobProgressView;161 162 156 procedure Register; 163 157 164 158 resourcestring 165 159 SExecuted = 'Executed'; 160 166 161 167 162 implementation … … 187 182 try 188 183 try 189 //raise Exception.Create('Exception in job');190 184 ProgressView.CurrentJob.Method(Job); 191 185 except … … 286 280 end; 287 281 288 procedure TFormJobProgressView.FormDestroy(Sender:TObject);289 begin290 end;291 292 282 procedure TFormJobProgressView.ListViewJobsData(Sender: TObject; Item: TListItem); 293 283 begin 294 284 if (Item.Index >= 0) and (Item.Index < JobProgressView.Jobs.Count) then 295 with TJob(JobProgressView.Jobs[Item.Index])do begin285 with JobProgressView.Jobs[Item.Index] do begin 296 286 Item.Caption := Title; 297 287 if Item.Index = JobProgressView.CurrentJobIndex then Item.ImageIndex := 1 … … 311 301 Caption := SPleaseWait; 312 302 try 313 //Animate1.FileName := ExtractFileDir(UTF8Encode( DpiApplication.ExeName)) +303 //Animate1.FileName := ExtractFileDir(UTF8Encode(Application.ExeName)) + 314 304 // DirectorySeparator + 'horse.avi'; 315 305 //Animate1.Active := True; … … 405 395 I := 0; 406 396 while I < Jobs.Count do 407 with TJob(Jobs[I])do begin397 with Jobs[I] do begin 408 398 CurrentJobIndex := I; 409 CurrentJob := TJob(Jobs[I]);399 CurrentJob := Jobs[I]; 410 400 JobProgressChange(Self); 411 401 StartTime := Now; … … 420 410 Method(CurrentJob); 421 411 end else begin 412 Thread := TJobThread.Create(True); 422 413 try 423 Thread := TJobThread.Create(True);424 414 with Thread do begin 425 415 FreeOnTerminate := False; … … 494 484 if AValue = FTerminate then Exit; 495 485 for I := 0 to Jobs.Count - 1 do 496 TJob(Jobs[I]).Terminate := AValue;486 Jobs[I].Terminate := AValue; 497 487 FTerminate := AValue; 498 488 end; … … 620 610 procedure TProgress.Increment; 621 611 begin 622 try623 FLock.Acquire;612 FLock.Acquire; 613 try 624 614 Value := Value + 1; 625 615 finally … … 630 620 procedure TProgress.Reset; 631 621 begin 632 try633 FLock.Acquire;622 FLock.Acquire; 623 try 634 624 FValue := 0; 635 625 finally … … 647 637 begin 648 638 FLock.Free; 649 inherited Destroy;639 inherited; 650 640 end; 651 641 … … 678 668 destructor TJob.Destroy; 679 669 begin 680 Progress.Free;670 FreeAndNil(Progress); 681 671 inherited; 682 672 end; -
branches/highdpi/Packages/Common/Languages.pas
r462 r463 1 unit ULanguages; 2 3 {$mode objfpc}{$H+} 1 unit Languages; 4 2 5 3 interface 6 4 7 5 uses 8 Classes, SysUtils, Contnrs;6 Classes, SysUtils, Generics.Collections; 9 7 10 8 type … … 15 13 end; 16 14 17 { TLanguage List}18 19 TLanguage List = class(TObjectList)15 { TLanguages } 16 17 TLanguages = class(TObjectList<TLanguage>) 20 18 function SearchByCode(ACode: string): TLanguage; 21 19 procedure AddNew(Code: string; Name: string); 22 constructor Create ;20 constructor Create(FreeObjects: Boolean = True); 23 21 end; 24 22 … … 218 216 SLang_za = 'Zhuang'; 219 217 SLang_zh = 'Chinese'; 218 SLang_zh_Hans = 'Simplified Chinese'; 219 SLang_zh_Hant = 'Traditional Chinese'; 220 220 SLang_zu = 'Zulu'; 221 221 222 222 223 implementation 223 224 224 225 225 { TLanguage List}226 227 function TLanguage List.SearchByCode(ACode: string): TLanguage;226 { TLanguages } 227 228 function TLanguages.SearchByCode(ACode: string): TLanguage; 228 229 var 229 230 I: Integer; 230 231 begin 231 232 I := 0; 232 while (I < Count) and ( TLanguage(Items[I]).Code <ACode) do Inc(I);233 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] 234 235 else Result := nil; 235 236 end; 236 237 237 procedure TLanguage List.AddNew(Code: string; Name: string);238 procedure TLanguages.AddNew(Code: string; Name: string); 238 239 var 239 240 NewItem: TLanguage; … … 245 246 end; 246 247 247 constructor TLanguage List.Create;248 constructor TLanguages.Create(FreeObjects: Boolean); 248 249 begin 249 inherited Create;250 inherited; 250 251 AddNew('', SLangAuto); 251 252 AddNew('aa', SLang_aa); … … 441 442 AddNew('za', SLang_za); 442 443 AddNew('zh', SLang_zh); 444 AddNew('zh-Hant', SLang_zh_Hant); 445 AddNew('zh-Hans', SLang_zh_Hans); 443 446 AddNew('zu', SLang_zu); 444 447 end; 445 448 446 449 end. 447 -
branches/highdpi/Packages/Common/Languages/DebugLog.cs.po
r462 r463 10 10 "Content-Transfer-Encoding: 8bit\n" 11 11 12 #: udebuglog.sfilenamenotdefined 12 #: debuglog.sfilenamenotdefined 13 #, fuzzy 14 msgctxt "debuglog.sfilenamenotdefined" 13 15 msgid "Filename not defined" 14 16 msgstr "Neurčen soubor" -
branches/highdpi/Packages/Common/Languages/DebugLog.pot
r462 r463 2 2 msgstr "Content-Type: text/plain; charset=UTF-8" 3 3 4 #: udebuglog.sfilenamenotdefined4 #: debuglog.sfilenamenotdefined 5 5 msgid "Filename not defined" 6 msgstr " Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8"6 msgstr "" 7 7 -
branches/highdpi/Packages/Common/Languages/FindFile.cs.po
r462 r463 12 12 "X-Generator: Poedit 1.8.9\n" 13 13 14 #: ufindfile.sdirnotfound 14 #: findfile.sdirnotfound 15 #, fuzzy 16 msgctxt "findfile.sdirnotfound" 15 17 msgid "Directory not found" 16 18 msgstr "Adresář nenalezen" -
branches/highdpi/Packages/Common/Languages/FindFile.pot
r462 r463 2 2 msgstr "Content-Type: text/plain; charset=UTF-8" 3 3 4 #: ufindfile.sdirnotfound4 #: findfile.sdirnotfound 5 5 msgid "Directory not found" 6 6 msgstr "" -
branches/highdpi/Packages/Common/Languages/FormAbout.cs.po
r462 r463 12 12 "X-Generator: Poedit 2.4.1\n" 13 13 14 #: uformabout.slicense 14 #: formabout.slicense 15 #, fuzzy 16 msgctxt "formabout.slicense" 15 17 msgid "License" 16 18 msgstr "Licence" 17 19 18 #: uformabout.sreleasedate 20 #: formabout.sreleasedate 21 #, fuzzy 22 msgctxt "formabout.sreleasedate" 19 23 msgid "Release date" 20 24 msgstr "Datum uvolnění" 21 25 22 #: uformabout.sversion 26 #: formabout.sversion 27 #, fuzzy 28 msgctxt "formabout.sversion" 23 29 msgid "Version" 24 30 msgstr "Verze" -
branches/highdpi/Packages/Common/Languages/FormAbout.pot
r462 r463 2 2 msgstr "Content-Type: text/plain; charset=UTF-8" 3 3 4 #: uformabout.slicense4 #: formabout.slicense 5 5 msgid "License" 6 6 msgstr "" 7 7 8 #: uformabout.sreleasedate8 #: formabout.sreleasedate 9 9 msgid "Release date" 10 10 msgstr "" 11 11 12 #: uformabout.sversion12 #: formabout.sversion 13 13 msgid "Version" 14 14 msgstr "" -
branches/highdpi/Packages/Common/Languages/JobProgressView.cs.po
r462 r463 12 12 "X-Generator: Poedit 2.2\n" 13 13 14 #: ujobprogressview.sestimatedtime 14 #: jobprogressview.sestimatedtime 15 #, object-pascal-format, fuzzy 16 msgctxt "jobprogressview.sestimatedtime" 15 17 msgid "Estimated time: %s" 16 18 msgstr "Odhadovaný čas: %s" 17 19 18 #: ujobprogressview.sexecuted 20 #: jobprogressview.sexecuted 21 #, fuzzy 22 msgctxt "jobprogressview.sexecuted" 19 23 msgid "Executed" 20 24 msgstr "Vykonané" 21 25 22 #: ujobprogressview.sfinished 26 #: jobprogressview.sfinished 27 #, fuzzy 28 msgctxt "jobprogressview.sfinished" 23 29 msgid "Finished" 24 30 msgstr "Dokončené" 25 31 26 #: ujobprogressview.spleasewait 32 #: jobprogressview.spleasewait 33 #, fuzzy 34 msgctxt "jobprogressview.spleasewait" 27 35 msgid "Please wait..." 28 36 msgstr "Prosím čekejte..." 29 37 30 #: ujobprogressview.sterminate 38 #: jobprogressview.sterminate 39 #, fuzzy 40 msgctxt "jobprogressview.sterminate" 31 41 msgid "Termination" 32 42 msgstr "Přerušení" 33 43 34 #: ujobprogressview.stotalestimatedtime 44 #: jobprogressview.stotalestimatedtime 45 #, object-pascal-format, fuzzy 46 msgctxt "jobprogressview.stotalestimatedtime" 35 47 msgid "Total estimated time: %s" 36 48 msgstr "Celkový odhadovaný čas: %s" -
branches/highdpi/Packages/Common/Languages/JobProgressView.pot
r462 r463 2 2 msgstr "Content-Type: text/plain; charset=UTF-8" 3 3 4 #: ujobprogressview.sestimatedtime 4 #: jobprogressview.sestimatedtime 5 #, object-pascal-format 5 6 msgid "Estimated time: %s" 6 7 msgstr "" 7 8 8 #: ujobprogressview.sexecuted9 #: jobprogressview.sexecuted 9 10 msgid "Executed" 10 11 msgstr "" 11 12 12 #: ujobprogressview.sfinished13 #: jobprogressview.sfinished 13 14 msgid "Finished" 14 15 msgstr "" 15 16 16 #: ujobprogressview.spleasewait17 #: jobprogressview.spleasewait 17 18 msgid "Please wait..." 18 19 msgstr "" 19 20 20 #: ujobprogressview.sterminate21 #: jobprogressview.sterminate 21 22 msgid "Termination" 22 23 msgstr "" 23 24 24 #: ujobprogressview.stotalestimatedtime 25 #: jobprogressview.stotalestimatedtime 26 #, object-pascal-format 25 27 msgid "Total estimated time: %s" 26 28 msgstr "" -
branches/highdpi/Packages/Common/Languages/Languages.pot
r462 r463 2 2 msgstr "Content-Type: text/plain; charset=UTF-8" 3 3 4 #: ulanguages.slangauto4 #: languages.slangauto 5 5 msgid "Automatic" 6 6 msgstr "" 7 7 8 #: ulanguages.slang_aa8 #: languages.slang_aa 9 9 msgid "Afar" 10 10 msgstr "" 11 11 12 #: ulanguages.slang_ab12 #: languages.slang_ab 13 13 msgid "Abkhazian" 14 14 msgstr "" 15 15 16 #: ulanguages.slang_ae16 #: languages.slang_ae 17 17 msgid "Avestan" 18 18 msgstr "" 19 19 20 #: ulanguages.slang_af20 #: languages.slang_af 21 21 msgid "Afrikaans" 22 22 msgstr "" 23 23 24 #: ulanguages.slang_ak24 #: languages.slang_ak 25 25 msgid "Akan" 26 26 msgstr "" 27 27 28 #: ulanguages.slang_am28 #: languages.slang_am 29 29 msgid "Amharic" 30 30 msgstr "" 31 31 32 #: ulanguages.slang_an32 #: languages.slang_an 33 33 msgid "Aragonese" 34 34 msgstr "" 35 35 36 #: ulanguages.slang_ar36 #: languages.slang_ar 37 37 msgid "Arabic" 38 38 msgstr "" 39 39 40 #: ulanguages.slang_as40 #: languages.slang_as 41 41 msgid "Assamese" 42 42 msgstr "" 43 43 44 #: ulanguages.slang_av44 #: languages.slang_av 45 45 msgid "Avaric" 46 46 msgstr "" 47 47 48 #: ulanguages.slang_ay48 #: languages.slang_ay 49 49 msgid "Aymara" 50 50 msgstr "" 51 51 52 #: ulanguages.slang_az52 #: languages.slang_az 53 53 msgid "Azerbaijani" 54 54 msgstr "" 55 55 56 #: ulanguages.slang_ba56 #: languages.slang_ba 57 57 msgid "Bashkir" 58 58 msgstr "" 59 59 60 #: ulanguages.slang_be60 #: languages.slang_be 61 61 msgid "Belarusian" 62 62 msgstr "" 63 63 64 #: ulanguages.slang_bg64 #: languages.slang_bg 65 65 msgid "Bulgarian" 66 66 msgstr "" 67 67 68 #: ulanguages.slang_bh68 #: languages.slang_bh 69 69 msgid "Bihari" 70 70 msgstr "" 71 71 72 #: ulanguages.slang_bi72 #: languages.slang_bi 73 73 msgid "Bislama" 74 74 msgstr "" 75 75 76 #: ulanguages.slang_bm76 #: languages.slang_bm 77 77 msgid "Bambara" 78 78 msgstr "" 79 79 80 #: ulanguages.slang_bn80 #: languages.slang_bn 81 81 msgid "Bengali" 82 82 msgstr "" 83 83 84 #: ulanguages.slang_bo84 #: languages.slang_bo 85 85 msgid "Tibetan" 86 86 msgstr "" 87 87 88 #: ulanguages.slang_br88 #: languages.slang_br 89 89 msgid "Breton" 90 90 msgstr "" 91 91 92 #: ulanguages.slang_bs92 #: languages.slang_bs 93 93 msgid "Bosnian" 94 94 msgstr "" 95 95 96 #: ulanguages.slang_ca96 #: languages.slang_ca 97 97 msgid "Catalan" 98 98 msgstr "" 99 99 100 #: ulanguages.slang_ce100 #: languages.slang_ce 101 101 msgid "Chechen" 102 102 msgstr "" 103 103 104 #: ulanguages.slang_ch104 #: languages.slang_ch 105 105 msgid "Chamorro" 106 106 msgstr "" 107 107 108 #: ulanguages.slang_co108 #: languages.slang_co 109 109 msgid "Corsican" 110 110 msgstr "" 111 111 112 #: ulanguages.slang_cr112 #: languages.slang_cr 113 113 msgid "Cree" 114 114 msgstr "" 115 115 116 #: ulanguages.slang_cs116 #: languages.slang_cs 117 117 msgid "Czech" 118 118 msgstr "" 119 119 120 #: ulanguages.slang_cv120 #: languages.slang_cv 121 121 msgid "Chuvash" 122 122 msgstr "" 123 123 124 #: ulanguages.slang_cy124 #: languages.slang_cy 125 125 msgid "Welsh" 126 126 msgstr "" 127 127 128 #: ulanguages.slang_da128 #: languages.slang_da 129 129 msgid "Danish" 130 130 msgstr "" 131 131 132 #: ulanguages.slang_de132 #: languages.slang_de 133 133 msgid "German" 134 134 msgstr "" 135 135 136 #: ulanguages.slang_de_at136 #: languages.slang_de_at 137 137 msgid "Austrian German" 138 138 msgstr "" 139 139 140 #: ulanguages.slang_de_ch140 #: languages.slang_de_ch 141 141 msgid "Swiss German" 142 142 msgstr "" 143 143 144 #: ulanguages.slang_dv144 #: languages.slang_dv 145 145 msgid "Divehi" 146 146 msgstr "" 147 147 148 #: ulanguages.slang_dz148 #: languages.slang_dz 149 149 msgid "Dzongkha" 150 150 msgstr "" 151 151 152 #: ulanguages.slang_ee152 #: languages.slang_ee 153 153 msgid "Ewe" 154 154 msgstr "" 155 155 156 #: ulanguages.slang_el156 #: languages.slang_el 157 157 msgid "Greek" 158 158 msgstr "" 159 159 160 #: ulanguages.slang_en160 #: languages.slang_en 161 161 msgid "English" 162 162 msgstr "" 163 163 164 #: ulanguages.slang_en_au164 #: languages.slang_en_au 165 165 msgid "Australian English" 166 166 msgstr "" 167 167 168 #: ulanguages.slang_en_ca168 #: languages.slang_en_ca 169 169 msgid "Canadian English" 170 170 msgstr "" 171 171 172 #: ulanguages.slang_en_gb172 #: languages.slang_en_gb 173 173 msgid "British English" 174 174 msgstr "" 175 175 176 #: ulanguages.slang_en_us176 #: languages.slang_en_us 177 177 msgid "American English" 178 178 msgstr "" 179 179 180 #: ulanguages.slang_eo180 #: languages.slang_eo 181 181 msgid "Esperanto" 182 182 msgstr "" 183 183 184 #: ulanguages.slang_es184 #: languages.slang_es 185 185 msgid "Spanish" 186 186 msgstr "" 187 187 188 #: ulanguages.slang_et188 #: languages.slang_et 189 189 msgid "Estonian" 190 190 msgstr "" 191 191 192 #: ulanguages.slang_eu192 #: languages.slang_eu 193 193 msgid "Basque" 194 194 msgstr "" 195 195 196 #: ulanguages.slang_fa196 #: languages.slang_fa 197 197 msgid "Persian" 198 198 msgstr "" 199 199 200 #: ulanguages.slang_ff200 #: languages.slang_ff 201 201 msgid "Fulah" 202 202 msgstr "" 203 203 204 #: ulanguages.slang_fi204 #: languages.slang_fi 205 205 msgid "Finnish" 206 206 msgstr "" 207 207 208 #: ulanguages.slang_fj208 #: languages.slang_fj 209 209 msgid "Fijian" 210 210 msgstr "" 211 211 212 #: ulanguages.slang_fo212 #: languages.slang_fo 213 213 msgid "Faroese" 214 214 msgstr "" 215 215 216 #: ulanguages.slang_fr216 #: languages.slang_fr 217 217 msgid "French" 218 218 msgstr "" 219 219 220 #: ulanguages.slang_fr_be221 msgctxt " ulanguages.slang_fr_be"220 #: languages.slang_fr_be 221 msgctxt "languages.slang_fr_be" 222 222 msgid "Walloon" 223 223 msgstr "" 224 224 225 #: ulanguages.slang_fy225 #: languages.slang_fy 226 226 msgid "Frisian" 227 227 msgstr "" 228 228 229 #: ulanguages.slang_ga229 #: languages.slang_ga 230 230 msgid "Irish" 231 231 msgstr "" 232 232 233 #: ulanguages.slang_gd233 #: languages.slang_gd 234 234 msgid "Gaelic" 235 235 msgstr "" 236 236 237 #: ulanguages.slang_gl237 #: languages.slang_gl 238 238 msgid "Gallegan" 239 239 msgstr "" 240 240 241 #: ulanguages.slang_gn241 #: languages.slang_gn 242 242 msgid "Guarani" 243 243 msgstr "" 244 244 245 #: ulanguages.slang_gu245 #: languages.slang_gu 246 246 msgid "Gujarati" 247 247 msgstr "" 248 248 249 #: ulanguages.slang_gv249 #: languages.slang_gv 250 250 msgid "Manx" 251 251 msgstr "" 252 252 253 #: ulanguages.slang_ha253 #: languages.slang_ha 254 254 msgid "Hausa" 255 255 msgstr "" 256 256 257 #: ulanguages.slang_he257 #: languages.slang_he 258 258 msgid "Hebrew" 259 259 msgstr "" 260 260 261 #: ulanguages.slang_hi261 #: languages.slang_hi 262 262 msgid "Hindi" 263 263 msgstr "" 264 264 265 #: ulanguages.slang_ho265 #: languages.slang_ho 266 266 msgid "Hiri Motu" 267 267 msgstr "" 268 268 269 #: ulanguages.slang_hr269 #: languages.slang_hr 270 270 msgid "Croatian" 271 271 msgstr "" 272 272 273 #: ulanguages.slang_ht273 #: languages.slang_ht 274 274 msgid "Haitian" 275 275 msgstr "" 276 276 277 #: ulanguages.slang_hu277 #: languages.slang_hu 278 278 msgid "Hungarian" 279 279 msgstr "" 280 280 281 #: ulanguages.slang_hy281 #: languages.slang_hy 282 282 msgid "Armenian" 283 283 msgstr "" 284 284 285 #: ulanguages.slang_hz285 #: languages.slang_hz 286 286 msgid "Herero" 287 287 msgstr "" 288 288 289 #: ulanguages.slang_ia289 #: languages.slang_ia 290 290 msgid "Interlingua" 291 291 msgstr "" 292 292 293 #: ulanguages.slang_id293 #: languages.slang_id 294 294 msgid "Indonesian" 295 295 msgstr "" 296 296 297 #: ulanguages.slang_ie297 #: languages.slang_ie 298 298 msgid "Interlingue" 299 299 msgstr "" 300 300 301 #: ulanguages.slang_ig301 #: languages.slang_ig 302 302 msgid "Igbo" 303 303 msgstr "" 304 304 305 #: ulanguages.slang_ii305 #: languages.slang_ii 306 306 msgid "Sichuan Yi" 307 307 msgstr "" 308 308 309 #: ulanguages.slang_ik309 #: languages.slang_ik 310 310 msgid "Inupiaq" 311 311 msgstr "" 312 312 313 #: ulanguages.slang_io313 #: languages.slang_io 314 314 msgid "Ido" 315 315 msgstr "" 316 316 317 #: ulanguages.slang_is317 #: languages.slang_is 318 318 msgid "Icelandic" 319 319 msgstr "" 320 320 321 #: ulanguages.slang_it321 #: languages.slang_it 322 322 msgid "Italian" 323 323 msgstr "" 324 324 325 #: ulanguages.slang_iu325 #: languages.slang_iu 326 326 msgid "Inuktitut" 327 327 msgstr "" 328 328 329 #: ulanguages.slang_ja329 #: languages.slang_ja 330 330 msgid "Japanese" 331 331 msgstr "" 332 332 333 #: ulanguages.slang_jv333 #: languages.slang_jv 334 334 msgid "Javanese" 335 335 msgstr "" 336 336 337 #: ulanguages.slang_ka337 #: languages.slang_ka 338 338 msgid "Georgian" 339 339 msgstr "" 340 340 341 #: ulanguages.slang_kg341 #: languages.slang_kg 342 342 msgid "Kongo" 343 343 msgstr "" 344 344 345 #: ulanguages.slang_ki345 #: languages.slang_ki 346 346 msgid "Kikuyu" 347 347 msgstr "" 348 348 349 #: ulanguages.slang_kj349 #: languages.slang_kj 350 350 msgid "Kuanyama" 351 351 msgstr "" 352 352 353 #: ulanguages.slang_kk353 #: languages.slang_kk 354 354 msgid "Kazakh" 355 355 msgstr "" 356 356 357 #: ulanguages.slang_kl357 #: languages.slang_kl 358 358 msgid "Greenlandic" 359 359 msgstr "" 360 360 361 #: ulanguages.slang_km361 #: languages.slang_km 362 362 msgid "Khmer" 363 363 msgstr "" 364 364 365 #: ulanguages.slang_kn365 #: languages.slang_kn 366 366 msgid "Kannada" 367 367 msgstr "" 368 368 369 #: ulanguages.slang_ko369 #: languages.slang_ko 370 370 msgid "Korean" 371 371 msgstr "" 372 372 373 #: ulanguages.slang_kr373 #: languages.slang_kr 374 374 msgid "Kanuri" 375 375 msgstr "" 376 376 377 #: ulanguages.slang_ks377 #: languages.slang_ks 378 378 msgid "Kashmiri" 379 379 msgstr "" 380 380 381 #: ulanguages.slang_ku381 #: languages.slang_ku 382 382 msgid "Kurdish" 383 383 msgstr "" 384 384 385 #: ulanguages.slang_kv385 #: languages.slang_kv 386 386 msgid "Komi" 387 387 msgstr "" 388 388 389 #: ulanguages.slang_kw389 #: languages.slang_kw 390 390 msgid "Cornish" 391 391 msgstr "" 392 392 393 #: ulanguages.slang_ky393 #: languages.slang_ky 394 394 msgid "Kirghiz" 395 395 msgstr "" 396 396 397 #: ulanguages.slang_la397 #: languages.slang_la 398 398 msgid "Latin" 399 399 msgstr "" 400 400 401 #: ulanguages.slang_lb401 #: languages.slang_lb 402 402 msgid "Luxembourgish" 403 403 msgstr "" 404 404 405 #: ulanguages.slang_lg405 #: languages.slang_lg 406 406 msgid "Ganda" 407 407 msgstr "" 408 408 409 #: ulanguages.slang_li409 #: languages.slang_li 410 410 msgid "Limburgan" 411 411 msgstr "" 412 412 413 #: ulanguages.slang_ln413 #: languages.slang_ln 414 414 msgid "Lingala" 415 415 msgstr "" 416 416 417 #: ulanguages.slang_lo417 #: languages.slang_lo 418 418 msgid "Lao" 419 419 msgstr "" 420 420 421 #: ulanguages.slang_lt421 #: languages.slang_lt 422 422 msgid "Lithuanian" 423 423 msgstr "" 424 424 425 #: ulanguages.slang_lu425 #: languages.slang_lu 426 426 msgid "Luba-Katanga" 427 427 msgstr "" 428 428 429 #: ulanguages.slang_lv429 #: languages.slang_lv 430 430 msgid "Latvian" 431 431 msgstr "" 432 432 433 #: ulanguages.slang_mg433 #: languages.slang_mg 434 434 msgid "Malagasy" 435 435 msgstr "" 436 436 437 #: ulanguages.slang_mh437 #: languages.slang_mh 438 438 msgid "Marshallese" 439 439 msgstr "" 440 440 441 #: ulanguages.slang_mi441 #: languages.slang_mi 442 442 msgid "Maori" 443 443 msgstr "" 444 444 445 #: ulanguages.slang_mk445 #: languages.slang_mk 446 446 msgid "Macedonian" 447 447 msgstr "" 448 448 449 #: ulanguages.slang_ml449 #: languages.slang_ml 450 450 msgid "Malayalam" 451 451 msgstr "" 452 452 453 #: ulanguages.slang_mn453 #: languages.slang_mn 454 454 msgid "Mongolian" 455 455 msgstr "" 456 456 457 #: ulanguages.slang_mo457 #: languages.slang_mo 458 458 msgid "Moldavian" 459 459 msgstr "" 460 460 461 #: ulanguages.slang_mr461 #: languages.slang_mr 462 462 msgid "Marathi" 463 463 msgstr "" 464 464 465 #: ulanguages.slang_ms465 #: languages.slang_ms 466 466 msgid "Malay" 467 467 msgstr "" 468 468 469 #: ulanguages.slang_mt469 #: languages.slang_mt 470 470 msgid "Maltese" 471 471 msgstr "" 472 472 473 #: ulanguages.slang_my473 #: languages.slang_my 474 474 msgid "Burmese" 475 475 msgstr "" 476 476 477 #: ulanguages.slang_na477 #: languages.slang_na 478 478 msgid "Nauru" 479 479 msgstr "" 480 480 481 #: ulanguages.slang_nb481 #: languages.slang_nb 482 482 msgid "Norwegian Bokmaal" 483 483 msgstr "" 484 484 485 #: ulanguages.slang_nd485 #: languages.slang_nd 486 486 msgid "Ndebele, North" 487 487 msgstr "" 488 488 489 #: ulanguages.slang_ne489 #: languages.slang_ne 490 490 msgid "Nepali" 491 491 msgstr "" 492 492 493 #: ulanguages.slang_ng493 #: languages.slang_ng 494 494 msgid "Ndonga" 495 495 msgstr "" 496 496 497 #: ulanguages.slang_nl497 #: languages.slang_nl 498 498 msgid "Dutch" 499 499 msgstr "" 500 500 501 #: ulanguages.slang_nl_be501 #: languages.slang_nl_be 502 502 msgid "Flemish" 503 503 msgstr "" 504 504 505 #: ulanguages.slang_nn505 #: languages.slang_nn 506 506 msgid "Norwegian Nynorsk" 507 507 msgstr "" 508 508 509 #: ulanguages.slang_no509 #: languages.slang_no 510 510 msgid "Norwegian" 511 511 msgstr "" 512 512 513 #: ulanguages.slang_nr513 #: languages.slang_nr 514 514 msgid "Ndebele, South" 515 515 msgstr "" 516 516 517 #: ulanguages.slang_nv517 #: languages.slang_nv 518 518 msgid "Navajo" 519 519 msgstr "" 520 520 521 #: ulanguages.slang_ny521 #: languages.slang_ny 522 522 msgid "Chichewa" 523 523 msgstr "" 524 524 525 #: ulanguages.slang_oc525 #: languages.slang_oc 526 526 msgid "Occitan" 527 527 msgstr "" 528 528 529 #: ulanguages.slang_oj529 #: languages.slang_oj 530 530 msgid "Ojibwa" 531 531 msgstr "" 532 532 533 #: ulanguages.slang_om533 #: languages.slang_om 534 534 msgid "Oromo" 535 535 msgstr "" 536 536 537 #: ulanguages.slang_or537 #: languages.slang_or 538 538 msgid "Oriya" 539 539 msgstr "" 540 540 541 #: ulanguages.slang_os541 #: languages.slang_os 542 542 msgid "Ossetian" 543 543 msgstr "" 544 544 545 #: ulanguages.slang_pa545 #: languages.slang_pa 546 546 msgid "Panjabi" 547 547 msgstr "" 548 548 549 #: ulanguages.slang_pi549 #: languages.slang_pi 550 550 msgid "Pali" 551 551 msgstr "" 552 552 553 #: ulanguages.slang_pl553 #: languages.slang_pl 554 554 msgid "Polish" 555 555 msgstr "" 556 556 557 #: ulanguages.slang_ps557 #: languages.slang_ps 558 558 msgid "Pushto" 559 559 msgstr "" 560 560 561 #: ulanguages.slang_pt561 #: languages.slang_pt 562 562 msgid "Portuguese" 563 563 msgstr "" 564 564 565 #: ulanguages.slang_pt_br565 #: languages.slang_pt_br 566 566 msgid "Brazilian Portuguese" 567 567 msgstr "" 568 568 569 #: ulanguages.slang_qu569 #: languages.slang_qu 570 570 msgid "Quechua" 571 571 msgstr "" 572 572 573 #: ulanguages.slang_rm573 #: languages.slang_rm 574 574 msgid "Raeto-Romance" 575 575 msgstr "" 576 576 577 #: ulanguages.slang_rn577 #: languages.slang_rn 578 578 msgid "Rundi" 579 579 msgstr "" 580 580 581 #: ulanguages.slang_ro581 #: languages.slang_ro 582 582 msgid "Romanian" 583 583 msgstr "" 584 584 585 #: ulanguages.slang_ru585 #: languages.slang_ru 586 586 msgid "Russian" 587 587 msgstr "" 588 588 589 #: ulanguages.slang_rw589 #: languages.slang_rw 590 590 msgid "Kinyarwanda" 591 591 msgstr "" 592 592 593 #: ulanguages.slang_sa593 #: languages.slang_sa 594 594 msgid "Sanskrit" 595 595 msgstr "" 596 596 597 #: ulanguages.slang_sc597 #: languages.slang_sc 598 598 msgid "Sardinian" 599 599 msgstr "" 600 600 601 #: ulanguages.slang_sd601 #: languages.slang_sd 602 602 msgid "Sindhi" 603 603 msgstr "" 604 604 605 #: ulanguages.slang_se605 #: languages.slang_se 606 606 msgid "Northern Sami" 607 607 msgstr "" 608 608 609 #: ulanguages.slang_sg609 #: languages.slang_sg 610 610 msgid "Sango" 611 611 msgstr "" 612 612 613 #: ulanguages.slang_si613 #: languages.slang_si 614 614 msgid "Sinhalese" 615 615 msgstr "" 616 616 617 #: ulanguages.slang_sk617 #: languages.slang_sk 618 618 msgid "Slovak" 619 619 msgstr "" 620 620 621 #: ulanguages.slang_sl621 #: languages.slang_sl 622 622 msgid "Slovenian" 623 623 msgstr "" 624 624 625 #: ulanguages.slang_sm625 #: languages.slang_sm 626 626 msgid "Samoan" 627 627 msgstr "" 628 628 629 #: ulanguages.slang_sn629 #: languages.slang_sn 630 630 msgid "Shona" 631 631 msgstr "" 632 632 633 #: ulanguages.slang_so633 #: languages.slang_so 634 634 msgid "Somali" 635 635 msgstr "" 636 636 637 #: ulanguages.slang_sq637 #: languages.slang_sq 638 638 msgid "Albanian" 639 639 msgstr "" 640 640 641 #: ulanguages.slang_sr641 #: languages.slang_sr 642 642 msgid "Serbian" 643 643 msgstr "" 644 644 645 #: ulanguages.slang_ss645 #: languages.slang_ss 646 646 msgid "Swati" 647 647 msgstr "" 648 648 649 #: ulanguages.slang_st649 #: languages.slang_st 650 650 msgid "Sotho, Southern" 651 651 msgstr "" 652 652 653 #: ulanguages.slang_su653 #: languages.slang_su 654 654 msgid "Sundanese" 655 655 msgstr "" 656 656 657 #: ulanguages.slang_sv657 #: languages.slang_sv 658 658 msgid "Swedish" 659 659 msgstr "" 660 660 661 #: ulanguages.slang_sw661 #: languages.slang_sw 662 662 msgid "Swahili" 663 663 msgstr "" 664 664 665 #: ulanguages.slang_ta665 #: languages.slang_ta 666 666 msgid "Tamil" 667 667 msgstr "" 668 668 669 #: ulanguages.slang_te669 #: languages.slang_te 670 670 msgid "Telugu" 671 671 msgstr "" 672 672 673 #: ulanguages.slang_tg673 #: languages.slang_tg 674 674 msgid "Tajik" 675 675 msgstr "" 676 676 677 #: ulanguages.slang_th677 #: languages.slang_th 678 678 msgid "Thai" 679 679 msgstr "" 680 680 681 #: ulanguages.slang_ti681 #: languages.slang_ti 682 682 msgid "Tigrinya" 683 683 msgstr "" 684 684 685 #: ulanguages.slang_tk685 #: languages.slang_tk 686 686 msgid "Turkmen" 687 687 msgstr "" 688 688 689 #: ulanguages.slang_tl689 #: languages.slang_tl 690 690 msgid "Tagalog" 691 691 msgstr "" 692 692 693 #: ulanguages.slang_tn693 #: languages.slang_tn 694 694 msgid "Tswana" 695 695 msgstr "" 696 696 697 #: ulanguages.slang_to697 #: languages.slang_to 698 698 msgid "Tonga" 699 699 msgstr "" 700 700 701 #: ulanguages.slang_tr701 #: languages.slang_tr 702 702 msgid "Turkish" 703 703 msgstr "" 704 704 705 #: ulanguages.slang_ts705 #: languages.slang_ts 706 706 msgid "Tsonga" 707 707 msgstr "" 708 708 709 #: ulanguages.slang_tt709 #: languages.slang_tt 710 710 msgid "Tatar" 711 711 msgstr "" 712 712 713 #: ulanguages.slang_tw713 #: languages.slang_tw 714 714 msgid "Twi" 715 715 msgstr "" 716 716 717 #: ulanguages.slang_ty717 #: languages.slang_ty 718 718 msgid "Tahitian" 719 719 msgstr "" 720 720 721 #: ulanguages.slang_ug721 #: languages.slang_ug 722 722 msgid "Uighur" 723 723 msgstr "" 724 724 725 #: ulanguages.slang_uk725 #: languages.slang_uk 726 726 msgid "Ukrainian" 727 727 msgstr "" 728 728 729 #: ulanguages.slang_ur729 #: languages.slang_ur 730 730 msgid "Urdu" 731 731 msgstr "" 732 732 733 #: ulanguages.slang_uz733 #: languages.slang_uz 734 734 msgid "Uzbek" 735 735 msgstr "" 736 736 737 #: ulanguages.slang_ve737 #: languages.slang_ve 738 738 msgid "Venda" 739 739 msgstr "" 740 740 741 #: ulanguages.slang_vi741 #: languages.slang_vi 742 742 msgid "Vietnamese" 743 743 msgstr "" 744 744 745 #: ulanguages.slang_vo745 #: languages.slang_vo 746 746 msgid "Volapuk" 747 747 msgstr "" 748 748 749 #: ulanguages.slang_wa750 msgctxt " ulanguages.slang_wa"749 #: languages.slang_wa 750 msgctxt "languages.slang_wa" 751 751 msgid "Walloon" 752 752 msgstr "" 753 753 754 #: ulanguages.slang_wo754 #: languages.slang_wo 755 755 msgid "Wolof" 756 756 msgstr "" 757 757 758 #: ulanguages.slang_xh758 #: languages.slang_xh 759 759 msgid "Xhosa" 760 760 msgstr "" 761 761 762 #: ulanguages.slang_yi762 #: languages.slang_yi 763 763 msgid "Yiddish" 764 764 msgstr "" 765 765 766 #: ulanguages.slang_yo766 #: languages.slang_yo 767 767 msgid "Yoruba" 768 768 msgstr "" 769 769 770 #: ulanguages.slang_za770 #: languages.slang_za 771 771 msgid "Zhuang" 772 772 msgstr "" 773 773 774 #: ulanguages.slang_zh774 #: languages.slang_zh 775 775 msgid "Chinese" 776 776 msgstr "" 777 777 778 #: ulanguages.slang_zu 778 #: languages.slang_zh_hans 779 msgid "Simplified Chinese" 780 msgstr "" 781 782 #: languages.slang_zh_hant 783 msgid "Traditional Chinese" 784 msgstr "" 785 786 #: languages.slang_zu 779 787 msgid "Zulu" 780 788 msgstr "" -
branches/highdpi/Packages/Common/Languages/Pool.cs.po
r462 r463 10 10 "Content-Transfer-Encoding: 8bit\n" 11 11 12 #: upool.sobjectpoolempty 12 #: pool.sobjectpoolempty 13 #, fuzzy 14 msgctxt "pool.sobjectpoolempty" 13 15 msgid "Object pool is empty" 14 16 msgstr "Zásobník objektů je prázdný" 15 17 16 #: upool.sreleaseerror 18 #: pool.sreleaseerror 19 #, fuzzy 20 msgctxt "pool.sreleaseerror" 17 21 msgid "Unknown object for release from pool" 18 22 msgstr "Neznýmý objekt pro uvolnění ze zásobníku" -
branches/highdpi/Packages/Common/Languages/Pool.pot
r462 r463 2 2 msgstr "Content-Type: text/plain; charset=UTF-8" 3 3 4 #: upool.sobjectpoolempty4 #: pool.sobjectpoolempty 5 5 msgid "Object pool is empty" 6 msgstr " Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8"6 msgstr "" 7 7 8 #: upool.sreleaseerror8 #: pool.sreleaseerror 9 9 msgid "Unknown object for release from pool" 10 10 msgstr "" -
branches/highdpi/Packages/Common/Languages/ResetableThread.cs.po
r462 r463 10 10 "Content-Transfer-Encoding: 8bit\n" 11 11 12 #: uresetablethread.swaiterror 12 #: resetablethread.swaiterror 13 #, fuzzy 14 msgctxt "resetablethread.swaiterror" 13 15 msgid "WaitFor error" 14 16 msgstr "Chyba WaitFor" -
branches/highdpi/Packages/Common/Languages/ResetableThread.pot
r462 r463 2 2 msgstr "Content-Type: text/plain; charset=UTF-8" 3 3 4 #: uresetablethread.swaiterror4 #: resetablethread.swaiterror 5 5 msgid "WaitFor error" 6 msgstr " Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8"6 msgstr "" 7 7 -
branches/highdpi/Packages/Common/Languages/ScaleDPI.cs.po
r462 r463 12 12 "X-Generator: Poedit 1.8.9\n" 13 13 14 #: uscaledpi.swrongdpi 14 #: scaledpi.swrongdpi 15 #, object-pascal-format, fuzzy 16 msgctxt "scaledpi.swrongdpi" 15 17 msgid "Wrong DPI [%d,%d]" 16 18 msgstr "Chybné DPI [%d,%d]" -
branches/highdpi/Packages/Common/Languages/ScaleDPI.pot
r462 r463 2 2 msgstr "Content-Type: text/plain; charset=UTF-8" 3 3 4 #: uscaledpi.swrongdpi 4 #: scaledpi.swrongdpi 5 #, object-pascal-format 5 6 msgid "Wrong DPI [%d,%d]" 6 7 msgstr "" -
branches/highdpi/Packages/Common/Languages/Threading.cs.po
r462 r463 10 10 "Content-Transfer-Encoding: 8bit\n" 11 11 12 #: uthreading.scurrentthreadnotfound 12 #: threading.scurrentthreadnotfound 13 #, object-pascal-format, fuzzy 14 msgctxt "threading.scurrentthreadnotfound" 13 15 msgid "Current thread ID %d not found in virtual thread list." 14 16 msgstr "Aktuální vlákno ID %d nenalezeno v seznamu virtuálních vláken." -
branches/highdpi/Packages/Common/Languages/Threading.pot
r462 r463 2 2 msgstr "Content-Type: text/plain; charset=UTF-8" 3 3 4 #: uthreading.scurrentthreadnotfound5 #, fuzzy,badformat4 #: threading.scurrentthreadnotfound 5 #, object-pascal-format 6 6 msgid "Current thread ID %d not found in virtual thread list." 7 msgstr " Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8Content-Type: text/plain; charset=UTF-8"7 msgstr "" 8 8 -
branches/highdpi/Packages/Common/LastOpenedList.pas
r462 r463 1 unit ULastOpenedList; 2 3 {$mode delphi} 1 unit LastOpenedList; 4 2 5 3 interface 6 4 7 5 uses 8 UDpiControls, Classes, SysUtils, Registry, URegistry, Menus, XMLConf, DOM;6 UDpiControls, Classes, SysUtils, Registry, RegistryEx, Menus, XMLConf, DOM; 9 7 10 8 type … … 84 82 destructor TLastOpenedList.Destroy; 85 83 begin 86 Items.Free;84 FreeAndNil(Items); 87 85 inherited; 88 86 end; … … 94 92 begin 95 93 if Assigned(MenuItem) then begin 96 MenuItem.Clear; 94 while MenuItem.Count > Items.Count do 95 MenuItem.Delete(MenuItem.Count - 1); 96 while MenuItem.Count < Items.Count do begin 97 NewMenuItem := TDpiMenuItem.Create(MenuItem); 98 MenuItem.Add(NewMenuItem); 99 end; 97 100 for I := 0 to Items.Count - 1 do begin 98 NewMenuItem := TDpiMenuItem.Create(MenuItem); 99 NewMenuItem.Caption := Items[I]; 100 NewMenuItem.OnClick := ClickAction; 101 MenuItem.Add(NewMenuItem); 101 MenuItem.Items[I].Caption := Items[I]; 102 MenuItem.Items[I].OnClick := ClickAction; 102 103 end; 103 104 end; … … 193 194 194 195 end. 195 -
branches/highdpi/Packages/Common/ListViewSort.pas
r462 r463 1 unit UListViewSort;1 unit ListViewSort; 2 2 3 3 // Date: 2019-05-17 4 5 {$mode delphi}6 4 7 5 interface … … 9 7 uses 10 8 UDpiControls, {$IFDEF Windows}Windows, CommCtrl, LMessages, {$ENDIF}Classes, Graphics, ComCtrls, SysUtils, 11 Controls, DateUtils, Dialogs, fgl,Forms, Grids, StdCtrls, ExtCtrls,12 LclIntf, LclType, LResources ;9 Controls, DateUtils, Dialogs, Forms, Grids, StdCtrls, ExtCtrls, 10 LclIntf, LclType, LResources, Generics.Collections, Generics.Defaults; 13 11 14 12 type … … 19 17 TCompareEvent = function (Item1, Item2: TObject): Integer of object; 20 18 TListFilterEvent = procedure (ListViewSort: TListViewSort) of object; 19 20 TObjects = TObjectList<TObject>; 21 21 22 22 { TListViewSort } … … 27 27 FOnCompareItem: TCompareEvent; 28 28 FOnFilter: TListFilterEvent; 29 FOnCustomDraw: T LVCustomDrawItemEvent;29 FOnCustomDraw: TDpiLVCustomDrawItemEvent; 30 30 {$IFDEF Windows}FHeaderHandle: HWND;{$ENDIF} 31 31 FColumn: Integer; … … 42 42 procedure GetCheckBias(var XBias, YBias, BiasTop, BiasLeft: Integer; 43 43 const ListView: TDpiListView); 44 procedure ListViewCustomDrawItem(Sender: T CustomListView;44 procedure ListViewCustomDrawItem(Sender: TDpiCustomListView; 45 45 Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean); 46 46 procedure ListViewClick(Sender: TObject); … … 52 52 {$ENDIF} 53 53 public 54 List: TFPGObjectList<TObject>;55 Source: TFPGObjectList<TObject>;54 Source: TObjects; 55 List: TObjects; 56 56 constructor Create(AOwner: TComponent); override; 57 57 destructor Destroy; override; … … 67 67 property OnFilter: TListFilterEvent read FOnFilter 68 68 write FOnFilter; 69 property OnCustomDraw: T LVCustomDrawItemEvent read FOnCustomDraw69 property OnCustomDraw: TDpiLVCustomDrawItemEvent read FOnCustomDraw 70 70 write FOnCustomDraw; 71 71 property OnColumnWidthChanged: TNotifyEvent read FOnColumnWidthChanged … … 81 81 FOnChange: TNotifyEvent; 82 82 FStringGrid1: TDpiStringGrid; 83 procedure DoOnChange; 83 84 procedure GridDoOnKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); 84 85 procedure GridDoOnResize(Sender: TObject); … … 90 91 function TextEnteredColumn(Index: Integer): Boolean; 91 92 function GetColValue(Index: Integer): string; 93 procedure Reset; 92 94 property StringGrid: TDpiStringGrid read FStringGrid1 write FStringGrid1; 93 95 published … … 147 149 destructor TListViewEx.Destroy; 148 150 begin 149 inherited Destroy;151 inherited; 150 152 end; 151 153 152 154 { TListViewFilter } 155 156 procedure TListViewFilter.DoOnChange; 157 begin 158 if Assigned(FOnChange) then FOnChange(Self); 159 end; 153 160 154 161 procedure TListViewFilter.GridDoOnKeyUp(Sender: TObject; var Key: Word; 155 162 Shift: TShiftState); 156 163 begin 157 if Assigned(FOnChange) then 158 FOnChange(Self); 164 DoOnChange; 159 165 end; 160 166 … … 229 235 end; 230 236 237 procedure TListViewFilter.Reset; 238 var 239 I: Integer; 240 begin 241 with StringGrid do 242 for I := 0 to ColCount - 1 do 243 Cells[I, 0] := ''; 244 DoOnChange; 245 end; 246 231 247 { TListViewSort } 232 248 … … 322 338 ListViewSortCompare: TCompareEvent; 323 339 324 function ListViewCompare(const Item1, Item2: TObject): Integer;340 function ListViewCompare(constref Item1, Item2: TObject): Integer; 325 341 begin 326 342 Result := ListViewSortCompare(Item1, Item2); … … 333 349 ListViewSortCompare := Compare; 334 350 if (List.Count > 0) then 335 List.Sort( ListViewCompare);351 List.Sort(TComparer<TObject>.Construct(ListViewCompare)); 336 352 end; 337 353 … … 339 355 begin 340 356 if Assigned(FOnFilter) then FOnFilter(Self) 341 else if Assigned(Source) then 342 List.Assign(Source) else 357 else if Assigned(Source) then begin 343 358 List.Clear; 359 List.AddRange(Source); 360 end else List.Clear; 344 361 if ListView.Items.Count <> List.Count then 345 362 ListView.Items.Count := List.Count; … … 396 413 begin 397 414 inherited; 398 List := T FPGObjectList<TObject>.Create;399 List. FreeObjects := False;415 List := TObjects.Create; 416 List.OwnsObjects := False; 400 417 end; 401 418 402 419 destructor TListViewSort.Destroy; 403 420 begin 404 List.Free;421 FreeAndNil(List); 405 422 inherited; 406 423 end; … … 491 508 end; 492 509 493 procedure TListViewSort.ListViewCustomDrawItem(Sender: T CustomListView;510 procedure TListViewSort.ListViewCustomDrawItem(Sender: TDpiCustomListView; 494 511 Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean); 495 512 begin -
branches/highdpi/Packages/Common/Memory.pas
r462 r463 1 unit UMemory; 2 3 {$mode Delphi}{$H+} 1 unit Memory; 4 2 5 3 interface … … 44 42 end; 45 43 44 46 45 implementation 47 46 … … 50 49 procedure TPositionMemory.SetSize(AValue: Integer); 51 50 begin 52 inherited SetSize(AValue);51 inherited; 53 52 if FPosition > FSize then FPosition := FSize; 54 53 end; … … 107 106 begin 108 107 Size := 0; 109 inherited Destroy;108 inherited; 110 109 end; 111 110 … … 121 120 122 121 end. 123 -
branches/highdpi/Packages/Common/PersistentForm.pas
r462 r463 1 unit UPersistentForm; 2 3 {$mode delphi} 4 5 // Date: 2020-11-26 1 unit PersistentForm; 6 2 7 3 interface 8 4 9 5 uses 10 UDpiControls, Classes, SysUtils, Forms, URegistry, LCLIntf, Registry, Controls, ComCtrls,6 UDpiControls, Classes, SysUtils, Forms, RegistryEx, LCLIntf, Registry, Controls, ComCtrls, 11 7 ExtCtrls, LCLType; 12 8 … … 23 19 procedure SaveControl(Control: TDpiControl); 24 20 public 25 FormNormalSize: TRect;26 21 FormRestoredSize: TRect; 27 22 FormWindowState: TWindowState; … … 157 152 RootKey := RegistryContext.RootKey; 158 153 OpenKey(RegistryContext.Key + '\Forms\' + Form.Name, True); 159 // Normal size 160 FormNormalSize.Left := ReadIntegerWithDefault('NormalLeft', FormNormalSize.Left); 161 FormNormalSize.Top := ReadIntegerWithDefault('NormalTop', FormNormalSize.Top); 162 FormNormalSize.Right := ReadIntegerWithDefault('NormalWidth', FormNormalSize.Right - FormNormalSize.Left) 163 + FormNormalSize.Left; 164 FormNormalSize.Bottom := ReadIntegerWithDefault('NormalHeight', FormNormalSize.Bottom - FormNormalSize.Top) 165 + FormNormalSize.Top; 154 166 155 // Restored size 167 156 FormRestoredSize.Left := ReadIntegerWithDefault('RestoredLeft', FormRestoredSize.Left); … … 171 160 FormRestoredSize.Bottom := ReadIntegerWithDefault('RestoredHeight', FormRestoredSize.Bottom - FormRestoredSize.Top) 172 161 + FormRestoredSize.Top; 162 173 163 // Other state 174 164 FormWindowState := TWindowState(ReadIntegerWithDefault('WindowState', Integer(FormWindowState))); … … 185 175 RootKey := RegistryContext.RootKey; 186 176 OpenKey(RegistryContext.Key + '\Forms\' + Form.Name, True); 187 // Normal state 188 WriteInteger('NormalWidth', FormNormalSize.Right - FormNormalSize.Left); 189 WriteInteger('NormalHeight', FormNormalSize.Bottom - FormNormalSize.Top); 190 WriteInteger('NormalTop', FormNormalSize.Top); 191 WriteInteger('NormalLeft', FormNormalSize.Left); 192 // Restored state 177 178 // Restored size 193 179 WriteInteger('RestoredWidth', FormRestoredSize.Right - FormRestoredSize.Left); 194 180 WriteInteger('RestoredHeight', FormRestoredSize.Bottom - FormRestoredSize.Top); 195 181 WriteInteger('RestoredTop', FormRestoredSize.Top); 196 182 WriteInteger('RestoredLeft', FormRestoredSize.Left); 183 197 184 // Other state 198 185 WriteInteger('WindowState', Integer(FormWindowState)); … … 259 246 begin 260 247 Self.Form := Form; 248 261 249 // Set default 262 FormNormalSize := Bounds((DpiScreen.Width - Form.Width) div 2,263 (DpiScreen.Height - Form.Height) div 2, Form.Width, Form.Height);264 250 FormRestoredSize := Bounds((DpiScreen.Width - Form.Width) div 2, 265 251 (DpiScreen.Height - Form.Height) div 2, Form.Width, Form.Height); … … 269 255 LoadFromRegistry(RegistryContext); 270 256 271 if not EqualRect(FormNormalSize, FormRestoredSize) or 272 DefaultMaximized then begin 257 if (FormWindowState = wsMaximized) or DefaultMaximized then begin 273 258 // Restore to maximized state 274 259 Form.WindowState := wsNormal; … … 279 264 // Restore to normal state 280 265 Form.WindowState := wsNormal; 281 if FEntireVisible then Form NormalSize := CheckEntireVisible(FormNormalSize)266 if FEntireVisible then FormRestoredSize := CheckEntireVisible(FormRestoredSize) 282 267 else if FMinVisiblePart > 0 then 283 FormNormalSize := CheckPartVisible(FormNormalSize, FMinVisiblePart);284 if not EqualRect(Form NormalSize, Form.BoundsRect) then285 Form.BoundsRect := Form NormalSize;268 FormRestoredSize := CheckPartVisible(FormRestoredSize, FMinVisiblePart); 269 if not EqualRect(FormRestoredSize, Form.BoundsRect) then 270 Form.BoundsRect := FormRestoredSize; 286 271 end; 287 272 if FormFullScreen then SetFullScreen(True); … … 292 277 begin 293 278 Self.Form := Form; 294 FormNormalSize := Bounds(Form.Left, Form.Top, Form.Width, Form.Height); 295 if not FormFullScreen then 296 FormRestoredSize := Bounds(Form.RestoredLeft, Form.RestoredTop, Form.RestoredWidth, 297 Form.RestoredHeight); 298 FormWindowState := Form.WindowState; 279 if not FormFullScreen then begin 280 FormWindowState := Form.WindowState; 281 if FormWindowState = wsMaximized then begin 282 FormRestoredSize := Bounds(Form.RestoredLeft, Form.RestoredTop, Form.RestoredWidth, 283 Form.RestoredHeight); 284 end else 285 if FormWindowState = wsNormal then begin 286 FormRestoredSize := Bounds(Form.Left, Form.Top, Form.Width, Form.Height); 287 end; 288 end; 299 289 SaveToRegistry(RegistryContext); 300 290 SaveControl(Form); … … 314 304 if State then begin 315 305 FormFullScreen := True; 316 FormNormalSize := Form.BoundsRect; 317 FormRestoredSize := Bounds(Form.RestoredLeft, Form.RestoredTop, Form.RestoredWidth, 318 Form.RestoredHeight); 306 if Form.WindowState = wsMaximized then begin 307 FormRestoredSize := Bounds(Form.RestoredLeft, Form.RestoredTop, Form.RestoredWidth, 308 Form.RestoredHeight); 309 end else 310 if Form.WindowState = wsNormal then begin 311 FormRestoredSize := Bounds(Form.Left, Form.Top, Form.Width, Form.Height); 312 end; 319 313 FormWindowState := Form.WindowState; 314 Form.WindowState := wsMaximized; 315 Form.WindowState := wsNormal; 320 316 ShowWindow(Form.Handle, SW_SHOWFULLSCREEN); 321 317 {$IFDEF WINDOWS} … … 329 325 ShowWindow(Form.Handle, SW_SHOWNORMAL); 330 326 if FormWindowState = wsNormal then begin 331 Form.BoundsRect := FormNormalSize; 327 Form.WindowState := wsNormal; 328 Form.BoundsRect := FormRestoredSize; 332 329 end else 333 330 if FormWindowState = wsMaximized then begin … … 339 336 340 337 end. 341 -
branches/highdpi/Packages/Common/PixelPointer.pas
r462 r463 1 unit UPixelPointer;1 unit PixelPointer; 2 2 3 3 interface … … 15 15 private 16 16 procedure SetRGB(AValue: Cardinal); 17 function GetRGB: Cardinal; 17 function GetRGB: Cardinal; 18 18 public 19 19 property RGB: Cardinal read GetRGB write SetRGB; … … 41 41 procedure SetXY(X, Y: Integer); inline; // Set pixel position relative to base 42 42 procedure SetX(X: Integer); inline; // Set horizontal pixel position relative to base 43 class function Create(Bitmap: TDpiRasterImage; BaseX: Integer = 0; BaseY: Integer = 0): TPixelPointer; inline; static; 43 44 end; 44 45 PPixelPointer = ^TPixelPointer; 45 46 46 function PixelPointer(Bitmap: TDpiRasterImage; BaseX: Integer = 0; BaseY: Integer = 0): TPixelPointer; inline;47 47 function SwapRedBlue(Color: TColor32): TColor32; 48 48 procedure BitmapCopyRect(DstBitmap: TDpiRasterImage; DstRect: TRect; SrcBitmap: TDpiRasterImage; SrcPos: TPoint); … … 60 60 function ColorToColor32(Color: TColor): TColor32; 61 61 62 62 63 implementation 63 64 … … 119 120 SrcBitmap.BeginUpdate(True); 120 121 DstBitmap.BeginUpdate(True); 121 SrcPtr := PixelPointer(SrcBitmap, SrcPos.X, SrcPos.Y);122 DstPtr := PixelPointer(DstBitmap, DstRect.Left, DstRect.Top);122 SrcPtr := TPixelPointer.Create(SrcBitmap, SrcPos.X, SrcPos.Y); 123 DstPtr := TPixelPointer.Create(DstBitmap, DstRect.Left, DstRect.Top); 123 124 for Y := 0 to DstRect.Height - 1 do begin 124 125 for X := 0 to DstRect.Width - 1 do begin … … 138 139 var 139 140 SrcPtr, DstPtr: TPixelPointer; 140 SubPtr: TPixelPointer;141 141 X, Y: Integer; 142 142 XX, YY: Integer; … … 150 150 SrcBitmap.BeginUpdate(True); 151 151 DstBitmap.BeginUpdate(True); 152 SrcPtr := PixelPointer(SrcBitmap, SrcRect.Left, SrcRect.Top);153 DstPtr := PixelPointer(DstBitmap, DstRect.Left, DstRect.Top);152 SrcPtr := TPixelPointer.Create(SrcBitmap, SrcRect.Left, SrcRect.Top); 153 DstPtr := TPixelPointer.Create(DstBitmap, DstRect.Left, DstRect.Top); 154 154 for Y := 0 to DstRect.Height - 1 do begin 155 155 for X := 0 to DstRect.Width - 1 do begin … … 181 181 begin 182 182 Bitmap.BeginUpdate(True); 183 Ptr := PixelPointer(Bitmap);183 Ptr := TPixelPointer.Create(Bitmap); 184 184 for Y := 0 to Bitmap.Height - 1 do begin 185 185 for X := 0 to Bitmap.Width - 1 do begin … … 198 198 begin 199 199 Bitmap.BeginUpdate(True); 200 Ptr := PixelPointer(Bitmap, Rect.Left, Rect.Top);200 Ptr := TPixelPointer.Create(Bitmap, Rect.Left, Rect.Top); 201 201 for Y := 0 to Rect.Height - 1 do begin 202 202 for X := 0 to Rect.Width - 1 do begin … … 215 215 begin 216 216 Bitmap.BeginUpdate(True); 217 Ptr := PixelPointer(Bitmap);217 Ptr := TPixelPointer.Create(Bitmap); 218 218 for Y := 0 to Bitmap.Height - 1 do begin 219 219 for X := 0 to Bitmap.Width - 1 do begin … … 232 232 begin 233 233 Bitmap.BeginUpdate(True); 234 Ptr := PixelPointer(Bitmap);234 Ptr := TPixelPointer.Create(Bitmap); 235 235 for Y := 0 to Bitmap.Height - 1 do begin 236 236 for X := 0 to Bitmap.Width - 1 do begin … … 252 252 Pixel := Color32ToPixel32(Color); 253 253 Bitmap.BeginUpdate(True); 254 Ptr := PixelPointer(Bitmap);254 Ptr := TPixelPointer.Create(Bitmap); 255 255 for Y := 0 to Bitmap.Height - 1 do begin 256 256 for X := 0 to Bitmap.Width - 1 do begin … … 295 295 end; 296 296 297 function PixelPointer(Bitmap: TDpiRasterImage; BaseX: Integer;297 class function TPixelPointer.Create(Bitmap: TDpiRasterImage; BaseX: Integer; 298 298 BaseY: Integer): TPixelPointer; 299 299 begin … … 310 310 end; 311 311 312 313 312 end. 314 -
branches/highdpi/Packages/Common/Pool.pas
r462 r463 1 unit UPool; 2 3 {$mode Delphi}{$H+} 1 unit Pool; 4 2 5 3 interface 6 4 7 5 uses 8 Classes, SysUtils, syncobjs, fgl, UThreading;6 Classes, SysUtils, syncobjs, Generics.Collections, Threading; 9 7 10 8 type … … 22 20 function NewItemObject: TObject; virtual; 23 21 public 24 Items: T FPGObjectList<TObject>;25 FreeItems: T FPGObjectList<TObject>;22 Items: TObjectList<TObject>; 23 FreeItems: TObjectList<TObject>; 26 24 function Acquire: TObject; virtual; 27 25 procedure Release(Item: TObject); virtual; … … 108 106 constructor TThreadedPool.Create; 109 107 begin 110 inherited Create;108 inherited; 111 109 Lock := TCriticalSection.Create; 112 110 end; … … 116 114 TotalCount := 0; 117 115 Lock.Free; 118 inherited Destroy;116 inherited; 119 117 end; 120 118 … … 185 183 begin 186 184 inherited; 187 Items := T FPGObjectList<TObject>.Create;188 FreeItems := T FPGObjectList<TObject>.Create;189 FreeItems. FreeObjects := False;185 Items := TObjectList<TObject>.Create; 186 FreeItems := TObjectList<TObject>.Create; 187 FreeItems.OwnsObjects := False; 190 188 FReleaseEvent := TEvent.Create(nil, False, False, ''); 191 189 end; … … 201 199 202 200 end. 203 -
branches/highdpi/Packages/Common/PrefixMultiplier.pas
r462 r463 1 unit UPrefixMultiplier;1 unit PrefixMultiplier; 2 2 3 3 // Date: 2010-06-01 4 5 {$mode delphi}6 4 7 5 interface … … 33 31 ( 34 32 (ShortText: 'y'; FullText: 'yocto'; Value: 1e-24), 35 33 (ShortText: 'z'; FullText: 'zepto'; Value: 1e-21), 36 34 (ShortText: 'a'; FullText: 'atto'; Value: 1e-18), 37 35 (ShortText: 'f'; FullText: 'femto'; Value: 1e-15), … … 54 52 ( 55 53 (ShortText: 'ys'; FullText: 'yocto'; Value: 1e-24), 56 54 (ShortText: 'zs'; FullText: 'zepto'; Value: 1e-21), 57 55 (ShortText: 'as'; FullText: 'atto'; Value: 1e-18), 58 56 (ShortText: 'fs'; FullText: 'femto'; Value: 1e-15), … … 126 124 127 125 end. 128 -
branches/highdpi/Packages/Common/RegistryEx.pas
r462 r463 1 unit URegistry; 2 3 {$MODE delphi} 1 unit RegistryEx; 4 2 5 3 interface … … 48 46 HKEY_CURRENT_CONFIG, HKEY_DYN_DATA); 49 47 48 50 49 implementation 51 52 50 53 51 { TRegistryContext } … … 132 130 function TRegistryEx.OpenKey(const Key: string; CanCreate: Boolean): Boolean; 133 131 begin 134 {$IFDEF Linux}132 {$IFDEF UNIX} 135 133 //CloseKey; 136 134 {$ENDIF} … … 140 138 function TRegistryEx.GetCurrentContext: TRegistryContext; 141 139 begin 142 Result.Key := CurrentPath;140 Result.Key := String(CurrentPath); 143 141 Result.RootKey := RootKey; 144 142 end; -
branches/highdpi/Packages/Common/ResetableThread.pas
r462 r463 1 unit UResetableThread; 2 3 {$mode Delphi}{$H+} 1 unit ResetableThread; 4 2 5 3 interface 6 4 7 5 uses 8 Classes, SysUtils, syncobjs, UThreading, UPool;6 Classes, SysUtils, syncobjs, Threading, Pool; 9 7 10 8 type … … 167 165 FreeAndNil(FStopEvent); 168 166 FreeAndNil(FLock); 169 inherited Destroy;167 inherited; 170 168 end; 171 169 … … 286 284 constructor TThreadPool.Create; 287 285 begin 288 inherited Create;286 inherited; 289 287 end; 290 288 … … 293 291 TotalCount := 0; 294 292 WaitForEmpty; 295 inherited Destroy;293 inherited; 296 294 end; 297 295 -
branches/highdpi/Packages/Common/ScaleDPI.pas
r462 r463 1 unit UScaleDPI;1 unit ScaleDPI; 2 2 3 3 { See: http://wiki.lazarus.freepascal.org/High_DPI } 4 4 5 {$mode delphi}{$H+}6 7 5 interface 8 6 9 7 uses 10 UDpiControls, Classes, Forms, Graphics, Controls, ComCtrls, LCLType, SysUtils, StdCtrls,11 Contnrs;8 UDpiControls, Classes, Forms, Graphics, Controls, ComCtrls, LCLType, SysUtils, 9 Generics.Collections; 12 10 13 11 type 12 TControlDimensions = class; 14 13 15 14 { TControlDimension } … … 18 17 BoundsRect: TRect; 19 18 FontHeight: Integer; 20 Controls: T ObjectList; // TList<TControlDimension>19 Controls: TControlDimensions; 21 20 // Class specifics 22 21 ButtonSize: TPoint; // TToolBar … … 26 25 constructor Create; 27 26 destructor Destroy; override; 27 end; 28 29 TControlDimensions = class(TObjectList<TControlDimension>) 28 30 end; 29 31 … … 73 75 constructor TControlDimension.Create; 74 76 begin 75 Controls := T ObjectList.Create;77 Controls := TControlDimensions.Create; 76 78 end; 77 79 … … 79 81 begin 80 82 FreeAndNil(Controls); 81 inherited Destroy;83 inherited; 82 84 end; 83 85 … … 212 214 TempBmp: TDpiBitmap; 213 215 Temp: array of TDpiBitmap; 214 NewWidth, NewHeight: integer; 216 NewWidth: Integer; 217 NewHeight: Integer; 215 218 I: Integer; 216 219 begin 217 220 ImgList.BeginUpdate; 218 NewWidth := ScaleX(ImgList.Width, FromDPI.X); 219 NewHeight := ScaleY(ImgList.Height, FromDPI.Y); 220 221 SetLength(Temp, ImgList.Count); 222 for I := 0 to ImgList.Count - 1 do 223 begin 224 TempBmp := TDpiBitmap.Create; 225 TempBmp.PixelFormat := pf32bit; 226 ImgList.GetBitmap(I, TempBmp); 227 Temp[I] := TDpiBitmap.Create; 228 Temp[I].SetSize(NewWidth, NewHeight); 229 Temp[I].PixelFormat := pf32bit; 230 Temp[I].TransparentColor := TempBmp.TransparentColor; 231 //Temp[I].TransparentMode := TempBmp.TransparentMode; 232 Temp[I].Transparent := True; 233 Temp[I].Canvas.Brush.Style := bsSolid; 234 Temp[I].Canvas.Brush.Color := Temp[I].TransparentColor; 235 Temp[I].Canvas.FillRect(0, 0, Temp[I].Width, Temp[I].Height); 236 237 if (Temp[I].Width = 0) or (Temp[I].Height = 0) then Continue; 238 Temp[I].Canvas.StretchDraw(Rect(0, 0, Temp[I].Width, Temp[I].Height), TempBmp); 239 TempBmp.Free; 240 end; 241 242 ImgList.Clear; 243 ImgList.Width := NewWidth; 244 ImgList.Height := NewHeight; 245 246 for I := 0 to High(Temp) do 247 begin 248 ImgList.Add(Temp[I], nil); 249 Temp[i].Free; 250 end; 251 ImgList.EndUpdate; 221 try 222 NewWidth := ScaleX(ImgList.Width, FromDPI.X); 223 NewHeight := ScaleY(ImgList.Height, FromDPI.Y); 224 225 Temp := nil; 226 SetLength(Temp, ImgList.Count); 227 for I := 0 to ImgList.Count - 1 do 228 begin 229 TempBmp := TDpiBitmap.Create; 230 try 231 TempBmp.PixelFormat := pf32bit; 232 ImgList.GetBitmap(I, TempBmp); 233 Temp[I] := TDpiBitmap.Create; 234 Temp[I].SetSize(NewWidth, NewHeight); 235 {$IFDEF UNIX} 236 Temp[I].PixelFormat := pf24bit; 237 {$ELSE} 238 Temp[I].PixelFormat := pf32bit; 239 {$ENDIF} 240 Temp[I].TransparentColor := TempBmp.TransparentColor; 241 //Temp[I].TransparentMode := TempBmp.TransparentMode; 242 Temp[I].Transparent := True; 243 Temp[I].Canvas.Brush.Style := bsSolid; 244 Temp[I].Canvas.Brush.Color := Temp[I].TransparentColor; 245 Temp[I].Canvas.FillRect(0, 0, Temp[I].Width, Temp[I].Height); 246 247 if (Temp[I].Width = 0) or (Temp[I].Height = 0) then Continue; 248 Temp[I].Canvas.StretchDraw(Rect(0, 0, Temp[I].Width, Temp[I].Height), TempBmp); 249 finally 250 TempBmp.Free; 251 end; 252 end; 253 254 ImgList.Clear; 255 ImgList.Width := NewWidth; 256 ImgList.Height := NewHeight; 257 258 for I := 0 to High(Temp) do 259 begin 260 ImgList.Add(Temp[I], nil); 261 Temp[i].Free; 262 end; 263 finally 264 ImgList.EndUpdate; 265 end; 252 266 end; 253 267 … … 303 317 304 318 //if Control is TMemo then Exit; 305 //if Control is T DpiForm then319 //if Control is TForm then 306 320 // Control.DisableAutoSizing; 307 321 with Control do begin … … 327 341 with TDpiCoolBar(Control) do begin 328 342 BeginUpdate; 329 for I := 0 to Bands.Count - 1 do 330 with Bands[I] do begin 331 MinWidth := ScaleX(MinWidth, FromDPI.X); 332 MinHeight := ScaleY(MinHeight, FromDPI.Y); 333 // Workaround to bad band width auto sizing 334 //Width := ScaleX(Width, FromDPI.X); 335 Width := ScaleX(Control.Width + 28, FromDPI.X); 336 //Control.Invalidate; 343 try 344 for I := 0 to Bands.Count - 1 do 345 with Bands[I] do begin 346 MinWidth := ScaleX(MinWidth, FromDPI.X); 347 MinHeight := ScaleY(MinHeight, FromDPI.Y); 348 // Workaround to bad band width auto sizing 349 //Width := ScaleX(Width, FromDPI.X); 350 Width := ScaleX(Control.Width + 28, FromDPI.X); 351 //Control.Invalidate; 352 end; 353 // Workaround for bad autosizing of coolbar 354 if AutoSize then begin 355 AutoSize := False; 356 Height := ScaleY(Height, FromDPI.Y); 357 AutoSize := True; 337 358 end; 338 // Workaround for bad autosizing of coolbar 339 if AutoSize then begin 340 AutoSize := False; 341 Height := ScaleY(Height, FromDPI.Y); 342 AutoSize := True; 343 end; 344 EndUpdate; 359 finally 360 EndUpdate; 361 end; 345 362 end; 346 363 … … 353 370 end; 354 371 355 //if Control is T DpiForm then372 //if Control is TForm then 356 373 // Control.EnableAutoSizing; 357 374 end; -
branches/highdpi/Packages/Common/StopWatch.pas
r405 r463 5 5 6 6 uses 7 {$IFDEF W indows}Windows,{$ENDIF}7 {$IFDEF WINDOWS}Windows,{$ENDIF} 8 8 SysUtils, DateUtils; 9 9 … … 32 32 end; 33 33 34 34 35 implementation 35 36 … … 40 41 fIsRunning := False; 41 42 42 {$IFDEF W indows}43 {$IFDEF WINDOWS} 43 44 fIsHighResolution := QueryPerformanceFrequency(fFrequency) ; 44 45 {$ELSE} … … 92 93 93 94 end. 95 -
branches/highdpi/Packages/Common/StringTable.pas
r462 r463 1 unit UStringTable; 2 3 {$mode objfpc}{$H+} 1 unit StringTable; 4 2 5 3 interface … … 71 69 end; 72 70 73 74 71 end. 75 -
branches/highdpi/Packages/Common/SyncCounter.pas
r462 r463 1 unit USyncCounter; 2 3 {$mode delphi} 1 unit SyncCounter; 4 2 5 3 interface … … 25 23 procedure Assign(Source: TSyncCounter); 26 24 end; 25 27 26 28 27 implementation … … 69 68 begin 70 69 Lock.Free; 71 inherited Destroy;70 inherited; 72 71 end; 73 72 … … 79 78 80 79 end. 81 -
branches/highdpi/Packages/Common/Theme.pas
r462 r463 1 unit UTheme;1 unit Theme; 2 2 3 3 interface … … 5 5 uses 6 6 UDpiControls, Classes, SysUtils, Graphics, ComCtrls, Controls, ExtCtrls, Menus, StdCtrls, 7 Spin, Forms, Contnrs, Grids;7 Spin, Forms, Generics.Collections, Grids; 8 8 9 9 type … … 19 19 { TThemes } 20 20 21 TThemes = class(TObjectList )21 TThemes = class(TObjectList<TTheme>) 22 22 function AddNew(Name: string): TTheme; 23 23 function FindByName(Name: string): TTheme; … … 42 42 end; 43 43 44 const 45 ThemeNameSystem = 'System'; 46 ThemeNameLight = 'Light'; 47 ThemeNameDark = 'Dark'; 48 44 49 procedure Register; 50 45 51 46 52 implementation … … 74 80 procedure TThemes.LoadToStrings(Strings: TStrings); 75 81 var 76 Theme: TTheme;82 I: Integer; 77 83 begin 78 Strings.Clear; 79 for Theme in Self do 80 Strings.AddObject(Theme.Name, Theme); 84 Strings.BeginUpdate; 85 try 86 while Strings.Count < Count do Strings.Add(''); 87 while Strings.Count > Count do Strings.Delete(Strings.Count - 1); 88 for I := 0 to Count - 1 do begin 89 Strings[I] := Items[I].Name; 90 Strings.Objects[I] := Items[I]; 91 end; 92 finally 93 Strings.EndUpdate; 94 end; 81 95 end; 82 96 … … 97 111 inherited; 98 112 Themes := TThemes.Create; 99 with Themes.AddNew( 'System') do begin113 with Themes.AddNew(ThemeNameSystem) do begin 100 114 ColorWindow := clWindow; 101 115 ColorWindowText := clWindowText; … … 105 119 end; 106 120 Theme := TTheme(Themes.First); 107 with Themes.AddNew( 'Dark') do begin121 with Themes.AddNew(ThemeNameDark) do begin 108 122 ColorWindow := RGBToColor($20, $20, $20); 109 123 ColorWindowText := clWhite; … … 112 126 ColorControlSelected := RGBToColor(96, 125, 155); 113 127 end; 114 with Themes.AddNew( 'Light') do begin128 with Themes.AddNew(ThemeNameLight) do begin 115 129 ColorWindow := clWhite; 116 130 ColorWindowText := clBlack; … … 123 137 destructor TThemeManager.Destroy; 124 138 begin 125 Themes.Free;126 inherited Destroy;139 FreeAndNil(Themes); 140 inherited; 127 141 end; 128 142 … … 167 181 procedure TThemeManager.UseTheme(Form: TDpiForm); 168 182 begin 169 if not Used and (FTheme.Name = 'System') then Exit;183 if not Used and (FTheme.Name = ThemeNameSystem) then Exit; 170 184 ApplyTheme(Form); 171 185 Used := True; 172 186 end; 173 187 188 end. 174 189 175 end. -
branches/highdpi/Packages/Common/Threading.pas
r462 r463 1 unit UThreading; 2 3 {$mode delphi} 1 unit Threading; 4 2 5 3 interface 6 4 7 5 uses 8 UDpiControls, Classes, SysUtils, Forms, Contnrs, SyncObjs;6 UDpiControls, Classes, SysUtils, Forms, Generics.Collections, SyncObjs; 9 7 10 8 type 11 9 TExceptionEvent = procedure (Sender: TObject; E: Exception) of object; 12 10 TMethodCall = procedure of object; 13 14 11 15 12 { TVirtualThread } … … 22 19 function GetSuspended: Boolean; virtual; abstract; 23 20 function GetTerminated: Boolean; virtual; abstract; 24 function GetThreadId: Integer; virtual; abstract;21 function GetThreadId: TThreadID; virtual; abstract; 25 22 procedure SetFreeOnTerminate(const AValue: Boolean); virtual; abstract; 26 23 procedure SetPriority(const AValue: TThreadPriority); virtual; abstract; … … 42 39 property Terminated: Boolean read GetTerminated write SetTerminated; 43 40 property Finished: Boolean read GetFinished; 44 property ThreadId: Integerread GetThreadId;41 property ThreadId: TThreadID read GetThreadId; 45 42 end; 46 43 … … 68 65 function GetSuspended: Boolean; override; 69 66 function GetTerminated: Boolean; override; 70 function GetThreadId: Integer; override;67 function GetThreadId: TThreadID; override; 71 68 procedure SetFreeOnTerminate(const AValue: Boolean); override; 72 69 procedure SetPriority(const AValue: TThreadPriority); override; … … 102 99 { TThreadList } 103 100 104 TThreadList = class(TObjectList )105 function FindById(Id: Integer): TVirtualThread;101 TThreadList = class(TObjectList<TVirtualThread>) 102 function FindById(Id: TThreadID): TVirtualThread; 106 103 constructor Create; virtual; 107 104 end; … … 164 161 if MainThreadID = ThreadID then Method 165 162 else begin 166 Thread := ThreadList.FindById(ThreadID); 163 try 164 ThreadListLock.Acquire; 165 Thread := ThreadList.FindById(ThreadID); 166 finally 167 ThreadListLock.Release; 168 end; 167 169 if Assigned(Thread) then begin 168 170 Thread.Synchronize(Method); … … 173 175 { TThreadList } 174 176 175 function TThreadList.FindById(Id: Integer): TVirtualThread;177 function TThreadList.FindById(Id: TThreadID): TVirtualThread; 176 178 var 177 179 I: Integer; 178 180 begin 179 181 I := 0; 180 while (I < ThreadList.Count) and (T VirtualThread(ThreadList[I]).ThreadID <> Id) do182 while (I < ThreadList.Count) and (ThreadList[I].ThreadID <> Id) do 181 183 Inc(I); 182 if I < ThreadList.Count then Result := T VirtualThread(ThreadList[I])184 if I < ThreadList.Count then Result := ThreadList[I] 183 185 else Result := nil; 184 186 end; … … 233 235 end; 234 236 235 function TListedThread.GetThreadId: Integer;237 function TListedThread.GetThreadId: TThreadID; 236 238 begin 237 239 Result := FThread.ThreadID; … … 290 292 end; 291 293 FThread.Free; 292 inherited Destroy;294 inherited; 293 295 end; 294 296 … … 364 366 365 367 end. 366 -
branches/highdpi/Packages/Common/Translator.pas
r462 r463 1 unit UTranslator; 2 3 {$mode Delphi}{$H+} 1 unit Translator; 4 2 5 3 interface 6 4 7 5 uses 8 UDpiControls, Classes, SysUtils, Forms, ExtCtrls, Controls, Contnrs,LazFileUtils, LazUTF8,9 Translations, TypInfo, Dialogs, FileUtil, LCLProc, ULanguages, LCLType,10 LCLVersion ;6 UDpiControls, Classes, SysUtils, Forms, ExtCtrls, Controls, LazFileUtils, LazUTF8, 7 Translations, TypInfo, Dialogs, FileUtil, LCLProc, Languages, LCLType, 8 LCLVersion, Generics.Collections; 11 9 12 10 type 13 11 THandleStringEvent = function (AValue: string): string of object; 12 13 TPoFiles = class(TObjectList<TPOFile>) 14 end; 14 15 15 16 { TComponentExcludes } … … 24 25 { TComponentExcludesList } 25 26 26 TComponentExcludesList = class(TObjectList )27 TComponentExcludesList = class(TObjectList<TComponentExcludes>) 27 28 function FindByClassType(AClassType: TClass): TComponentExcludes; 28 29 procedure DumpToStrings(Strings: TStrings); … … 36 37 FOnAutomaticLanguage: THandleStringEvent; 37 38 FOnTranslate: TNotifyEvent; 38 FP OFilesFolder: string;39 FP OFiles: TObjectList; // TObjectList<TPOFile>;39 FPoFilesFolder: string; 40 FPoFiles: TPoFiles; 40 41 function GetLocale: string; 41 42 function GetLocaleShort: string; … … 50 51 public 51 52 ComponentExcludes: TComponentExcludesList; 52 Languages: TLanguage List;53 Languages: TLanguages; 53 54 procedure Translate; 54 procedure LanguageListToStrings(Strings: TStrings );55 procedure LanguageListToStrings(Strings: TStrings; WithCode: Boolean = True); 55 56 procedure TranslateResourceStrings(PoFileName: string); 56 57 procedure TranslateUnitResourceStrings(UnitName: string; PoFileName: string); … … 63 64 destructor Destroy; override; 64 65 published 65 property POFilesFolder: string read FP OFilesFolder write SetPOFilesFolder;66 property POFilesFolder: string read FPoFilesFolder write SetPOFilesFolder; 66 67 property Language: TLanguage read FLanguage write SetLanguage; 67 68 property OnTranslate: TNotifyEvent read FOnTranslate write FOnTranslate; … … 71 72 72 73 procedure Register; 74 73 75 74 76 implementation … … 117 119 destructor TComponentExcludes.Destroy; 118 120 begin 119 PropertyExcludes.Free;120 inherited Destroy;121 FreeAndNil(PropertyExcludes); 122 inherited; 121 123 end; 122 124 … … 128 130 I, J: Integer; 129 131 Po: TPoFile; 130 Item: TP OFileItem;132 Item: TPoFileItem; 131 133 begin 132 134 TranslateComponentRecursive(DpiApplication); … … 134 136 // Merge files to single translation file 135 137 try 136 Po := TP OFile.Create;137 for I := 0 to FP OFiles.Count - 1 do138 Po := TPoFile.Create; 139 for I := 0 to FPoFiles.Count - 1 do 138 140 with TPoFile(FPoFiles[I]) do 139 141 for J := 0 to Items.Count - 1 do … … 162 164 SearchMask: string; 163 165 begin 164 FP OFiles.Clear;166 FPoFiles.Clear; 165 167 if Assigned(FLanguage) then 166 168 try 167 169 LocaleShort := GetLocaleShort; 168 //ShowMessage(ExtractFileDir( DpiApplication.ExeName) +170 //ShowMessage(ExtractFileDir(Application.ExeName) + 169 171 // DirectorySeparator + 'Languages' + ' ' + '*.' + LocaleShort + '.po'); 170 172 SearchMask := '*'; … … 177 179 if FileExists(FileName) and ( 178 180 ((LocaleShort = '') and (Pos('.', FileName) = Pos('.po', FileName))) or 179 (LocaleShort <> '')) then FP OFiles.Add(TPOFile.Create(FileName));181 (LocaleShort <> '')) then FPoFiles.Add(TPOFile.Create(FileName)); 180 182 end; 181 183 finally … … 281 283 var 282 284 Item: TClass; 283 284 285 Excludes: TComponentExcludes; 285 286 begin … … 287 288 Item := Component.ClassType; 288 289 while Assigned(Item) do begin 289 //ShowMessage(Component.Name + ', ' + Component.ClassName + ', ' + Item.ClassName + ', ' + PropertyName);290 290 Excludes := ComponentExcludes.FindByClassType(Item.ClassType); 291 291 if Assigned(Excludes) then begin … … 301 301 function TTranslator.GetLangFileDir: string; 302 302 begin 303 Result := FP OFilesFolder;303 Result := FPoFilesFolder; 304 304 if Copy(Result, 1, 1) <> DirectorySeparator then 305 305 Result := ExtractFileDir(DpiApplication.ExeName) + … … 307 307 end; 308 308 309 procedure TTranslator.LanguageListToStrings(Strings: TStrings );309 procedure TTranslator.LanguageListToStrings(Strings: TStrings; WithCode: Boolean = True); 310 310 var 311 311 I: Integer; … … 313 313 begin 314 314 with Strings do begin 315 Clear; 316 for I := 0 to Languages.Count - 1 do 317 with TLanguage(Languages[I]) do 318 if Available then begin 319 ItemName := Name; 320 if Code <> '' then ItemName := ItemName + ' (' + Code + ')'; 321 AddObject(ItemName, Languages[I]); 322 end; 315 BeginUpdate; 316 try 317 Clear; 318 for I := 0 to Languages.Count - 1 do 319 with Languages[I] do 320 if Available then begin 321 ItemName := Name; 322 if WithCode and (Code <> '') then ItemName := ItemName + ' (' + Code + ')'; 323 AddObject(ItemName, Languages[I]); 324 end; 325 finally 326 EndUpdate; 327 end; 323 328 end; 324 329 end; … … 342 347 if Text <> '' then begin 343 348 for I := 0 to FPoFiles.Count - 1 do begin 344 Result := TPoFile(FP OFiles[I]).Translate(Identifier, Text);349 Result := TPoFile(FPoFiles[I]).Translate(Identifier, Text); 345 350 if Result <> Text then Break; 346 351 end; … … 369 374 begin 370 375 LangDir := GetLangFileDir; 371 TLanguage(Languages[0]).Available := True; // Automatic376 Languages.SearchByCode('').Available := True; // Automatic 372 377 373 378 for I := 1 to Languages.Count - 1 do 374 with TLanguage(Languages[I])do begin379 with Languages[I] do begin 375 380 Available := FileExists(LangDir + DirectorySeparator + ExtractFileNameOnly(DpiApplication.ExeName) + 376 381 '.' + Code + ExtensionSeparator + 'po') or (Code = 'en'); … … 381 386 begin 382 387 inherited; 383 FP OFiles := TObjectList.Create;388 FPoFiles := TPoFiles.Create; 384 389 ComponentExcludes := TComponentExcludesList.Create; 385 Languages := TLanguage List.Create;390 Languages := TLanguages.Create; 386 391 POFilesFolder := 'Languages'; 387 392 CheckLanguageFiles; … … 395 400 destructor TTranslator.Destroy; 396 401 begin 397 F POFiles.Free;398 Languages.Free;399 ComponentExcludes.Free;400 inherited Destroy;402 FreeAndNil(FPoFiles); 403 FreeAndNil(Languages); 404 FreeAndNil(ComponentExcludes); 405 inherited; 401 406 end; 402 407 … … 564 569 end; 565 570 566 567 571 end. 568 -
branches/highdpi/Packages/Common/URI.pas
r462 r463 1 unit U URI;1 unit URI; 2 2 3 3 // Date: 2011-04-04 4 5 {$mode delphi}6 4 7 5 interface … … 85 83 end; 86 84 85 87 86 implementation 88 87 … … 183 182 begin 184 183 Items.Free; 185 inherited Destroy;184 inherited; 186 185 end; 187 186 … … 232 231 begin 233 232 Path.Free; 234 inherited Destroy;233 inherited; 235 234 end; 236 235 … … 243 242 Fragment := TURI(Source).Fragment; 244 243 Query := TURI(Source).Query; 245 end else inherited Assign(Source);244 end else inherited; 246 245 end; 247 246 … … 291 290 destructor TURL.Destroy; 292 291 begin 293 inherited Destroy;292 inherited; 294 293 end; 295 294 … … 344 343 begin 345 344 Directory.Free; 346 inherited Destroy; 347 end; 348 345 inherited; 346 end; 349 347 350 348 end. 351 -
branches/highdpi/Packages/Common/XML.pas
r462 r463 1 unit UXMLUtils; 2 3 {$mode delphi} 1 unit XML; 4 2 5 3 interface … … 16 14 procedure WriteString(Node: TDOMNode; Name: string; Value: string); 17 15 procedure WriteDateTime(Node: TDOMNode; Name: string; Value: TDateTime); 16 procedure WriteDouble(Node: TDOMNode; Name: string; Value: Double); 18 17 function ReadInteger(Node: TDOMNode; Name: string; DefaultValue: Integer): Integer; 19 18 function ReadInt64(Node: TDOMNode; Name: string; DefaultValue: Int64): Int64; … … 21 20 function ReadString(Node: TDOMNode; Name: string; DefaultValue: string): string; 22 21 function ReadDateTime(Node: TDOMNode; Name: string; DefaultValue: TDateTime): TDateTime; 22 function ReadDouble(Node: TDOMNode; Name: string; DefaultValue: Double): Double; 23 23 procedure ReadXMLFileParser(out Doc: TXMLDocument; FileName: string); 24 24 25 25 26 26 implementation 27 28 function ReadDouble(Node: TDOMNode; Name: string; DefaultValue: Double): Double; 29 var 30 NewNode: TDOMNode; 31 begin 32 Result := DefaultValue; 33 NewNode := Node.FindNode(DOMString(Name)); 34 if Assigned(NewNode) then 35 Result := StrToFloat(string(NewNode.TextContent)); 36 end; 27 37 28 38 procedure ReadXMLFileParser(out Doc: TXMLDocument; FileName: string); … … 202 212 end; 203 213 214 procedure WriteDouble(Node: TDOMNode; Name: string; Value: Double); 215 var 216 NewNode: TDOMNode; 217 begin 218 NewNode := Node.OwnerDocument.CreateElement(DOMString(Name)); 219 NewNode.TextContent := DOMString(FloatToStr(Value)); 220 Node.AppendChild(NewNode); 221 end; 222 204 223 function ReadInteger(Node: TDOMNode; Name: string; DefaultValue: Integer): Integer; 205 224 var … … 254 273 255 274 end. 256 -
branches/highdpi/Packages/DpiControls/UDpiControls.pas
r412 r463 175 175 function GetShowHint: Boolean; 176 176 function GetVisible: Boolean; 177 function GetWindowProc: TWndMethod; 177 178 function IsAnchorsStored: Boolean; 178 179 procedure SetAlign(AValue: TAlign); … … 207 208 procedure MouseLeaveHandler(Sender: TObject); virtual; 208 209 procedure MouseEnterHandler(Sender: TObject); virtual; 210 procedure SetWindowProc(AValue: TWndMethod); 209 211 protected 210 212 procedure DoBorderSpacingChange(Sender: TObject; InnerSpaceChanged: Boolean); virtual; … … 255 257 property Anchors: TAnchors read GetAnchors write SetAnchors stored IsAnchorsStored default [akLeft, akTop]; 256 258 property BorderSpacing: TDpiControlBorderSpacing read FBorderSpacing write SetBorderSpacing; 259 property WindowProc: TWndMethod read GetWindowProc write SetWindowProc; 257 260 published 258 261 property AutoSize: Boolean read GetAutoSize write SetAutoSize default False; … … 373 376 destructor Destroy; override; 374 377 function GetNativePen: TPen; 378 procedure Assign(Source: TDpiPen); 375 379 property NativePen: TPen read FNativePen write SetNativePen; 376 380 published … … 395 399 constructor Create; 396 400 destructor Destroy; override; 401 procedure Assign(Source: TDpiBrush); 397 402 property NativeBrush: TBrush read FNativeBrush write SetNativeBrush; 398 403 published … … 422 427 procedure SetNativeCanvas(AValue: TCanvas); 423 428 protected 429 procedure DoLine(X1, Y1, X2, Y2: Integer); virtual; 430 procedure DoTextOut(X, Y: Integer; Text: string); virtual; 431 procedure DoRectangle(const Bounds: TRect); virtual; 432 procedure DoRectangleFill(const Bounds: TRect); virtual; 433 procedure DoPolygon(const Points: array of TPoint); virtual; 434 procedure CreateHandle; virtual; 435 procedure DoEllipse(const Bounds: TRect); virtual; 436 procedure DoMoveTo(X, Y: Integer); virtual; 437 procedure DoLineTo(X, Y: Integer); virtual; 438 procedure DoPolyline(const Points: array of TPoint); virtual; 439 procedure DoPolyBezier(Points: PPoint; NumPts: Integer; 440 Filled: Boolean = False; Continuous: Boolean = False); virtual; 424 441 procedure SetHeight(AValue: Integer); virtual; 425 442 procedure SetWidth(AValue: Integer); virtual; … … 429 446 public 430 447 property NativeCanvas: TCanvas read FNativeCanvas write SetNativeCanvas; 448 procedure RoundRect(const Rect: TRect; RX, RY: Integer); 449 procedure RoundRect(X1, Y1, X2, Y2: Integer; RX,RY: Integer); overload; virtual; 450 procedure Polygon(const Points: array of TPoint; Winding: Boolean; 451 StartIndex: Integer = 0; NumPts: Integer = -1); 452 procedure Polygon(Points: PPoint; NumPts: Integer; Winding: Boolean = False); virtual; 453 procedure Polygon(const Points: array of TPoint); 454 procedure PolyBezier(const Points: array of TPoint; 455 Filled: Boolean = False; Continuous: boolean = True); 456 procedure PolyBezier(Points: PPoint; NumPts: Integer; 457 Filled: Boolean = False; Continuous: Boolean = True); virtual; 458 procedure Polyline(const Points: array of TPoint); 459 procedure Polyline(Points: PPoint; NumPts: Integer); virtual; 460 procedure Ellipse(x1, y1, x2, y2: Integer); virtual; 461 procedure Ellipse(const ARect: TRect); virtual; 462 procedure StretchDraw(const DestRect: TRect; SrcGraphic: TGraphic); virtual; 463 procedure Pie(EllipseX1, EllipseY1, EllipseX2, EllipseY2, 464 StartX, StartY, EndX, EndY: Integer); virtual; 431 465 procedure StretchDraw(const DestRect: TRect; SrcGraphic: TDpiGraphic); virtual; 432 466 procedure FrameRect(Rect: TRect); 433 467 procedure Rectangle(X1, Y1, X2, Y2: Integer); overload; 434 468 procedure Rectangle(const ARect: TRect); overload; 435 function TextWidth( Text: string): Integer;436 function TextHeight( Text: string): Integer;437 function TextExtent( Text: string): TSize;469 function TextWidth(const Text: string): Integer; 470 function TextHeight(const Text: string): Integer; 471 function TextExtent(const Text: string): TSize; virtual; 438 472 procedure TextOut(X, Y: Integer; const Text: string); virtual; 439 473 procedure TextRect(ARect: TRect; X, Y: Integer; Text: string); 440 474 procedure MoveTo(X, Y: Integer); 441 475 procedure LineTo(X, Y: Integer); 476 procedure Line(const p1, p2: TPoint); 442 477 procedure FillRect(const ARect: TRect); virtual; 443 478 procedure FillRect(X1, Y1, X2, Y2: Integer); … … 598 633 function GetRestoredTop: Integer; 599 634 function GetRestoredWidth: Integer; 635 function GetShowInTaskbar: TShowInTaskbar; 600 636 function GetWindowState: TWindowState; 601 637 procedure SetBorderIcons(AValue: TBorderIcons); … … 615 651 procedure FormMessageHandler(var TheMessage: TLMessage); 616 652 procedure SetPosition(AValue: TPosition); 653 procedure SetShowInTaskBar(AValue: TShowInTaskbar); 617 654 procedure SetWindowState(AValue: TWindowState); 618 655 procedure ActivateHandler(Sender: TObject); … … 667 704 property OnMouseDown; 668 705 property OnMouseMove; 706 property ShowInTaskBar: TShowInTaskbar read GetShowInTaskbar write SetShowInTaskBar 707 default stDefault; 669 708 end; 670 709 … … 873 912 end; 874 913 914 TDpiCustomListView = class(TDpiWinControl) 915 916 end; 917 918 TDpiLVCustomDrawItemEvent = procedure(Sender: TDpiCustomListView; Item: TListItem; 919 State: TCustomDrawState; var DefaultDraw: Boolean) of object; 920 875 921 { TDpiListView } 876 922 877 TDpiListView = class(TDpi WinControl)923 TDpiListView = class(TDpiCustomListView) 878 924 private 925 FOnCustomDrawItem: TDpiLVCustomDrawItemEvent; 879 926 NativeListView: TListView; 927 function GetCanvas: TCanvas; 880 928 function GetColumns: TListColumns; 881 929 function GetItems: TListItems; 930 function GetOnChange: TLVChangeEvent; 931 function GetOnColumnClick: TLVColumnClickEvent; 932 function GetOnCustomDrawItem: TDpiLVCustomDrawItemEvent; 933 function GetProperty(AIndex: Integer): Boolean; 934 function GetViewStyle: TViewStyle; 882 935 procedure SetColumns(AValue: TListColumns); 883 936 procedure SetItems(AValue: TListItems); 937 procedure SetOnChange(AValue: TLVChangeEvent); 938 procedure SetOnColumnClick(AValue: TLVColumnClickEvent); 939 procedure SetOnCustomDrawItem(AValue: TDpiLVCustomDrawItemEvent); 940 procedure SetProperty(AIndex: Integer; AValue: Boolean); 941 procedure SetViewStyle(AValue: TViewStyle); 942 procedure DoCustomDrawItem(Sender: TCustomListView; Item: TListItem; 943 State: TCustomDrawState; var DefaultDraw: Boolean); 884 944 public 945 function GetItemAt(x,y: integer): TListItem; 885 946 function GetNativeListView: TListView; 886 947 constructor Create(TheOwner: TComponent); override; … … 888 949 property Columns: TListColumns read GetColumns write SetColumns; 889 950 property Items: TListItems read GetItems write SetItems; 951 property Canvas: TCanvas read GetCanvas; 952 property Checkboxes: Boolean index Ord(lvpCheckboxes) read GetProperty write SetProperty default False; 890 953 published 954 property OnColumnClick: TLVColumnClickEvent read GetOnColumnClick 955 write SetOnColumnClick; 956 property OnCustomDrawItem: TDpiLVCustomDrawItemEvent read GetOnCustomDrawItem 957 write SetOnCustomDrawItem; 958 property ViewStyle: TViewStyle read GetViewStyle write SetViewStyle default vsList; 959 property OnChange: TLVChangeEvent read GetOnChange write SetOnChange; 891 960 end; 892 961 … … 1100 1169 NativeStringGrid: TStringGrid; 1101 1170 function DefaultRowHeightIsStored: Boolean; 1171 function GetCells(ACol, ARow: Integer): string; 1172 function GetColCount: Integer; 1173 function GetColumns: TGridColumns; 1102 1174 function GetDefRowHeight: Integer; 1175 function GetEditor: TWinControl; 1176 function GetFixedCols: Integer; 1177 function GetFixedRows: Integer; 1178 function GetOptions: TGridOptions; 1179 function GetRowCount: Integer; 1180 function GetScrollBars: TScrollStyle; 1181 function GetSelection: TGridRect; 1182 function IsColumnsStored: Boolean; 1183 procedure SetCells(ACol, ARow: Integer; AValue: string); 1184 procedure SetColCount(AValue: Integer); 1185 procedure SetColumns(AValue: TGridColumns); 1103 1186 procedure SetDefRowHeight(AValue: Integer); 1187 procedure SetEditor(AValue: TWinControl); 1188 procedure SetFixedCols(AValue: Integer); 1189 procedure SetFixedRows(AValue: Integer); 1190 procedure SetOptions(AValue: TGridOptions); 1191 procedure SetRowCount(AValue: Integer); 1192 procedure SetScrollBars(AValue: TScrollStyle); 1193 procedure SetSelection(AValue: TGridRect); 1104 1194 public 1105 1195 function GetNativeStringGrid: TStringGrid; 1196 function CellRect(ACol, ARow: Integer): TRect; 1106 1197 constructor Create(TheOwner: TComponent); override; 1107 1198 destructor Destroy; override; 1199 property Selection: TGridRect read GetSelection write SetSelection; 1200 property Cells[ACol, ARow: Integer]: string read GetCells write SetCells; 1108 1201 published 1109 1202 property DefaultRowHeight: Integer read GetDefRowHeight write SetDefRowHeight stored DefaultRowHeightIsStored; 1203 property ScrollBars: TScrollStyle read GetScrollBars write SetScrollBars default ssAutoBoth; 1204 property FixedCols: Integer read GetFixedCols write SetFixedCols default 1; 1205 property FixedRows: Integer read GetFixedRows write SetFixedRows default 1; 1206 property RowCount: Integer read GetRowCount write SetRowCount default 5; 1207 property ColCount: Integer read GetColCount write SetColCount default 5; 1208 property Options: TGridOptions read GetOptions write SetOptions default DefaultGridOptions; 1209 property Columns: TGridColumns read GetColumns write SetColumns stored IsColumnsStored; 1210 property Editor: TWinControl read GetEditor write SetEditor; 1110 1211 end; 1111 1212 … … 1193 1294 function GetExeName: string; 1194 1295 function GetShowMainForm: Boolean; 1296 function GetTaskBarBehavior: TTaskBarBehavior; 1195 1297 function GetTitle: string; 1196 1298 procedure SetMainForm(AValue: TDpiForm); 1197 1299 function GetMainForm: TDpiForm; 1198 1300 procedure SetShowMainForm(AValue: Boolean); 1301 procedure SetTaskBarBehavior(AValue: TTaskBarBehavior); 1199 1302 procedure SetTitle(AValue: string); 1200 1303 protected … … 1216 1319 property Active: Boolean read GetActive; 1217 1320 property ExeName: string read GetExeName; 1321 property TaskBarBehavior: TTaskBarBehavior read GetTaskBarBehavior write SetTaskBarBehavior; 1218 1322 end; 1219 1323 … … 1276 1380 property Count: Integer read GetCount; 1277 1381 procedure Clear; 1382 procedure Click; virtual; 1278 1383 published 1279 1384 property RadioItem: Boolean read GetRadioItem write SetRadioItem default False; … … 1356 1461 SDpiFormTitle = 'DpiForm form'; 1357 1462 SDpiFormDescription = 'DPI aware form'; 1463 SNotImplemented = 'Not implemented'; 1358 1464 1359 1465 procedure Register; … … 1971 2077 function TDpiStringGrid.DefaultRowHeightIsStored: Boolean; 1972 2078 begin 1973 Result := GetDefRowHeight>=0; 2079 Result := GetDefRowHeight >= 0; 2080 end; 2081 2082 function TDpiStringGrid.GetCells(ACol, ARow: Integer): string; 2083 begin 2084 Result := GetNativeStringGrid.Cells[ACol, ARow]; 2085 end; 2086 2087 function TDpiStringGrid.GetColCount: Integer; 2088 begin 2089 Result := GetNativeStringGrid.ColCount; 2090 end; 2091 2092 function TDpiStringGrid.GetColumns: TGridColumns; 2093 begin 2094 Result := GetNativeStringGrid.Columns; 1974 2095 end; 1975 2096 … … 1979 2100 end; 1980 2101 2102 function TDpiStringGrid.GetEditor: TWinControl; 2103 begin 2104 Result := GetNativeStringGrid.Editor; 2105 end; 2106 2107 function TDpiStringGrid.GetFixedCols: Integer; 2108 begin 2109 Result := GetNativeStringGrid.FixedCols; 2110 end; 2111 2112 function TDpiStringGrid.GetFixedRows: Integer; 2113 begin 2114 Result := GetNativeStringGrid.FixedRows; 2115 end; 2116 2117 function TDpiStringGrid.GetOptions: TGridOptions; 2118 begin 2119 Result := GetNativeStringGrid.Options; 2120 end; 2121 2122 function TDpiStringGrid.GetRowCount: Integer; 2123 begin 2124 Result := GetNativeStringGrid.RowCount; 2125 end; 2126 2127 function TDpiStringGrid.GetScrollBars: TScrollStyle; 2128 begin 2129 Result := GetNativeStringGrid.ScrollBars; 2130 end; 2131 2132 function TDpiStringGrid.GetSelection: TGridRect; 2133 begin 2134 Result := GetNativeStringGrid.Selection; 2135 end; 2136 2137 function TDpiStringGrid.IsColumnsStored: Boolean; 2138 begin 2139 Result := GetNativeStringGrid.Columns.Enabled; 2140 end; 2141 2142 procedure TDpiStringGrid.SetCells(ACol, ARow: Integer; AValue: string); 2143 begin 2144 GetNativeStringGrid.Cells[ACol, ARow] := AValue; 2145 end; 2146 2147 procedure TDpiStringGrid.SetColCount(AValue: Integer); 2148 begin 2149 GetNativeStringGrid.ColCount := AValue; 2150 end; 2151 2152 procedure TDpiStringGrid.SetColumns(AValue: TGridColumns); 2153 begin 2154 GetNativeStringGrid.Columns := AValue; 2155 end; 2156 1981 2157 procedure TDpiStringGrid.SetDefRowHeight(AValue: Integer); 1982 2158 begin 1983 2159 GetNativeStringGrid.DefaultRowHeight := AValue; 2160 end; 2161 2162 procedure TDpiStringGrid.SetEditor(AValue: TWinControl); 2163 begin 2164 GetNativeStringGrid.Editor := AValue; 2165 end; 2166 2167 procedure TDpiStringGrid.SetFixedCols(AValue: Integer); 2168 begin 2169 GetNativeStringGrid.FixedCols := AValue; 2170 end; 2171 2172 procedure TDpiStringGrid.SetFixedRows(AValue: Integer); 2173 begin 2174 GetNativeStringGrid.FixedRows := AValue; 2175 end; 2176 2177 procedure TDpiStringGrid.SetOptions(AValue: TGridOptions); 2178 begin 2179 GetNativeStringGrid.Options := AValue; 2180 end; 2181 2182 procedure TDpiStringGrid.SetRowCount(AValue: Integer); 2183 begin 2184 GetNativeStringGrid.RowCount := AValue; 2185 end; 2186 2187 procedure TDpiStringGrid.SetScrollBars(AValue: TScrollStyle); 2188 begin 2189 GetNativeStringGrid.ScrollBars := AValue; 2190 end; 2191 2192 procedure TDpiStringGrid.SetSelection(AValue: TGridRect); 2193 begin 2194 GetNativeStringGrid.Selection := AValue; 1984 2195 end; 1985 2196 … … 1990 2201 end; 1991 2202 2203 function TDpiStringGrid.CellRect(ACol, ARow: Integer): TRect; 2204 begin 2205 Result := GetNativeStringGrid.CellRect(ACol, ARow); 2206 end; 2207 1992 2208 constructor TDpiStringGrid.Create(TheOwner: TComponent); 1993 2209 begin … … 2008 2224 end; 2009 2225 2226 function TDpiListView.GetOnChange: TLVChangeEvent; 2227 begin 2228 Result := GetNativeListView.OnChange; 2229 end; 2230 2231 function TDpiListView.GetOnColumnClick: TLVColumnClickEvent; 2232 begin 2233 Result := GetNativeListView.OnColumnClick; 2234 end; 2235 2236 function TDpiListView.GetOnCustomDrawItem: TDpiLVCustomDrawItemEvent; 2237 begin 2238 Result := FOnCustomDrawItem; 2239 end; 2240 2241 function TDpiListView.GetProperty(AIndex: Integer): Boolean; 2242 begin 2243 Result := GetNativeListView.Checkboxes; 2244 end; 2245 2246 function TDpiListView.GetViewStyle: TViewStyle; 2247 begin 2248 Result := GetNativeListView.ViewStyle; 2249 end; 2250 2010 2251 function TDpiListView.GetColumns: TListColumns; 2011 2252 begin 2012 Result := NativeListView.Columns; 2253 Result := GetNativeListView.Columns; 2254 end; 2255 2256 function TDpiListView.GetCanvas: TCanvas; 2257 begin 2258 Result := GetNativeListView.Canvas; 2013 2259 end; 2014 2260 2015 2261 procedure TDpiListView.SetColumns(AValue: TListColumns); 2016 2262 begin 2017 NativeListView.Columns := AValue;2263 GetNativeListView.Columns := AValue; 2018 2264 end; 2019 2265 … … 2023 2269 end; 2024 2270 2271 procedure TDpiListView.SetOnChange(AValue: TLVChangeEvent); 2272 begin 2273 GetNativeListView.OnChange := AValue; 2274 end; 2275 2276 procedure TDpiListView.SetOnColumnClick(AValue: TLVColumnClickEvent); 2277 begin 2278 GetNativeListView.OnColumnClick := AValue; 2279 end; 2280 2281 procedure TDpiListView.SetOnCustomDrawItem(AValue: TDpiLVCustomDrawItemEvent); 2282 begin 2283 FOnCustomDrawItem := AValue; 2284 end; 2285 2286 procedure TDpiListView.SetProperty(AIndex: Integer; AValue: Boolean); 2287 begin 2288 GetNativeListView.Checkboxes := AValue; 2289 end; 2290 2291 procedure TDpiListView.SetViewStyle(AValue: TViewStyle); 2292 begin 2293 GetNativeListView.ViewStyle := AValue; 2294 end; 2295 2296 procedure TDpiListView.DoCustomDrawItem(Sender: TCustomListView; Item: TListItem; 2297 State: TCustomDrawState; var DefaultDraw: Boolean); 2298 begin 2299 if Assigned(FOnCustomDrawItem) then 2300 FOnCustomDrawItem(Self, Item, State, DefaultDraw); 2301 end; 2302 2303 function TDpiListView.GetItemAt(x, y: integer): TListItem; 2304 begin 2305 Result := GetNativeListView.GetItemAt(X, Y); 2306 end; 2307 2025 2308 function TDpiListView.GetNativeListView: TListView; 2026 2309 begin 2027 if not Assigned(NativeListView) then NativeListView := TListView.Create(nil); 2028 Result := NativeListView; 2310 if not Assigned(NativeListView) then begin 2311 NativeListView := TListView.Create(nil); 2312 NativeListView.OnCustomDrawItem := @DoCustomDrawItem; 2313 end; 2314 Result := NativeListView; 2029 2315 end; 2030 2316 … … 2101 2387 end; 2102 2388 2389 procedure TDpiPen.Assign(Source: TDpiPen); 2390 begin 2391 FWidth := Source.FWidth; 2392 GetNativePen.Assign(Source.GetNativePen); 2393 end; 2394 2103 2395 { TDpiBrush } 2104 2396 … … 2146 2438 if FNativeBrushFree then FreeAndNil(FNativeBrush); 2147 2439 inherited; 2440 end; 2441 2442 procedure TDpiBrush.Assign(Source: TDpiBrush); 2443 begin 2444 GetNativeBrush.Assign(Source.GetNativeBrush); 2148 2445 end; 2149 2446 … … 2472 2769 begin 2473 2770 GetNativeMenuItem.Clear; 2771 end; 2772 2773 procedure TDpiMenuItem.Click; 2774 begin 2775 GetNativeMenuItem.Click; 2474 2776 end; 2475 2777 … … 2679 2981 end; 2680 2982 2983 function TDpiApplication.GetTaskBarBehavior: TTaskBarBehavior; 2984 begin 2985 Result := GetNativeApplication.TaskBarBehavior; 2986 end; 2987 2681 2988 function TDpiApplication.GetActive: Boolean; 2682 2989 begin 2683 Result := Application.Active;2990 Result := GetNativeApplication.Active; 2684 2991 end; 2685 2992 … … 2697 3004 begin 2698 3005 GetNativeApplication.ShowMainForm := AValue; 3006 end; 3007 3008 procedure TDpiApplication.SetTaskBarBehavior(AValue: TTaskBarBehavior); 3009 begin 3010 GetNativeApplication.TaskBarBehavior := AValue; 2699 3011 end; 2700 3012 … … 3526 3838 end; 3527 3839 3840 procedure TDpiCanvas.DoLine(X1, Y1, X2, Y2: Integer); 3841 begin 3842 raise ENotImplemented.Create(SNotImplemented); 3843 end; 3844 3845 procedure TDpiCanvas.DoTextOut(X, Y: Integer; Text: string); 3846 begin 3847 raise ENotImplemented.Create(SNotImplemented); 3848 end; 3849 3850 procedure TDpiCanvas.DoRectangle(const Bounds: TRect); 3851 begin 3852 raise ENotImplemented.Create(SNotImplemented); 3853 end; 3854 3855 procedure TDpiCanvas.DoRectangleFill(const Bounds: TRect); 3856 begin 3857 raise ENotImplemented.Create(SNotImplemented); 3858 end; 3859 3860 procedure TDpiCanvas.DoPolygon(const Points: array of TPoint); 3861 begin 3862 raise ENotImplemented.Create(SNotImplemented); 3863 end; 3864 3865 procedure TDpiCanvas.CreateHandle; 3866 begin 3867 raise ENotImplemented.Create(SNotImplemented); 3868 end; 3869 3870 procedure TDpiCanvas.DoEllipse(const Bounds: TRect); 3871 begin 3872 raise ENotImplemented.Create(SNotImplemented); 3873 end; 3874 3875 procedure TDpiCanvas.DoMoveTo(X, Y: Integer); 3876 begin 3877 raise ENotImplemented.Create(SNotImplemented); 3878 end; 3879 3880 procedure TDpiCanvas.DoLineTo(X, Y: Integer); 3881 begin 3882 raise ENotImplemented.Create(SNotImplemented); 3883 end; 3884 3885 procedure TDpiCanvas.DoPolyline(const Points: array of TPoint); 3886 begin 3887 raise ENotImplemented.Create(SNotImplemented); 3888 end; 3889 3890 procedure TDpiCanvas.DoPolyBezier(Points: PPoint; NumPts: Integer; 3891 Filled: Boolean; Continuous: Boolean); 3892 begin 3893 raise ENotImplemented.Create(SNotImplemented); 3894 end; 3895 3528 3896 function TDpiCanvas.GetNativeCanvas: TCanvas; 3529 3897 begin 3530 3898 Result := NativeCanvas; 3899 end; 3900 3901 procedure TDpiCanvas.RoundRect(const Rect: TRect; RX, RY: Integer); 3902 begin 3903 GetNativeCanvas.RoundRect(Rect, RX, RY); 3904 end; 3905 3906 procedure TDpiCanvas.RoundRect(X1, Y1, X2, Y2: Integer; RX, RY: Integer); 3907 begin 3908 GetNativeCanvas.RoundRect(X1, Y1, X2, Y2, RX, RY); 3909 end; 3910 3911 procedure TDpiCanvas.Polygon(const Points: array of TPoint; Winding: Boolean; 3912 StartIndex: Integer; NumPts: Integer); 3913 begin 3914 GetNativeCanvas.Polygon(Points, Winding, StartIndex, NumPts); 3915 end; 3916 3917 procedure TDpiCanvas.Polygon(Points: PPoint; NumPts: Integer; Winding: Boolean); 3918 begin 3919 GetNativeCanvas.Polygon(Points, NumPts, Winding); 3920 end; 3921 3922 procedure TDpiCanvas.Polygon(const Points: array of TPoint); 3923 begin 3924 GetNativeCanvas.Polygon(Points); 3925 end; 3926 3927 procedure TDpiCanvas.PolyBezier(const Points: array of TPoint; Filled: Boolean; 3928 Continuous: boolean); 3929 begin 3930 GetNativeCanvas.Polyline(Points); 3931 end; 3932 3933 procedure TDpiCanvas.PolyBezier(Points: PPoint; NumPts: Integer; 3934 Filled: Boolean; Continuous: Boolean); 3935 begin 3936 GetNativeCanvas.PolyBezier(Points, NumPts, Filled, Continuous); 3937 end; 3938 3939 procedure TDpiCanvas.Polyline(const Points: array of TPoint); 3940 begin 3941 GetNativeCanvas.Polyline(Points); 3942 end; 3943 3944 procedure TDpiCanvas.Polyline(Points: PPoint; NumPts: Integer); 3945 begin 3946 GetNativeCanvas.Polyline(Points, NumPts); 3947 end; 3948 3949 procedure TDpiCanvas.Ellipse(x1, y1, x2, y2: Integer); 3950 begin 3951 GetNativeCanvas.Ellipse(X1, Y1, X2, Y2); 3952 end; 3953 3954 procedure TDpiCanvas.Ellipse(const ARect: TRect); 3955 begin 3956 Ellipse(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom); 3957 end; 3958 3959 procedure TDpiCanvas.StretchDraw(const DestRect: TRect; SrcGraphic: TGraphic); 3960 begin 3961 GetNativeCanvas.StretchDraw(DestRect, SrcGraphic); 3962 end; 3963 3964 procedure TDpiCanvas.Pie(EllipseX1, EllipseY1, EllipseX2, EllipseY2, StartX, 3965 StartY, EndX, EndY: Integer); 3966 begin 3967 GetNativeCanvas.Pie(EllipseX1, EllipseY1, EllipseX2, EllipseY2, StartX, StartY, 3968 EndX, EndY); 3531 3969 end; 3532 3970 … … 3552 3990 end; 3553 3991 3554 function TDpiCanvas.TextWidth( Text: string): Integer;3992 function TDpiCanvas.TextWidth(const Text: string): Integer; 3555 3993 begin 3556 3994 Result := ScaleFromNative(GetNativeCanvas.TextWidth(Text)); 3557 3995 end; 3558 3996 3559 function TDpiCanvas.TextHeight( Text: string): Integer;3997 function TDpiCanvas.TextHeight(const Text: string): Integer; 3560 3998 begin 3561 3999 Result := ScaleFromNative(GetNativeCanvas.TextHeight(Text)); 3562 4000 end; 3563 4001 3564 function TDpiCanvas.TextExtent( Text: string): TSize;4002 function TDpiCanvas.TextExtent(const Text: string): TSize; 3565 4003 begin 3566 4004 Result := ScaleSizeFromNative(GetNativeCanvas.TextExtent(Text)); … … 3585 4023 begin 3586 4024 GetNativeCanvas.LineTo(ScaleToNative(X), ScaleToNative(Y)); 4025 end; 4026 4027 procedure TDpiCanvas.Line(const p1, p2: TPoint); 4028 begin 4029 GetNativeCanvas.Line(P1, P2); 3587 4030 end; 3588 4031 … … 4139 4582 FreeAndNil(FForms); 4140 4583 FreeAndNil(FPrevActiveForms); 4141 inherited Destroy;4584 inherited; 4142 4585 end; 4143 4586 … … 4256 4699 MouseEnter; 4257 4700 if Assigned(FOnMouseEnter) then FOnMouseEnter(Self); 4701 end; 4702 4703 procedure TDpiControl.SetWindowProc(AValue: TWndMethod); 4704 begin 4705 GetNativeControl.WindowProc := AValue; 4258 4706 end; 4259 4707 … … 4522 4970 end; 4523 4971 4972 function TDpiControl.GetWindowProc: TWndMethod; 4973 begin 4974 Result := GetNativeControl.WindowProc; 4975 end; 4976 4524 4977 function TDpiControl.IsAnchorsStored: Boolean; 4525 4978 begin … … 4791 5244 end; 4792 5245 5246 function TDpiForm.GetShowInTaskbar: TShowInTaskbar; 5247 begin 5248 Result := GetNativeForm.ShowInTaskBar; 5249 end; 5250 4793 5251 function TDpiForm.GetWindowState: TWindowState; 4794 5252 begin … … 4875 5333 begin 4876 5334 GetNativeForm.Position := AValue; 5335 end; 5336 5337 procedure TDpiForm.SetShowInTaskBar(AValue: TShowInTaskbar); 5338 begin 5339 GetNativeForm.ShowInTaskBar := AValue; 4877 5340 end; 4878 5341
Note:
See TracChangeset
for help on using the changeset viewer.