Changeset 537
- Timestamp:
- Jun 23, 2019, 12:36:19 AM (5 years ago)
- Location:
- DpiControls
- Files:
-
- 6 edited
Legend:
- Unmodified
- Added
- Removed
-
DpiControls/Demo/DpiComponentsDemo.lpr
r534 r537 8 8 {$ENDIF}{$ENDIF} 9 9 Interfaces, // this includes the LCL widgetset 10 Forms, UFormMain, UDpiFormMain 10 Forms, UFormMain, UDpiFormMain, SysUtils 11 11 { you can add units after this }; 12 12 13 13 {$R *.res} 14 14 15 {$if declared(UseHeapTrace)} 16 const 17 HeapTraceLog = 'heaptrclog.trc'; 18 {$ENDIF} 19 15 20 begin 21 {$if declared(UseHeapTrace)} 22 // Heap trace 23 DeleteFile(ExtractFilePath(ParamStr(0)) + HeapTraceLog); 24 SetHeapTraceOutput(ExtractFilePath(ParamStr(0)) + HeapTraceLog); 25 {$ENDIF} 26 16 27 RequireDerivedFormResource:=True; 17 28 Application.Scaled:=True; -
DpiControls/Demo/UDpiFormMain.lfm
r535 r537 2 2 Top = 504 3 3 Left = 865 4 Width = 05 Height = 04 Width = 1 5 Height = 1 6 6 Visible = True 7 7 Enabled = True 8 8 ShowHint = False 9 Font.Color = clDefault 10 Font.PixelsPerInch = 144 11 Align = alNone 12 Color = clDefault 13 DesignTimePPI = 96 9 14 BorderStyle = Controls 15 BorderIcons = [biSystemMenu, biMinimize, biMaximize] 10 16 OnCreate = DpiFormMainCreate 17 OnDestroy = DpiFormMainDestroy 11 18 object DpiPaintBox1: TDpiPaintBox 12 Top = 16113 Left = 12419 Top = 248 20 Left = 88 14 21 Width = 100 15 22 Height = 100 … … 17 24 Enabled = True 18 25 ShowHint = False 19 OnPaint = DpiPaintBox1Paint 20 left = 88 21 top = 248 26 Font.Color = clDefault 27 Font.Name = 'jjjdefault' 28 Font.PixelsPerInch = 144 29 Align = alNone 30 Color = clDefault 22 31 end 23 32 end -
DpiControls/Demo/UDpiFormMain.pas
r535 r537 16 16 procedure DpiButton1Click(Sender: TObject); 17 17 procedure DpiFormMainCreate(Sender: TObject); 18 procedure DpiFormMainDestroy(Sender: TObject); 18 19 procedure DpiPaintBox1Paint(Sender: TObject); 19 20 private 21 Button: TDpiButton; 22 Image: TDpiImage; 23 ListBox: TDpiListBox; 24 PaintBox: TDpiPaintBox; 20 25 public 21 26 … … 33 38 procedure TDpiFormMain.DpiFormMainCreate(Sender: TObject); 34 39 var 35 Button: TDpiButton;36 Image: TDpiImage;37 ListBox: TDpiListBox;38 40 I: Integer; 39 PaintBox: TDpiPaintBox;40 41 begin 41 42 Button := TDpiButton.Create(DpiFormMain); … … 65 66 end; 66 67 68 procedure TDpiFormMain.DpiFormMainDestroy(Sender: TObject); 69 begin 70 FreeAndNil(Button); 71 FreeAndNil(Image); 72 FreeAndNil(ListBox); 73 end; 74 67 75 procedure TDpiFormMain.DpiPaintBox1Paint(Sender: TObject); 68 76 begin -
DpiControls/Demo/UFormMain.lfm
r535 r537 8 8 ClientWidth = 472 9 9 DesignTimePPI = 144 10 OnDestroy = FormDestroy 10 11 OnShow = FormShow 11 12 LCLVersion = '2.0.2.0' -
DpiControls/Demo/UFormMain.pas
r535 r537 19 19 TrackBar1: TTrackBar; 20 20 procedure ButtonNewDpiFormClick(Sender: TObject); 21 procedure FormDestroy(Sender: TObject); 21 22 procedure FormShow(Sender: TObject); 22 23 procedure Timer1Timer(Sender: TObject); 23 24 procedure TrackBar1Change(Sender: TObject); 24 25 private 25 26 DpiForm: TDpiForm; 26 27 public 27 28 Redraw: Boolean; … … 51 52 52 53 procedure TFormMain.ButtonNewDpiFormClick(Sender: TObject); 53 var54 DpiForm: TDpiForm;55 54 begin 56 55 DpiForm := TDpiFormMain.Create(nil); … … 59 58 DpiForm.Show; 60 59 DpiScreen.Forms.Add(DpiForm); 60 end; 61 62 procedure TFormMain.FormDestroy(Sender: TObject); 63 begin 64 FreeAndNil(DpiForm); 61 65 end; 62 66 -
DpiControls/UDpiControls.pas
r536 r537 8 8 Classes, SysUtils, LCLProc, LResources, Forms, FormEditingIntf, ProjectIntf, 9 9 Controls, StdCtrls, fgl, Graphics, ComCtrls, ExtCtrls, LCLType, GraphType, 10 Types ;10 Types, CustApp, LMessages, LCLIntf; 11 11 12 12 type 13 { TDpiFormFileDesc } 13 TMessageEvent = procedure (var TheMessage : TLMessage) of object; 14 15 { TFormEx } 16 17 TFormEx = class(TForm) 18 private 19 FOnMessage: TMessageEvent; 20 protected 21 procedure WndProc(var TheMessage : TLMessage); override; 22 property OnMessage: TMessageEvent read FOnMessage write FOnMessage; 23 end; 24 25 { TGraphicControlEx } 26 27 TGraphicControlEx = class(TGraphicControl) 28 public 29 property OnPaint; 30 property OnMouseDown; 31 property OnMouseUp; 32 property OnMouseMove; 33 procedure Paint; override; 34 end; 35 36 { TDpiFormFileDesc } 14 37 15 38 TDpiFormFileDesc = class(TFileDescPascalUnitWithResource) … … 23 46 { TDpiFont } 24 47 25 TDpiFont = class 48 TDpiFont = class(TPersistent) 26 49 private 27 50 FOnChange: TNotifyEvent; 28 51 FSize: Integer; 52 function GetCharSet: TFontCharSet; 29 53 function GetColor: TColor; 54 function GetHeight: Integer; 30 55 function GetName: string; 31 56 function GetPixelsPerInch: Integer; 32 57 function GetStyle: TFontStyles; 58 function IsNameStored: Boolean; 59 procedure SetCharSet(AValue: TFontCharSet); 33 60 procedure SetColor(AValue: TColor); 61 procedure SetHeight(AValue: Integer); 34 62 procedure SetName(AValue: string); 35 63 procedure SetOnChange(AValue: TNotifyEvent); … … 45 73 constructor Create; 46 74 destructor Destroy; override; 47 procedure Assign(Source: T DpiFont);75 procedure Assign(Source: TPersistent); override; 48 76 published 77 property CharSet: TFontCharSet read GetCharSet write SetCharSet default DEFAULT_CHARSET; 49 78 property Color: TColor read GetColor write SetColor; 50 property Name: string read GetName write SetName ;51 property Style: TFontStyles read GetStyle write SetStyle ;52 property Size: Integer read FSize write SetSize ;79 property Name: string read GetName write SetName stored IsNameStored; 80 property Style: TFontStyles read GetStyle write SetStyle default []; 81 property Size: Integer read FSize write SetSize stored false; 53 82 property PixelsPerInch: Integer read GetPixelsPerInch write SetPixelsPerInch; 83 property Height: Integer read GetHeight write SetHeight default 0; 54 84 property OnChange: TNotifyEvent read FOnChange write SetOnChange; 55 85 end; 86 87 { TDpiSizeConstraints } 88 89 TDpiSizeConstraints = class(TPersistent) 90 private 91 FMaxHeight: TConstraintSize; 92 FMaxWidth: TConstraintSize; 93 FMinHeight: TConstraintSize; 94 FMinWidth: TConstraintSize; 95 procedure SetMaxHeight(AValue: TConstraintSize); 96 procedure SetMaxWidth(AValue: TConstraintSize); 97 procedure SetMinHeight(AValue: TConstraintSize); 98 procedure SetMinWidth(AValue: TConstraintSize); 99 published 100 property MaxHeight: TConstraintSize read FMaxHeight write SetMaxHeight default 0; 101 property MaxWidth: TConstraintSize read FMaxWidth write SetMaxWidth default 0; 102 property MinHeight: TConstraintSize read FMinHeight write SetMinHeight default 0; 103 property MinWidth: TConstraintSize read FMinWidth write SetMinWidth default 0; 104 end; 105 56 106 57 107 TDpiWinControl = class; … … 61 111 TDpiControl = class(TComponent) 62 112 private 113 FConstraints: TDpiSizeConstraints; 63 114 FFont: TDpiFont; 64 115 FHeight: Integer; 65 116 FLeft: Integer; 66 117 FOnChangeBounds: TNotifyEvent; 118 FOnMouseDown: TMouseEvent; 119 FOnMouseMove: TMouseMoveEvent; 120 FOnMouseUp: TMouseEvent; 121 FOnMouseWheel: TMouseWheelEvent; 67 122 FOnResize: TNotifyEvent; 68 123 FTop: Integer; … … 73 128 function GetClientHeight: Integer; 74 129 function GetClientWidth: Integer; 130 function GetColor: TColor; 131 function GetCursor: TCursor; 75 132 function GetEnabled: Boolean; 76 133 function GetHint: string; … … 82 139 procedure SetClientHeight(AValue: Integer); 83 140 procedure SetClientWidth(AValue: Integer); 141 procedure SetColor(AValue: TColor); 142 procedure SetCursor(AValue: TCursor); 84 143 procedure SetEnabled(AValue: Boolean); 85 144 procedure SetFont(AValue: TDpiFont); … … 106 165 function GetVclControl: TControl; virtual; 107 166 procedure UpdateVclControl; virtual; 167 procedure MouseDownHandler(Sender: TObject; Button: TMouseButton; Shift: TShiftState; 168 X, Y: Integer); virtual; 169 procedure MouseUpHandler(Sender: TObject; Button: TMouseButton; Shift: TShiftState; 170 X, Y: Integer); virtual; 171 procedure MouseMoveHandler(Sender: TObject; Shift: TShiftState; X, Y: Integer); virtual; 172 procedure MouseWheelHandler(Sender: TObject; Shift: TShiftState; 173 WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean); virtual; 108 174 procedure MouseDown(Button: TMouseButton; Shift: TShiftState; 109 175 X, Y: Integer); virtual; … … 123 189 property Parent: TDpiWinControl read FParent write SetParent; 124 190 property BoundsRect: TRect read GetBoundsRect write SetBoundsRect; 191 published 192 property ClientHeight: Integer read GetClientHeight write SetClientHeight; 125 193 property ClientWidth: Integer read GetClientWidth write SetClientWidth; 126 property ClientHeight: Integer read GetClientHeight write SetClientHeight;127 published128 194 property Hint: string read GetHint write SetHint; 129 195 property Top: Integer read FTop write SetTop; … … 137 203 property Font: TDpiFont read FFont write SetFont; 138 204 property Align: TAlign read GetAlign write SetAlign; 205 property Color: TColor read GetColor write SetColor; 206 property Constraints: TDpiSizeConstraints read FConstraints write FConstraints; 207 property Cursor: TCursor read GetCursor write SetCursor default crDefault; 139 208 property OnResize: TNotifyEvent read FOnResize write SetOnResize; 140 209 property OnChangeBounds: TNotifyEvent read FOnChangeBounds write SetOnChangeBounds; 141 210 property OnClick: TNotifyEvent read GetOnClick write SetOnClick; 211 property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown; 212 property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove; 213 property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp; 214 property OnMouseWheel: TMouseWheelEvent read FOnMouseWheel write FOnMouseWheel; 142 215 end; 143 216 … … 214 287 TDpiGraphicControl = class(TDpiControl) 215 288 private 289 FOnPaint: TNotifyEvent; 290 VclGraphicControl: TGraphicControl; 216 291 FCanvas: TDpiCanvas; 217 function GetOnPaint: TNotifyEvent;218 292 procedure SetCanvas(AValue: TDpiCanvas); 219 procedure SetOnPaint(AValue: TNotifyEvent);293 procedure PaintHandler(Sender: TObject); 220 294 protected 221 295 procedure Paint; virtual; 222 296 function GetVclControl: TControl; override; 223 297 function GetVclGraphicControl: TGraphicControl; virtual; 298 procedure UpdateVclControl; override; 299 property OnPaint: TNotifyEvent read FOnPaint write FOnPaint; 224 300 public 225 301 constructor Create(TheOwner: TComponent); override; … … 227 303 published 228 304 property Canvas: TDpiCanvas read FCanvas write SetCanvas; 229 property OnPaint: TNotifyEvent read GetOnPaint write SetOnPaint;230 305 end; 231 306 … … 262 337 TDpiCustomControl = class(TDpiWinControl) 263 338 private 339 FCanvas: TDpiCanvas; 340 function GetCanvas: TDpiCanvas; 264 341 function GetOnPaint: TNotifyEvent; 342 function GetPixelsPerInch: Integer; 265 343 procedure SetOnPaint(AValue: TNotifyEvent); 344 procedure SetPixelsPerInch(AValue: Integer); 266 345 protected 267 346 function GetVclWinControl: TWinControl; override; 268 347 function GetVclCustomControl: TCustomControl; virtual; 348 public 349 property Canvas: TDpiCanvas read GetCanvas; 269 350 published 351 property PixelsPerInch: Integer read GetPixelsPerInch write SetPixelsPerInch stored False; 270 352 property OnPaint: TNotifyEvent read GetOnPaint write SetOnPaint; 271 353 end; 272 354 355 { TDpiControlScrollBar } 356 357 TDpiControlScrollBar = class(TPersistent) 358 private 359 function GetVisible: Boolean; 360 procedure SetVisible(AValue: Boolean); 361 published 362 property Visible: Boolean read GetVisible write SetVisible; 363 end; 364 365 { TDpiScrollingWinControl } 366 367 TDpiScrollingWinControl = class(TDpiCustomControl) 368 private 369 FHorzScrollBar: TDpiControlScrollBar; 370 FVertScrollBar: TDpiControlScrollBar; 371 protected 372 function GetVclCustomControl: TCustomControl; override; 373 function GetVclScrollingWinControl: TScrollingWinControl; virtual; 374 public 375 constructor Create(TheOwner: TComponent); override; 376 destructor Destroy; override; 377 published 378 property HorzScrollBar: TDpiControlScrollBar read FHorzScrollBar write FHorzScrollBar; 379 property VertScrollBar: TDpiControlScrollBar read FVertScrollBar write FVertScrollBar; 380 end; 381 273 382 { TDpiForm } 274 383 275 TDpiForm = class(TDpi CustomControl)384 TDpiForm = class(TDpiScrollingWinControl) 276 385 private 386 FOnActivate: TNotifyEvent; 387 FOnDeactivate: TNotifyEvent; 277 388 function GetBorderIcons: TBorderIcons; 278 389 function GetBorderStyle: TBorderStyle; 279 function Get Canvas: TDpiCanvas;390 function GetDesignTimePPI: Integer; 280 391 function GetFormState: TFormState; 392 function GetFormStyle: TFormStyle; 393 function GetKeyPreview: Boolean; 394 function GetLCLVersion: string; 281 395 function GetModalResult: TModalResult; 282 396 function GetOnClose: TCloseEvent; 397 function GetOnCloseQuery: TCloseQueryEvent; 283 398 function GetOnCreate: TNotifyEvent; 284 399 function GetOnDeactivate: TNotifyEvent; … … 286 401 function GetOnHide: TNotifyEvent; 287 402 function GetOnShow: TNotifyEvent; 403 function GetPosition: TPosition; 404 function GetWindowState: TWindowState; 288 405 procedure SetBorderIcons(AValue: TBorderIcons); 289 406 procedure SetBorderStyle(AValue: TBorderStyle); 407 procedure SetDesignTimePPI(AValue: Integer); 408 procedure SetFormStyle(AValue: TFormStyle); 409 procedure SetKeyPreview(AValue: Boolean); 410 procedure SetLCLVersion(AValue: string); 290 411 procedure SetModalResult(AValue: TModalResult); 291 412 procedure SetOnClose(AValue: TCloseEvent); 413 procedure SetOnCloseQuery(AValue: TCloseQueryEvent); 292 414 procedure SetOnCreate(AValue: TNotifyEvent); 293 415 procedure SetOnDeactivate(AValue: TNotifyEvent); … … 296 418 procedure SetOnShow(AValue: TNotifyEvent); 297 419 procedure DoOnCreate; 420 procedure FormMessageHandler(var TheMessage: TLMessage); 421 procedure SetPosition(AValue: TPosition); 422 procedure SetWindowState(AValue: TWindowState); 423 procedure ActivateHandler(Sender: TObject); 424 procedure DeactivateHandler(Sender: TObject); 298 425 protected 299 426 procedure CreateParams(var p: TCreateParams); virtual; 300 427 procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; 301 function GetVcl CustomControl: TCustomControl; override;428 function GetVclScrollingWinControl: TScrollingWinControl; override; 302 429 function GetVclForm: TForm; virtual; 430 procedure UpdateVclControl; override; 303 431 public 304 432 VclForm: TForm; 305 property Canvas: TDpiCanvas read GetCanvas;306 433 property ModalResult: TModalResult read GetModalResult write SetModalResult; 307 434 function ShowModal: Integer; virtual; … … 311 438 destructor Destroy; override; 312 439 published 440 property DesignTimePPI: Integer read GetDesignTimePPI write SetDesignTimePPI; // Not used 313 441 property FormState: TFormState read GetFormState; 442 property FormStyle: TFormStyle read GetFormStyle write SetFormStyle; 314 443 property BorderStyle: TBorderStyle read GetBorderStyle write SetBorderStyle; 315 444 property BorderIcons: TBorderIcons read GetBorderIcons write SetBorderIcons; 445 property LCLVersion: string read GetLCLVersion write SetLCLVersion; 446 property KeyPreview: Boolean read GetKeyPreview write SetKeyPreview default False; 447 property Position: TPosition read GetPosition write SetPosition default poDesigned; 448 property WindowState: TWindowState read GetWindowState write SetWindowState default wsNormal; 316 449 property OnShow: TNotifyEvent read GetOnShow write SetOnShow; 317 450 property OnHide: TNotifyEvent read GetOnHide write SetOnHide; 318 451 property OnCreate: TNotifyEvent read GetOnCreate write SetOnCreate; 319 452 property OnDestroy: TNotifyEvent read GetOnDestroy write SetOnDestroy; 320 property OnDeactivate: TNotifyEvent read GetOnDeactivate write SetOnDeactivate; 453 property OnActivate: TNotifyEvent read FOnActivate write FOnActivate; 454 property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate; 321 455 property OnClose: TCloseEvent read GetOnClose write SetOnClose; 456 property OnCloseQuery: TCloseQueryEvent read GetOnCloseQuery write SetOnCloseQuery; 457 property ClientHeight; 458 property ClientWidth; 459 property OnMouseUp; 460 property OnMouseDown; 461 property OnMouseMove; 322 462 end; 323 463 … … 403 543 constructor Create; 404 544 destructor Destroy; override; 545 procedure Assign(Source: TPersistent); override; 405 546 property ScanLine[Row: Integer]: Pointer read GetScanLine; 406 547 published … … 448 589 public 449 590 VclPaintBox: TPaintBox; 450 function GetVcl Control: TControl; override;591 function GetVclGraphicControl: TGraphicControl; override; 451 592 constructor Create(TheOwner: TComponent); override; 452 593 destructor Destroy; override; … … 464 605 function GetHeight: Integer; 465 606 function GetWidth: Integer; 607 procedure SetActiveForm(AValue: TDpiForm); 466 608 procedure SetDpi(AValue: Integer); 467 609 procedure UpdateForms; … … 471 613 destructor Destroy; override; 472 614 property FormCount: Integer read GetFormCount; 473 property ActiveForm: TDpiForm read GetActiveForm ;615 property ActiveForm: TDpiForm read GetActiveForm write SetActiveForm; 474 616 published 475 617 property Dpi: Integer read FDpi write SetDpi; … … 498 640 end; 499 641 642 { TDpiApplication } 643 644 TDpiApplication = class(TComponent) 645 private 646 FMainForm: TDpiForm; 647 FCreatingForm: TDpiForm; 648 function GetShowMainForm: Boolean; 649 function GetTitle: string; 650 procedure SetMainForm(AValue: TDpiForm); 651 function GetMainForm: TDpiForm; 652 procedure SetShowMainForm(AValue: Boolean); 653 procedure SetTitle(AValue: string); 654 protected 655 function GetVclApplication: TApplication; virtual; 656 public 657 procedure Run; 658 procedure Initialize; 659 procedure ProcessMessages; 660 procedure UpdateMainForm(AForm: TDpiForm); 661 procedure CreateForm(InstanceClass: TComponentClass; out Reference); 662 property MainForm: TDpiForm read GetMainForm write SetMainForm; 663 property ShowMainForm: Boolean read GetShowMainForm write SetShowMainForm default True; 664 property Title: string read GetTitle write SetTitle; 665 end; 666 500 667 var 501 668 DpiFormFileDesc: TDpiFormFileDesc; 502 669 DpiScreen: TDpiScreen; 670 DpiApplication: TDpiApplication; 503 671 504 672 procedure Register; 673 function DpiBitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc: Integer; Rop: DWORD): Boolean; 505 674 506 675 … … 529 698 end; 530 699 700 function ScalePointToVcl(Value: TPoint): TPoint; 701 begin 702 Result.X := ScaleToVcl(Value.X); 703 Result.Y := ScaleToVcl(Value.Y); 704 end; 705 706 function ScalePointFromVcl(Value: TPoint): TPoint; 707 begin 708 Result.X := ScaleFromVcl(Value.X); 709 Result.Y := ScaleFromVcl(Value.Y); 710 end; 711 531 712 function ScaleRectToVcl(Value: TRect): TRect; 532 713 begin … … 545 726 end; 546 727 728 function DpiBitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, 729 YSrc: Integer; Rop: DWORD): Boolean; 730 begin 731 Result := BitBlt(DestDC, ScaleToVcl(X), ScaleToVcl(Y), ScaleToVcl(Width), 732 ScaleToVcl(Height), SrcDC, ScaleToVcl(XSrc), ScaleToVcl(YSrc), Rop); 733 end; 734 735 { TDpiSizeConstraints } 736 737 procedure TDpiSizeConstraints.SetMaxHeight(AValue: TConstraintSize); 738 begin 739 if FMaxHeight=AValue then Exit; 740 FMaxHeight:=AValue; 741 end; 742 743 procedure TDpiSizeConstraints.SetMaxWidth(AValue: TConstraintSize); 744 begin 745 if FMaxWidth=AValue then Exit; 746 FMaxWidth:=AValue; 747 end; 748 749 procedure TDpiSizeConstraints.SetMinHeight(AValue: TConstraintSize); 750 begin 751 if FMinHeight=AValue then Exit; 752 FMinHeight:=AValue; 753 end; 754 755 procedure TDpiSizeConstraints.SetMinWidth(AValue: TConstraintSize); 756 begin 757 if FMinWidth=AValue then Exit; 758 FMinWidth:=AValue; 759 end; 760 761 { TDpiScrollingWinControl } 762 763 function TDpiScrollingWinControl.GetVclCustomControl: TCustomControl; 764 begin 765 Result := GetVclScrollingWinControl; 766 end; 767 768 function TDpiScrollingWinControl.GetVclScrollingWinControl: TScrollingWinControl; 769 begin 770 Result := nil; 771 end; 772 773 constructor TDpiScrollingWinControl.Create(TheOwner: TComponent); 774 begin 775 inherited; 776 FHorzScrollBar := TDpiControlScrollBar.Create; 777 FVertScrollBar := TDpiControlScrollBar.Create; 778 end; 779 780 destructor TDpiScrollingWinControl.Destroy; 781 begin 782 FreeAndNil(FHorzScrollBar); 783 FreeAndNil(FVertScrollBar); 784 inherited Destroy; 785 end; 786 787 { TDpiControlScrollBar } 788 789 function TDpiControlScrollBar.GetVisible: Boolean; 790 begin 791 792 end; 793 794 procedure TDpiControlScrollBar.SetVisible(AValue: Boolean); 795 begin 796 797 end; 798 799 { TGraphicControlEx } 800 801 procedure TGraphicControlEx.Paint; 802 begin 803 inherited Paint; 804 end; 805 806 { TFormEx } 807 808 procedure TFormEx.WndProc(var TheMessage: TLMessage); 809 begin 810 inherited WndProc(TheMessage); 811 if Assigned(FOnMessage) then 812 FOnMessage(TheMessage); 813 end; 814 815 { TDpiApplication } 816 817 procedure TDpiApplication.SetMainForm(AValue: TDpiForm); 818 begin 819 FMainForm := AValue; 820 end; 821 822 function TDpiApplication.GetTitle: string; 823 begin 824 Result := GetVclApplication.Title; 825 end; 826 827 function TDpiApplication.GetShowMainForm: Boolean; 828 begin 829 Result := GetVclApplication.ShowMainForm; 830 end; 831 832 function TDpiApplication.GetMainForm: TDpiForm; 833 begin 834 Result := FMainForm; 835 end; 836 837 procedure TDpiApplication.SetShowMainForm(AValue: Boolean); 838 begin 839 GetVclApplication.ShowMainForm := AValue; 840 end; 841 842 procedure TDpiApplication.SetTitle(AValue: string); 843 begin 844 GetVclApplication.Title := AValue; 845 end; 846 847 function TDpiApplication.GetVclApplication: TApplication; 848 begin 849 Result := Application; 850 end; 851 852 procedure TDpiApplication.Run; 853 begin 854 if (FMainForm <> nil) and GetShowMainForm then FMainForm.Show; 855 GetVclApplication.Run; 856 end; 857 858 procedure TDpiApplication.Initialize; 859 begin 860 GetVclApplication.Initialize; 861 end; 862 863 procedure TDpiApplication.ProcessMessages; 864 begin 865 GetVclApplication.ProcessMessages; 866 end; 867 868 procedure TDpiApplication.UpdateMainForm(AForm: TDpiForm); 869 begin 870 if (FMainForm = nil) 871 and (FCreatingForm=AForm) 872 //and (not (AppDestroying in FFlags)) 873 and not (AForm.FormStyle in [fsMDIChild, fsSplash]) 874 then 875 FMainForm := AForm; 876 GetVclApplication.UpdateMainForm(AForm.GetVclForm); 877 end; 878 879 procedure TDpiApplication.CreateForm(InstanceClass: TComponentClass; out 880 Reference); 881 var 882 Instance: TComponent; 883 ok: Boolean; 884 AForm: TDpiForm; 885 begin 886 // Allocate the instance, without calling the constructor 887 Instance := TComponent(InstanceClass.NewInstance); 888 // set the Reference before the constructor is called, so that 889 // events and constructors can refer to it 890 TComponent(Reference) := Instance; 891 892 ok := False; 893 try 894 if (FCreatingForm = nil) and (Instance is TDpiForm) then 895 FCreatingForm := TDpiForm(Instance); 896 Instance.Create(Self); 897 ok := true; 898 finally 899 if not ok then begin 900 TComponent(Reference) := nil; 901 if FCreatingForm = Instance then 902 FCreatingForm := nil; 903 end; 904 end; 905 906 if (Instance is TDpiForm) then begin 907 AForm := TDpiForm(Instance); 908 UpdateMainForm(AForm); 909 if FMainForm = AForm then AForm.GetVclForm.HandleNeeded; 910 if AForm.FormStyle = fsSplash then begin 911 // show the splash form and handle the paint message 912 AForm.Show; 913 AForm.Invalidate; 914 ProcessMessages; 915 end; 916 end; 917 end; 918 547 919 { TDpiJpegImage } 548 920 … … 578 950 end; 579 951 952 function TDpiCustomControl.GetPixelsPerInch: Integer; 953 begin 954 // Result := GetVclCustomControl.P; 955 end; 956 957 function TDpiCustomControl.GetCanvas: TDpiCanvas; 958 begin 959 if not Assigned(FCanvas) then begin 960 FCanvas := TDpiCanvas.Create; 961 FCanvas.VclCanvas := GetVclCustomControl.Canvas; 962 end; 963 Result := FCanvas; 964 end; 965 580 966 procedure TDpiCustomControl.SetOnPaint(AValue: TNotifyEvent); 581 967 begin 582 968 GetVclCustomControl.OnPaint := AValue; 969 end; 970 971 procedure TDpiCustomControl.SetPixelsPerInch(AValue: Integer); 972 begin 973 583 974 end; 584 975 … … 715 1106 function TDpiBitmap.GetCanvas: TDpiCanvas; 716 1107 begin 717 if not Assigned(FCanvas) then FCanvas := TDpiCanvas.Create; 1108 if not Assigned(FCanvas) then begin 1109 FCanvas := TDpiCanvas.Create; 1110 FCanvas.VclCanvas := GetVclBitmap.Canvas; 1111 end; 718 1112 Result := FCanvas; 719 1113 end; … … 775 1169 constructor TDpiBitmap.Create; 776 1170 begin 1171 inherited; 777 1172 end; 778 1173 … … 784 1179 end; 785 1180 1181 procedure TDpiBitmap.Assign(Source: TPersistent); 1182 begin 1183 if Source is TDpiBitmap then begin 1184 GetVclBitmap.Assign((Source as TDpiBitmap).GetVclBitmap); 1185 end else inherited; 1186 end; 1187 786 1188 function TDpiBitmap.GetVclRasterImage: TRasterImage; 787 1189 begin … … 815 1217 end; 816 1218 817 function TDpiPaintBox.GetVcl Control: TControl;1219 function TDpiPaintBox.GetVclGraphicControl: TGraphicControl; 818 1220 begin 819 1221 if not Assigned(VclPaintBox) then VclPaintBox := TPaintBox.Create(nil); … … 910 1312 function TDpiCanvas.GetVclCanvas: TCanvas; 911 1313 begin 912 if not Assigned(VclCanvas) then VclCanvas := TCanvas.Create;1314 //if not Assigned(VclCanvas) then VclCanvas := TCanvas.Create; 913 1315 Result := VclCanvas; 914 1316 end; … … 999 1401 end; 1000 1402 1001 function TDpiGraphicControl.GetOnPaint: TNotifyEvent; 1002 begin 1003 Result := nil; 1004 end; 1005 1006 procedure TDpiGraphicControl.SetOnPaint(AValue: TNotifyEvent); 1007 begin 1008 1403 procedure TDpiGraphicControl.PaintHandler(Sender: TObject); 1404 begin 1405 Paint; 1406 if Assigned(FOnPaint) then 1407 FOnPaint(Sender); 1009 1408 end; 1010 1409 … … 1020 1419 function TDpiGraphicControl.GetVclGraphicControl: TGraphicControl; 1021 1420 begin 1022 Result := nil; 1421 if not Assigned(VclGraphicControl) then begin 1422 VclGraphicControl := TGraphicControlEx.Create(nil); 1423 (VclGraphicControl as TGraphicControlEx).OnPaint := @PaintHandler; 1424 end; 1425 Result := VclGraphicControl; 1426 end; 1427 1428 procedure TDpiGraphicControl.UpdateVclControl; 1429 begin 1430 inherited; 1431 (GetVclGraphicControl as TGraphicControlEx).OnMouseDown := @MouseDownHandler; 1432 (GetVclGraphicControl as TGraphicControlEx).OnMouseUp := @MouseUpHandler; 1433 (GetVclGraphicControl as TGraphicControlEx).OnMouseMove := @MouseMoveHandler; 1023 1434 end; 1024 1435 … … 1027 1438 inherited; 1028 1439 FCanvas := TDpiCanvas.Create; 1440 FCanvas.VclCanvas := GetVclGraphicControl.Canvas; 1029 1441 end; 1030 1442 … … 1114 1526 end; 1115 1527 1528 function TDpiFont.GetCharSet: TFontCharSet; 1529 begin 1530 Result := GetVclFont.CharSet; 1531 end; 1532 1533 function TDpiFont.GetHeight: Integer; 1534 begin 1535 Result := GetVclFont.Height; 1536 end; 1537 1116 1538 function TDpiFont.GetPixelsPerInch: Integer; 1117 1539 begin … … 1124 1546 end; 1125 1547 1548 function TDpiFont.IsNameStored: Boolean; 1549 begin 1550 Result := GetVclFont.Name <> 'default'; 1551 end; 1552 1553 procedure TDpiFont.SetCharSet(AValue: TFontCharSet); 1554 begin 1555 GetVclFont.CharSet := AValue; 1556 end; 1557 1126 1558 procedure TDpiFont.SetColor(AValue: TColor); 1127 1559 begin … … 1129 1561 end; 1130 1562 1563 procedure TDpiFont.SetHeight(AValue: Integer); 1564 begin 1565 GetVclFont.Height := AValue; 1566 end; 1567 1131 1568 procedure TDpiFont.SetName(AValue: string); 1132 1569 begin … … 1144 1581 end; 1145 1582 1146 procedure TDpiFont.Assign(Source: TDpiFont); 1147 begin 1148 GetVclFont.Assign(Source.GetVclFont); 1149 Size := Source.Size; 1150 FOnChange := Source.FOnChange; 1583 procedure TDpiFont.Assign(Source: TPersistent); 1584 begin 1585 if Source is TDpiFont then begin 1586 GetVclFont.Assign((Source as TDpiFont).GetVclFont); 1587 Size := (Source as TDpiFont).Size; 1588 FOnChange := (Source as TDpiFont).FOnChange; 1589 end; 1151 1590 end; 1152 1591 … … 1191 1630 begin 1192 1631 GetVclWinControl.OnKeyUp := AValue; 1193 1194 1632 end; 1195 1633 … … 1245 1683 end; 1246 1684 1685 procedure TDpiScreen.SetActiveForm(AValue: TDpiForm); 1686 begin 1687 FActiveForm := AValue; 1688 end; 1689 1247 1690 function TDpiScreen.GetHeight: Integer; 1248 1691 begin … … 1272 1715 Forms := TDpiForms.Create; 1273 1716 Forms.FreeObjects := False; 1274 Dpi := 96;1717 Dpi := 144; 1275 1718 end; 1276 1719 … … 1330 1773 end; 1331 1774 1775 procedure TDpiControl.MouseDownHandler(Sender: TObject; Button: TMouseButton; 1776 Shift: TShiftState; X, Y: Integer); 1777 begin 1778 MouseDown(Button, Shift, ScaleFromVcl(X), ScaleFromVcl(Y)); 1779 if Assigned(FOnMouseDown) then FOnMouseDown(Self, Button, Shift, ScaleFromVcl(X), ScaleFromVcl(Y)); 1780 end; 1781 1782 procedure TDpiControl.MouseUpHandler(Sender: TObject; Button: TMouseButton; 1783 Shift: TShiftState; X, Y: Integer); 1784 begin 1785 MouseUp(Button, Shift, ScaleFromVcl(X), ScaleFromVcl(Y)); 1786 if Assigned(FOnMouseUp) then FOnMouseUp(Self, Button, Shift, ScaleFromVcl(X), ScaleFromVcl(Y)); 1787 end; 1788 1789 procedure TDpiControl.MouseMoveHandler(Sender: TObject; Shift: TShiftState; X, 1790 Y: Integer); 1791 begin 1792 MouseMove(Shift, ScaleFromVcl(X), ScaleFromVcl(Y)); 1793 if Assigned(FOnMouseMove) then FOnMouseMove(Self, Shift, ScaleFromVcl(X), ScaleFromVcl(Y)); 1794 end; 1795 1796 procedure TDpiControl.MouseWheelHandler(Sender: TObject; Shift: TShiftState; 1797 WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean); 1798 begin 1799 if Assigned(FOnMouseWheel) then FOnMouseWheel(Self, Shift, WheelDelta, 1800 ScalePointFromVcl(MousePos), Handled); 1801 end; 1802 1332 1803 procedure TDpiControl.MouseDown(Button: TMouseButton; Shift: TShiftState; X, 1333 1804 Y: Integer); 1334 1805 begin 1335 // TODO1336 1806 end; 1337 1807 … … 1339 1809 Y: Integer); 1340 1810 begin 1341 // TODO1342 1811 end; 1343 1812 1344 1813 procedure TDpiControl.MouseMove(Shift: TShiftState; X, Y: Integer); 1345 1814 begin 1346 // TODO1347 1815 end; 1348 1816 … … 1392 1860 FFont := TDpiFont.Create; 1393 1861 FFont.OnChange := @FontChanged; 1862 FConstraints := TDpiSizeConstraints.Create; 1394 1863 if Assigned(TheOwner) and (TheOwner is TDpiWinControl) then 1395 1864 Parent := TDpiWinControl(TheOwner); … … 1401 1870 destructor TDpiControl.Destroy; 1402 1871 begin 1872 FreeAndNil(FConstraints); 1403 1873 FreeAndNil(FFont); 1404 1874 inherited Destroy; … … 1467 1937 end; 1468 1938 1939 function TDpiControl.GetColor: TColor; 1940 begin 1941 Result := GetVclControl.Color; 1942 end; 1943 1944 function TDpiControl.GetCursor: TCursor; 1945 begin 1946 Result := GetVclControl.Cursor; 1947 end; 1948 1469 1949 function TDpiControl.GetEnabled: Boolean; 1470 1950 begin … … 1510 1990 begin 1511 1991 GetVclControl.ClientWidth := ScaletoVcl(AValue); 1992 end; 1993 1994 procedure TDpiControl.SetColor(AValue: TColor); 1995 begin 1996 GetVclControl.Color := AValue; 1997 end; 1998 1999 procedure TDpiControl.SetCursor(AValue: TCursor); 2000 begin 2001 GetVclControl.Cursor := AValue; 1512 2002 end; 1513 2003 … … 1546 2036 1547 2037 procedure TDpiControl.VclChangeBounds(Sender: TObject); 1548 begin 1549 BoundsRect := ScaleRectFromVcl(GetVclControl.BoundsRect); 1550 DoChangeBounds; 2038 var 2039 NewBounds: TRect; 2040 begin 2041 NewBounds := ScaleRectFromVcl(GetVclControl.BoundsRect); 2042 if NewBounds <> BoundsRect then begin 2043 BoundsRect := NewBounds; 2044 DoChangeBounds; 2045 end; 1551 2046 end; 1552 2047 … … 1613 2108 function TDpiForm.GetBorderIcons: TBorderIcons; 1614 2109 begin 1615 Result := VclForm.BorderIcons;2110 Result := GetVclForm.BorderIcons; 1616 2111 end; 1617 2112 1618 2113 function TDpiForm.GetBorderStyle: TBorderStyle; 1619 2114 begin 1620 Result := VclForm.BorderStyle;1621 end; 1622 1623 function TDpiForm.Get Canvas: TDpiCanvas;1624 begin 1625 Result := Canvas;2115 Result := GetVclForm.BorderStyle; 2116 end; 2117 2118 function TDpiForm.GetDesignTimePPI: Integer; 2119 begin 2120 Result := GetVclForm.DesignTimePPI; 1626 2121 end; 1627 2122 1628 2123 function TDpiForm.GetFormState: TFormState; 1629 2124 begin 1630 Result := VclForm.FormState; 2125 Result := GetVclForm.FormState; 2126 end; 2127 2128 function TDpiForm.GetFormStyle: TFormStyle; 2129 begin 2130 Result := GetVclForm.FormStyle; 2131 end; 2132 2133 function TDpiForm.GetKeyPreview: Boolean; 2134 begin 2135 Result := GetVclForm.KeyPreview; 2136 end; 2137 2138 function TDpiForm.GetLCLVersion: string; 2139 begin 2140 Result := GetVclForm.LCLVersion; 1631 2141 end; 1632 2142 1633 2143 function TDpiForm.GetModalResult: TModalResult; 1634 2144 begin 1635 Result := VclForm.ModalResult;2145 Result := GetVclForm.ModalResult; 1636 2146 end; 1637 2147 1638 2148 function TDpiForm.GetOnClose: TCloseEvent; 1639 2149 begin 1640 Result := VclForm.OnClose; 2150 Result := GetVclForm.OnClose; 2151 end; 2152 2153 function TDpiForm.GetOnCloseQuery: TCloseQueryEvent; 2154 begin 2155 Result := GetVclForm.OnCloseQuery; 1641 2156 end; 1642 2157 1643 2158 function TDpiForm.GetOnCreate: TNotifyEvent; 1644 2159 begin 1645 Result := VclForm.OnCreate;2160 Result := GetVclForm.OnCreate; 1646 2161 end; 1647 2162 1648 2163 function TDpiForm.GetOnDeactivate: TNotifyEvent; 1649 2164 begin 1650 Result := VclForm.OnDeactivate;2165 Result := GetVclForm.OnDeactivate; 1651 2166 end; 1652 2167 1653 2168 function TDpiForm.GetOnDestroy: TNotifyEvent; 1654 2169 begin 1655 Result := VclForm.OnDestroy;2170 Result := GetVclForm.OnDestroy; 1656 2171 end; 1657 2172 1658 2173 function TDpiForm.GetOnHide: TNotifyEvent; 1659 2174 begin 1660 Result := VclForm.OnHide;2175 Result := GetVclForm.OnHide; 1661 2176 end; 1662 2177 1663 2178 function TDpiForm.GetOnShow: TNotifyEvent; 1664 2179 begin 1665 Result := VclForm.OnShow; 2180 Result := GetVclForm.OnShow; 2181 end; 2182 2183 function TDpiForm.GetPosition: TPosition; 2184 begin 2185 Result := GetVclForm.Position; 2186 end; 2187 2188 function TDpiForm.GetWindowState: TWindowState; 2189 begin 2190 Result := GetVclForm.WindowState; 1666 2191 end; 1667 2192 1668 2193 procedure TDpiForm.SetBorderIcons(AValue: TBorderIcons); 1669 2194 begin 1670 VclForm.BorderIcons := AValue;2195 GetVclForm.BorderIcons := AValue; 1671 2196 end; 1672 2197 1673 2198 procedure TDpiForm.SetBorderStyle(AValue: TBorderStyle); 1674 2199 begin 1675 VclForm.BorderStyle := AValue; 2200 GetVclForm.BorderStyle := AValue; 2201 end; 2202 2203 procedure TDpiForm.SetDesignTimePPI(AValue: Integer); 2204 begin 2205 GetVclForm.DesignTimePPI := AValue; 2206 end; 2207 2208 procedure TDpiForm.SetFormStyle(AValue: TFormStyle); 2209 begin 2210 GetVclForm.FormStyle := AValue; 2211 end; 2212 2213 procedure TDpiForm.SetKeyPreview(AValue: Boolean); 2214 begin 2215 GetVclForm.KeyPreview := AValue; 2216 end; 2217 2218 procedure TDpiForm.SetLCLVersion(AValue: string); 2219 begin 2220 GetVclForm.LCLVersion := AValue; 1676 2221 end; 1677 2222 1678 2223 procedure TDpiForm.SetModalResult(AValue: TModalResult); 1679 2224 begin 1680 VclForm.ModalResult := AValue;2225 GetVclForm.ModalResult := AValue; 1681 2226 end; 1682 2227 1683 2228 procedure TDpiForm.SetOnClose(AValue: TCloseEvent); 1684 2229 begin 1685 VclForm.OnClose := AValue; 2230 GetVclForm.OnClose := AValue; 2231 end; 2232 2233 procedure TDpiForm.SetOnCloseQuery(AValue: TCloseQueryEvent); 2234 begin 2235 GetVclForm.OnCloseQuery := AValue; 1686 2236 end; 1687 2237 1688 2238 procedure TDpiForm.SetOnCreate(AValue: TNotifyEvent); 1689 2239 begin 1690 VclForm.OnCreate := AValue;2240 GetVclForm.OnCreate := AValue; 1691 2241 end; 1692 2242 1693 2243 procedure TDpiForm.SetOnDeactivate(AValue: TNotifyEvent); 1694 2244 begin 1695 VclForm.OnDeactivate := AValue;2245 GetVclForm.OnDeactivate := AValue; 1696 2246 end; 1697 2247 1698 2248 procedure TDpiForm.SetOnDestroy(AValue: TNotifyEvent); 1699 2249 begin 1700 VclForm.OnDestroy := AValue;2250 GetVclForm.OnDestroy := AValue; 1701 2251 end; 1702 2252 1703 2253 procedure TDpiForm.SetOnHide(AValue: TNotifyEvent); 1704 2254 begin 1705 VclForm.OnHide := AValue;2255 GetVclForm.OnHide := AValue; 1706 2256 end; 1707 2257 1708 2258 procedure TDpiForm.SetOnShow(AValue: TNotifyEvent); 1709 2259 begin 1710 VclForm.OnShow := AValue;2260 GetVclForm.OnShow := AValue; 1711 2261 end; 1712 2262 1713 2263 procedure TDpiForm.DoOnCreate; 1714 2264 begin 1715 if Assigned(VclForm.OnCreate) then 1716 VclForm.OnCreate(Self); 2265 if Assigned(GetVclForm.OnCreate) then 2266 GetVclForm.OnCreate(Self); 2267 end; 2268 2269 procedure TDpiForm.FormMessageHandler(var TheMessage: TLMessage); 2270 begin 2271 Dispatch(TheMessage); 2272 end; 2273 2274 procedure TDpiForm.SetPosition(AValue: TPosition); 2275 begin 2276 GetVclForm.Position := AValue; 2277 end; 2278 2279 procedure TDpiForm.SetWindowState(AValue: TWindowState); 2280 begin 2281 GetVclForm.WindowState := AValue; 2282 end; 2283 2284 procedure TDpiForm.ActivateHandler(Sender: TObject); 2285 begin 2286 DpiScreen.ActiveForm := Self; 2287 if Assigned(FOnActivate) then FOnActivate(Sender); 2288 end; 2289 2290 procedure TDpiForm.DeactivateHandler(Sender: TObject); 2291 begin 2292 if Assigned(FOnDeactivate) then FOnDeactivate(Sender); 1717 2293 end; 1718 2294 … … 1738 2314 end; 1739 2315 1740 function TDpiForm.GetVcl CustomControl: TCustomControl;2316 function TDpiForm.GetVclScrollingWinControl: TScrollingWinControl; 1741 2317 begin 1742 2318 Result := GetVclForm; … … 1745 2321 function TDpiForm.GetVclForm: TForm; 1746 2322 begin 1747 if not Assigned(VclForm) then VclForm := TForm.Create(nil); 2323 if not Assigned(VclForm) then begin 2324 VclForm := TFormEx.Create(nil); 2325 (VclForm as TFormEx).OnMessage := @FormMessageHandler; 2326 end; 1748 2327 Result := VclForm; 2328 end; 2329 2330 procedure TDpiForm.UpdateVclControl; 2331 begin 2332 inherited; 2333 GetVclForm.OnMouseDown := @MouseDownHandler; 2334 GetVclForm.OnMouseUp := @MouseUpHandler; 2335 GetVclForm.OnMouseMove := @MouseMoveHandler; 2336 GetVclForm.OnActivate := @ActivateHandler; 2337 GetVclForm.OnDeactivate := @DeactivateHandler; 1749 2338 end; 1750 2339 … … 1768 2357 begin 1769 2358 inherited; 1770 DebugLn(['TDpiForm.Create ', DbgSName(TheOwner)]);2359 //DebugLn(['TDpiForm.Create ', DbgSName(TheOwner)]); 1771 2360 GlobalNameSpace.BeginWrite; 1772 2361 try 1773 if (ClassType <> TDpiForm) and not (csDesigning in ComponentState) 1774 then begin 2362 if (ClassType <> TDpiForm) and not (csDesigning in ComponentState) then begin 1775 2363 if not InitResourceComponent(Self, TDataModule) then begin 1776 2364 raise EResNotFound.Create('Resource missing for class ' + ClassName); … … 1792 2380 initialization 1793 2381 2382 RegisterPropertyToSkip(TDpiForm, 'OldCreateOrder', 'VCL compatibility property', ''); 2383 RegisterPropertyToSkip(TDpiForm, 'TextHeight', 'VCL compatibility property', ''); 2384 RegisterPropertyToSkip(TDpiForm, 'Scaled', 'VCL compatibility property', ''); 2385 RegisterPropertyToSkip(TDpiForm, 'TransparentColorValue', 'VCL compatibility property', ''); 1794 2386 DpiScreen := TDpiScreen.Create; 2387 DpiApplication := TDpiApplication.Create(nil); 1795 2388 1796 2389 finalization 1797 2390 2391 FreeAndNil(DpiApplication); 1798 2392 FreeAndNil(DpiScreen); 1799 2393
Note:
See TracChangeset
for help on using the changeset viewer.