source: DpiControls/UDpiControls.pas

Last change on this file was 537, checked in by chronos, 5 years ago
File size: 58.3 KB
Line 
1unit UDpiControls;
2
3{$mode objfpc}{$H+}
4
5interface
6
7uses
8 Classes, SysUtils, LCLProc, LResources, Forms, FormEditingIntf, ProjectIntf,
9 Controls, StdCtrls, fgl, Graphics, ComCtrls, ExtCtrls, LCLType, GraphType,
10 Types, CustApp, LMessages, LCLIntf;
11
12type
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 }
37
38 TDpiFormFileDesc = class(TFileDescPascalUnitWithResource)
39 public
40 constructor Create; override;
41 function GetInterfaceUsesSection: string; override;
42 function GetLocalizedName: string; override;
43 function GetLocalizedDescription: string; override;
44 end;
45
46 { TDpiFont }
47
48 TDpiFont = class(TPersistent)
49 private
50 FOnChange: TNotifyEvent;
51 FSize: Integer;
52 function GetCharSet: TFontCharSet;
53 function GetColor: TColor;
54 function GetHeight: Integer;
55 function GetName: string;
56 function GetPixelsPerInch: Integer;
57 function GetStyle: TFontStyles;
58 function IsNameStored: Boolean;
59 procedure SetCharSet(AValue: TFontCharSet);
60 procedure SetColor(AValue: TColor);
61 procedure SetHeight(AValue: Integer);
62 procedure SetName(AValue: string);
63 procedure SetOnChange(AValue: TNotifyEvent);
64 procedure SetPixelsPerInch(AValue: Integer);
65 procedure SetSize(AValue: Integer);
66 procedure DoChange;
67 procedure SetStyle(AValue: TFontStyles);
68 protected
69 procedure ScreenChanged;
70 function GetVclFont: TFont; virtual;
71 public
72 VclFont: TFont;
73 constructor Create;
74 destructor Destroy; override;
75 procedure Assign(Source: TPersistent); override;
76 published
77 property CharSet: TFontCharSet read GetCharSet write SetCharSet default DEFAULT_CHARSET;
78 property Color: TColor read GetColor write SetColor;
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;
82 property PixelsPerInch: Integer read GetPixelsPerInch write SetPixelsPerInch;
83 property Height: Integer read GetHeight write SetHeight default 0;
84 property OnChange: TNotifyEvent read FOnChange write SetOnChange;
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
106
107 TDpiWinControl = class;
108
109 { TDpiControl }
110
111 TDpiControl = class(TComponent)
112 private
113 FConstraints: TDpiSizeConstraints;
114 FFont: TDpiFont;
115 FHeight: Integer;
116 FLeft: Integer;
117 FOnChangeBounds: TNotifyEvent;
118 FOnMouseDown: TMouseEvent;
119 FOnMouseMove: TMouseMoveEvent;
120 FOnMouseUp: TMouseEvent;
121 FOnMouseWheel: TMouseWheelEvent;
122 FOnResize: TNotifyEvent;
123 FTop: Integer;
124 FWidth: Integer;
125 FParent: TDpiWinControl;
126 function GetAlign: TAlign;
127 function GetBoundsRect: TRect;
128 function GetClientHeight: Integer;
129 function GetClientWidth: Integer;
130 function GetColor: TColor;
131 function GetCursor: TCursor;
132 function GetEnabled: Boolean;
133 function GetHint: string;
134 function GetOnClick: TNotifyEvent;
135 function GetShowHint: Boolean;
136 function GetVisible: Boolean;
137 procedure SetAlign(AValue: TAlign);
138 procedure SetBoundsRect(AValue: TRect);
139 procedure SetClientHeight(AValue: Integer);
140 procedure SetClientWidth(AValue: Integer);
141 procedure SetColor(AValue: TColor);
142 procedure SetCursor(AValue: TCursor);
143 procedure SetEnabled(AValue: Boolean);
144 procedure SetFont(AValue: TDpiFont);
145 procedure SetHint(AValue: string);
146 procedure SetOnChangeBounds(AValue: TNotifyEvent);
147 procedure SetOnClick(AValue: TNotifyEvent);
148 procedure SetOnResize(AValue: TNotifyEvent);
149 procedure SetShowHint(AValue: Boolean);
150 procedure VclFormResize(Sender: TObject);
151 procedure VclChangeBounds(Sender: TObject);
152 procedure DoFormResize;
153 procedure DoChangeBounds;
154 protected
155 procedure UpdateBounds; virtual;
156 procedure FontChanged(Sender: TObject); virtual;
157 function GetCaption: string; virtual;
158 procedure SetParent(AValue: TDpiWinControl); virtual;
159 procedure SetCaption(AValue: string); virtual;
160 procedure SetHeight(AValue: Integer); virtual;
161 procedure SetLeft(AValue: Integer); virtual;
162 procedure SetTop(AValue: Integer); virtual;
163 procedure SetVisible(AValue: Boolean); virtual;
164 procedure SetWidth(AValue: Integer); virtual;
165 function GetVclControl: TControl; virtual;
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;
174 procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
175 X, Y: Integer); virtual;
176 procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
177 X, Y: Integer); virtual;
178 procedure MouseMove(Shift: TShiftState; X, Y: Integer); virtual;
179 public
180 procedure ScreenChanged; virtual;
181 procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); virtual;
182 procedure Show;
183 procedure Hide;
184 procedure Invalidate;
185 procedure Repaint;
186 procedure Update;
187 constructor Create(TheOwner: TComponent); override;
188 destructor Destroy; override;
189 property Parent: TDpiWinControl read FParent write SetParent;
190 property BoundsRect: TRect read GetBoundsRect write SetBoundsRect;
191 published
192 property ClientHeight: Integer read GetClientHeight write SetClientHeight;
193 property ClientWidth: Integer read GetClientWidth write SetClientWidth;
194 property Hint: string read GetHint write SetHint;
195 property Top: Integer read FTop write SetTop;
196 property Left: Integer read FLeft write SetLeft;
197 property Width: Integer read FWidth write SetWidth;
198 property Height: Integer read FHeight write SetHeight;
199 property Visible: Boolean read GetVisible write SetVisible;
200 property Caption: string read GetCaption write SetCaption;
201 property Enabled: Boolean read GetEnabled write SetEnabled;
202 property ShowHint: Boolean read GetShowHint write SetShowHint;
203 property Font: TDpiFont read FFont write SetFont;
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;
208 property OnResize: TNotifyEvent read FOnResize write SetOnResize;
209 property OnChangeBounds: TNotifyEvent read FOnChangeBounds write SetOnChangeBounds;
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;
215 end;
216
217 TDpiControls = specialize TFPGObjectList<TDpiControl>;
218
219 { TDpiGraphic }
220
221 TDpiGraphic = class(TPersistent)
222 protected
223 function GetVclGraphic: TGraphic; virtual;
224 public
225 procedure LoadFromFile(const Filename: string);
226 end;
227
228 { TDpiRasterImage }
229
230 TDpiRasterImage = class(TDpiGraphic)
231 private
232 function GetRawImage: TRawImage;
233 protected
234 function GetVclGraphic: TGraphic; override;
235 function GetVclRasterImage: TRasterImage; virtual;
236 public
237 property RawImage: TRawImage read GetRawImage;
238 end;
239
240 { TDpiCanvas }
241
242 TDpiCanvas = class
243 private
244 FFont: TDpiFont;
245 function GetBrush: TBrush;
246 function GetHandle: HDC;
247 function GetHeight: Integer;
248 function GetPen: TPen;
249 function GetPixel(X, Y: Integer): TColor;
250 function GetWidth: Integer;
251 procedure SetBrush(AValue: TBrush);
252 procedure SetFont(AValue: TDpiFont);
253 procedure SetHandle(AValue: HDC);
254 procedure SetPen(AValue: TPen);
255 procedure SetPixel(X, Y: Integer; AValue: TColor);
256 protected
257 function GetVclCanvas: TCanvas; virtual;
258 public
259 VclCanvas: TCanvas;
260 procedure FrameRect(Rect: TRect);
261 procedure Rectangle(X1, Y1, X2, Y2: Integer);
262 function TextWidth(Text: string): Integer;
263 function TextHeight(Text: string): Integer;
264 function TextExtent(Text: string): TSize;
265 procedure TextOut(X, Y: Integer; Text: string);
266 procedure TextRect(ARect: TRect; X, Y: Integer; Text: string);
267 procedure MoveTo(X, Y: Integer);
268 procedure LineTo(X, Y: Integer);
269 procedure FillRect(ARect: TRect);
270 procedure FillRect(X1, Y1, X2, Y2: Integer);
271 procedure Draw(X, Y: Integer; Source: TDpiGraphic);
272 procedure CopyRect(Dest: TRect; SrcCanvas: TDpiCanvas; Source: TRect);
273 constructor Create;
274 destructor Destroy; override;
275 property Handle: HDC read GetHandle write SetHandle;
276 property Pixels[X, Y: Integer]: TColor read GetPixel write SetPixel;
277 property Width: Integer read GetWidth;
278 property Height: Integer read GetHeight;
279 published
280 property Brush: TBrush read GetBrush write SetBrush;
281 property Pen: TPen read GetPen write SetPen;
282 property Font: TDpiFont read FFont write SetFont;
283 end;
284
285 { TDpiGraphicControl }
286
287 TDpiGraphicControl = class(TDpiControl)
288 private
289 FOnPaint: TNotifyEvent;
290 VclGraphicControl: TGraphicControl;
291 FCanvas: TDpiCanvas;
292 procedure SetCanvas(AValue: TDpiCanvas);
293 procedure PaintHandler(Sender: TObject);
294 protected
295 procedure Paint; virtual;
296 function GetVclControl: TControl; override;
297 function GetVclGraphicControl: TGraphicControl; virtual;
298 procedure UpdateVclControl; override;
299 property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
300 public
301 constructor Create(TheOwner: TComponent); override;
302 destructor Destroy; override;
303 published
304 property Canvas: TDpiCanvas read FCanvas write SetCanvas;
305 end;
306
307 { TDpiWinControl }
308
309 TDpiWinControl = class(TDpiControl)
310 private
311 function GetHandle: HWND;
312 function GetOnKeyDown: TKeyEvent;
313 function GetOnKeyPress: TKeyPressEvent;
314 function GetOnKeyUp: TKeyEvent;
315 procedure SetHandle(AValue: HWND);
316 procedure SetOnKeyDown(AValue: TKeyEvent);
317 procedure SetOnKeyPress(AValue: TKeyPressEvent);
318 procedure SetOnKeyUp(AValue: TKeyEvent);
319 protected
320 function GetVclControl: TControl; override;
321 function GetVclWinControl: TWinControl; virtual;
322 public
323 Controls: TDpiControls;
324 procedure ScreenChanged; override;
325 function ControlCount: Integer;
326 constructor Create(TheOwner: TComponent); override;
327 destructor Destroy; override;
328 property Handle: HWND read GetHandle write SetHandle;
329 published
330 property OnKeyDown: TKeyEvent read GetOnKeyDown write SetOnKeyDown;
331 property OnKeyPress: TKeyPressEvent read GetOnKeyPress write SetOnKeyPress;
332 property OnKeyUp: TKeyEvent read GetOnKeyUp write SetOnKeyUp;
333 end;
334
335 { TDpiCustomControl }
336
337 TDpiCustomControl = class(TDpiWinControl)
338 private
339 FCanvas: TDpiCanvas;
340 function GetCanvas: TDpiCanvas;
341 function GetOnPaint: TNotifyEvent;
342 function GetPixelsPerInch: Integer;
343 procedure SetOnPaint(AValue: TNotifyEvent);
344 procedure SetPixelsPerInch(AValue: Integer);
345 protected
346 function GetVclWinControl: TWinControl; override;
347 function GetVclCustomControl: TCustomControl; virtual;
348 public
349 property Canvas: TDpiCanvas read GetCanvas;
350 published
351 property PixelsPerInch: Integer read GetPixelsPerInch write SetPixelsPerInch stored False;
352 property OnPaint: TNotifyEvent read GetOnPaint write SetOnPaint;
353 end;
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
382 { TDpiForm }
383
384 TDpiForm = class(TDpiScrollingWinControl)
385 private
386 FOnActivate: TNotifyEvent;
387 FOnDeactivate: TNotifyEvent;
388 function GetBorderIcons: TBorderIcons;
389 function GetBorderStyle: TBorderStyle;
390 function GetDesignTimePPI: Integer;
391 function GetFormState: TFormState;
392 function GetFormStyle: TFormStyle;
393 function GetKeyPreview: Boolean;
394 function GetLCLVersion: string;
395 function GetModalResult: TModalResult;
396 function GetOnClose: TCloseEvent;
397 function GetOnCloseQuery: TCloseQueryEvent;
398 function GetOnCreate: TNotifyEvent;
399 function GetOnDeactivate: TNotifyEvent;
400 function GetOnDestroy: TNotifyEvent;
401 function GetOnHide: TNotifyEvent;
402 function GetOnShow: TNotifyEvent;
403 function GetPosition: TPosition;
404 function GetWindowState: TWindowState;
405 procedure SetBorderIcons(AValue: TBorderIcons);
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);
411 procedure SetModalResult(AValue: TModalResult);
412 procedure SetOnClose(AValue: TCloseEvent);
413 procedure SetOnCloseQuery(AValue: TCloseQueryEvent);
414 procedure SetOnCreate(AValue: TNotifyEvent);
415 procedure SetOnDeactivate(AValue: TNotifyEvent);
416 procedure SetOnDestroy(AValue: TNotifyEvent);
417 procedure SetOnHide(AValue: TNotifyEvent);
418 procedure SetOnShow(AValue: TNotifyEvent);
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);
425 protected
426 procedure CreateParams(var p: TCreateParams); virtual;
427 procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
428 function GetVclScrollingWinControl: TScrollingWinControl; override;
429 function GetVclForm: TForm; virtual;
430 procedure UpdateVclControl; override;
431 public
432 VclForm: TForm;
433 property ModalResult: TModalResult read GetModalResult write SetModalResult;
434 function ShowModal: Integer; virtual;
435 procedure Close;
436 procedure BringToFront;
437 constructor Create(TheOwner: TComponent); override;
438 destructor Destroy; override;
439 published
440 property DesignTimePPI: Integer read GetDesignTimePPI write SetDesignTimePPI; // Not used
441 property FormState: TFormState read GetFormState;
442 property FormStyle: TFormStyle read GetFormStyle write SetFormStyle;
443 property BorderStyle: TBorderStyle read GetBorderStyle write SetBorderStyle;
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;
449 property OnShow: TNotifyEvent read GetOnShow write SetOnShow;
450 property OnHide: TNotifyEvent read GetOnHide write SetOnHide;
451 property OnCreate: TNotifyEvent read GetOnCreate write SetOnCreate;
452 property OnDestroy: TNotifyEvent read GetOnDestroy write SetOnDestroy;
453 property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;
454 property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;
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;
462 end;
463
464 TDpiForms = specialize TFPGObjectList<TDpiForm>;
465
466 { TDpiButton }
467
468 TDpiButton = class(TDpiControl)
469 private
470 protected
471 function GetVclControl: TControl; override;
472 public
473 VclButton: TButton;
474 destructor Destroy; override;
475 published
476 end;
477
478 { TDpiListBox }
479
480 TDpiListBox = class(TDpiControl)
481 private
482 protected
483 function GetVclControl: TControl; override;
484 public
485 VclListBox: TListBox;
486 destructor Destroy; override;
487 end;
488
489 { TDpiScrollBar }
490
491 TDpiScrollBar = class(TDpiControl)
492 private
493 function GetBorderSpacing: TControlBorderSpacing;
494 function GetKind: TScrollBarKind;
495 function GetMax: Integer;
496 function GetMin: Integer;
497 function GetOnChange: TNotifyEvent;
498 function GetPageSize: Integer;
499 function GetPosition: Integer;
500 procedure SetBorderSpacing(AValue: TControlBorderSpacing);
501 procedure SetKind(AValue: TScrollBarKind);
502 procedure SetMax(AValue: Integer);
503 procedure SetMin(AValue: Integer);
504 procedure SetOnChange(AValue: TNotifyEvent);
505 procedure SetPageSize(AValue: Integer);
506 procedure SetPosition(AValue: Integer);
507 protected
508 function GetVclControl: TControl; override;
509 public
510 VclScrollBar: TScrollBar;
511 destructor Destroy; override;
512 published
513 property PageSize: Integer read GetPageSize write SetPageSize;
514 property Min: Integer read GetMin write SetMin;
515 property Max: Integer read GetMax write SetMax;
516 property Position: Integer read GetPosition write SetPosition;
517 property BorderSpacing: TControlBorderSpacing read GetBorderSpacing write SetBorderSpacing;
518 property Kind: TScrollBarKind read GetKind write SetKind;
519 property OnChange: TNotifyEvent read GetOnChange write SetOnChange;
520 end;
521
522 { TDpiBitmap }
523
524 TDpiBitmap = class(TDpiRasterImage)
525 private
526 FCanvas: TDpiCanvas;
527 function GetCanvas: TDpiCanvas;
528 function GetHeight: Integer;
529 function GetPixelFormat: TPixelFormat;
530 function GetScanLine(Row: Integer): Pointer;
531 function GetWidth: Integer;
532 procedure SetHeight(AValue: Integer);
533 procedure SetPixelFormat(AValue: TPixelFormat);
534 procedure SetWidth(AValue: Integer);
535 protected
536 function GetVclBitmap: TCustomBitmap; virtual;
537 function GetVclRasterImage: TRasterImage; override;
538 public
539 VclBitmap: TBitmap;
540 procedure BeginUpdate;
541 procedure EndUpdate;
542 procedure SetSize(Width, Height: Integer);
543 constructor Create;
544 destructor Destroy; override;
545 procedure Assign(Source: TPersistent); override;
546 property ScanLine[Row: Integer]: Pointer read GetScanLine;
547 published
548 property PixelFormat: TPixelFormat read GetPixelFormat write SetPixelFormat;
549 property Height: Integer read GetHeight write SetHeight;
550 property Width: Integer read GetWidth write SetWidth;
551 property Canvas: TDpiCanvas read GetCanvas;
552 end;
553
554 { TDpiPicture }
555
556 TDpiPicture = class(TPersistent)
557 private
558 FBitmap: TDpiBitmap;
559 procedure SetBitmap(AValue: TDpiBitmap);
560 published
561 procedure LoadFromFile(FileName: string);
562 property Bitmpa: TDpiBitmap read FBitmap write SetBitmap;
563 end;
564
565 { TDpiImage }
566
567 TDpiImage = class(TDpiControl)
568 private
569 FDpiPicture: TDpiPicture;
570 FStretch: Boolean;
571 procedure SetPicture(AValue: TDpiPicture);
572 procedure SetStretch(AValue: Boolean);
573 protected
574 public
575 VclImage: TImage;
576 function GetVclControl: TControl; override;
577 destructor Destroy; override;
578 published
579 property Stretch: Boolean read FStretch write SetStretch;
580 property Picture: TDpiPicture read FDpiPicture write SetPicture;
581 end;
582
583 { TDpiPaintBox }
584
585 TDpiPaintBox = class(TDpiGraphicControl)
586 private
587 function GetOnPaint: TNotifyEvent;
588 procedure SetOnPaint(AValue: TNotifyEvent);
589 public
590 VclPaintBox: TPaintBox;
591 function GetVclGraphicControl: TGraphicControl; override;
592 constructor Create(TheOwner: TComponent); override;
593 destructor Destroy; override;
594 published
595 end;
596
597 { TDpiScreen }
598
599 TDpiScreen = class
600 private
601 FDpi: Integer;
602 FActiveForm: TDpiForm;
603 function GetActiveForm: TDpiForm;
604 function GetFormCount: Integer;
605 function GetHeight: Integer;
606 function GetWidth: Integer;
607 procedure SetActiveForm(AValue: TDpiForm);
608 procedure SetDpi(AValue: Integer);
609 procedure UpdateForms;
610 public
611 Forms: TDpiForms;
612 constructor Create;
613 destructor Destroy; override;
614 property FormCount: Integer read GetFormCount;
615 property ActiveForm: TDpiForm read GetActiveForm write SetActiveForm;
616 published
617 property Dpi: Integer read FDpi write SetDpi;
618 property Width: Integer read GetWidth;
619 property Height: Integer read GetHeight;
620 end;
621
622 { TDpiJpegImage }
623
624 TDpiJpegImage = class(TDpiBitmap)
625 protected
626 function GetVclBitmap: TCustomBitmap; override;
627 function GetVclJpeg: TJPEGImage; virtual;
628 public
629 VclJpeg: TJPEGImage;
630 end;
631
632 { TDpiPortableNetworkGraphic }
633
634 TDpiPortableNetworkGraphic = class(TDpiBitmap)
635 protected
636 function GetVclBitmap: TCustomBitmap; override;
637 function GetVclPng: TPortableNetworkGraphic; virtual;
638 public
639 VclPng: TPortableNetworkGraphic;
640 end;
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
667var
668 DpiFormFileDesc: TDpiFormFileDesc;
669 DpiScreen: TDpiScreen;
670 DpiApplication: TDpiApplication;
671
672procedure Register;
673function DpiBitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc: Integer; Rop: DWORD): Boolean;
674
675
676implementation
677
678resourcestring
679 SDpiFormTitle = 'DpiForm form';
680 SDpiFormDescription = 'DPI aware form';
681
682procedure Register;
683begin
684 FormEditingHook.RegisterDesignerBaseClass(TDpiForm);
685 DpiFormFileDesc := TDpiFormFileDesc.Create;
686 RegisterProjectFileDescriptor(DpiFormFileDesc);
687 RegisterComponents('DpiControls', [TDpiButton, TDpiImage, TDpiPaintBox, TDpiListBox]);
688end;
689
690function ScaleToVcl(Value: Integer): Integer;
691begin
692 Result := Round(Value * DpiScreen.Dpi / 96);
693end;
694
695function ScaleFromVcl(Value: Integer): Integer;
696begin
697 Result := Round(Value * 96 / DpiScreen.Dpi);
698end;
699
700function ScalePointToVcl(Value: TPoint): TPoint;
701begin
702 Result.X := ScaleToVcl(Value.X);
703 Result.Y := ScaleToVcl(Value.Y);
704end;
705
706function ScalePointFromVcl(Value: TPoint): TPoint;
707begin
708 Result.X := ScaleFromVcl(Value.X);
709 Result.Y := ScaleFromVcl(Value.Y);
710end;
711
712function ScaleRectToVcl(Value: TRect): TRect;
713begin
714 Result.Left := ScaleToVcl(Value.Left);
715 Result.Top := ScaleToVcl(Value.Top);
716 Result.Right := ScaleToVcl(Value.Right);
717 Result.Bottom := ScaleToVcl(Value.Bottom);
718end;
719
720function ScaleRectFromVcl(Value: TRect): TRect;
721begin
722 Result.Left := ScaleFromVcl(Value.Left);
723 Result.Top := ScaleFromVcl(Value.Top);
724 Result.Right := ScaleFromVcl(Value.Right);
725 Result.Bottom := ScaleFromVcl(Value.Bottom);
726end;
727
728function DpiBitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc,
729 YSrc: Integer; Rop: DWORD): Boolean;
730begin
731 Result := BitBlt(DestDC, ScaleToVcl(X), ScaleToVcl(Y), ScaleToVcl(Width),
732 ScaleToVcl(Height), SrcDC, ScaleToVcl(XSrc), ScaleToVcl(YSrc), Rop);
733end;
734
735{ TDpiSizeConstraints }
736
737procedure TDpiSizeConstraints.SetMaxHeight(AValue: TConstraintSize);
738begin
739 if FMaxHeight=AValue then Exit;
740 FMaxHeight:=AValue;
741end;
742
743procedure TDpiSizeConstraints.SetMaxWidth(AValue: TConstraintSize);
744begin
745 if FMaxWidth=AValue then Exit;
746 FMaxWidth:=AValue;
747end;
748
749procedure TDpiSizeConstraints.SetMinHeight(AValue: TConstraintSize);
750begin
751 if FMinHeight=AValue then Exit;
752 FMinHeight:=AValue;
753end;
754
755procedure TDpiSizeConstraints.SetMinWidth(AValue: TConstraintSize);
756begin
757 if FMinWidth=AValue then Exit;
758 FMinWidth:=AValue;
759end;
760
761{ TDpiScrollingWinControl }
762
763function TDpiScrollingWinControl.GetVclCustomControl: TCustomControl;
764begin
765 Result := GetVclScrollingWinControl;
766end;
767
768function TDpiScrollingWinControl.GetVclScrollingWinControl: TScrollingWinControl;
769begin
770 Result := nil;
771end;
772
773constructor TDpiScrollingWinControl.Create(TheOwner: TComponent);
774begin
775 inherited;
776 FHorzScrollBar := TDpiControlScrollBar.Create;
777 FVertScrollBar := TDpiControlScrollBar.Create;
778end;
779
780destructor TDpiScrollingWinControl.Destroy;
781begin
782 FreeAndNil(FHorzScrollBar);
783 FreeAndNil(FVertScrollBar);
784 inherited Destroy;
785end;
786
787{ TDpiControlScrollBar }
788
789function TDpiControlScrollBar.GetVisible: Boolean;
790begin
791
792end;
793
794procedure TDpiControlScrollBar.SetVisible(AValue: Boolean);
795begin
796
797end;
798
799{ TGraphicControlEx }
800
801procedure TGraphicControlEx.Paint;
802begin
803 inherited Paint;
804end;
805
806{ TFormEx }
807
808procedure TFormEx.WndProc(var TheMessage: TLMessage);
809begin
810 inherited WndProc(TheMessage);
811 if Assigned(FOnMessage) then
812 FOnMessage(TheMessage);
813end;
814
815{ TDpiApplication }
816
817procedure TDpiApplication.SetMainForm(AValue: TDpiForm);
818begin
819 FMainForm := AValue;
820end;
821
822function TDpiApplication.GetTitle: string;
823begin
824 Result := GetVclApplication.Title;
825end;
826
827function TDpiApplication.GetShowMainForm: Boolean;
828begin
829 Result := GetVclApplication.ShowMainForm;
830end;
831
832function TDpiApplication.GetMainForm: TDpiForm;
833begin
834 Result := FMainForm;
835end;
836
837procedure TDpiApplication.SetShowMainForm(AValue: Boolean);
838begin
839 GetVclApplication.ShowMainForm := AValue;
840end;
841
842procedure TDpiApplication.SetTitle(AValue: string);
843begin
844 GetVclApplication.Title := AValue;
845end;
846
847function TDpiApplication.GetVclApplication: TApplication;
848begin
849 Result := Application;
850end;
851
852procedure TDpiApplication.Run;
853begin
854 if (FMainForm <> nil) and GetShowMainForm then FMainForm.Show;
855 GetVclApplication.Run;
856end;
857
858procedure TDpiApplication.Initialize;
859begin
860 GetVclApplication.Initialize;
861end;
862
863procedure TDpiApplication.ProcessMessages;
864begin
865 GetVclApplication.ProcessMessages;
866end;
867
868procedure TDpiApplication.UpdateMainForm(AForm: TDpiForm);
869begin
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);
877end;
878
879procedure TDpiApplication.CreateForm(InstanceClass: TComponentClass; out
880 Reference);
881var
882 Instance: TComponent;
883 ok: Boolean;
884 AForm: TDpiForm;
885begin
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;
917end;
918
919{ TDpiJpegImage }
920
921function TDpiJpegImage.GetVclBitmap: TCustomBitmap;
922begin
923 Result := GetVclJpeg;
924end;
925
926function TDpiJpegImage.GetVclJpeg: TJPEGImage;
927begin
928 if not Assigned(VclJpeg) then VclJpeg := TJPEGImage.Create;
929 Result := VclJpeg;
930end;
931
932{ TDpiPortableNetworkGraphic }
933
934function TDpiPortableNetworkGraphic.GetVclBitmap: TCustomBitmap;
935begin
936 Result := GetVclPng;
937end;
938
939function TDpiPortableNetworkGraphic.GetVclPng: TPortableNetworkGraphic;
940begin
941 if not Assigned(VclPng) then VclPng := TPortableNetworkGraphic.Create;
942 Result := VclPng;
943end;
944
945{ TDpiCustomControl }
946
947function TDpiCustomControl.GetOnPaint: TNotifyEvent;
948begin
949 Result := GetVclCustomControl.OnPaint;
950end;
951
952function TDpiCustomControl.GetPixelsPerInch: Integer;
953begin
954// Result := GetVclCustomControl.P;
955end;
956
957function TDpiCustomControl.GetCanvas: TDpiCanvas;
958begin
959 if not Assigned(FCanvas) then begin
960 FCanvas := TDpiCanvas.Create;
961 FCanvas.VclCanvas := GetVclCustomControl.Canvas;
962 end;
963 Result := FCanvas;
964end;
965
966procedure TDpiCustomControl.SetOnPaint(AValue: TNotifyEvent);
967begin
968 GetVclCustomControl.OnPaint := AValue;
969end;
970
971procedure TDpiCustomControl.SetPixelsPerInch(AValue: Integer);
972begin
973
974end;
975
976function TDpiCustomControl.GetVclWinControl: TWinControl;
977begin
978 Result := GetVclCustomControl;
979end;
980
981function TDpiCustomControl.GetVclCustomControl: TCustomControl;
982begin
983 Result := nil;
984end;
985
986{ TDpiScrollBar }
987
988function TDpiScrollBar.GetBorderSpacing: TControlBorderSpacing;
989begin
990 Result := VclScrollBar.BorderSpacing;
991end;
992
993function TDpiScrollBar.GetKind: TScrollBarKind;
994begin
995 Result := VclScrollBar.Kind;
996end;
997
998function TDpiScrollBar.GetMax: Integer;
999begin
1000 Result := VclScrollBar.Max;
1001end;
1002
1003function TDpiScrollBar.GetMin: Integer;
1004begin
1005 Result := VclScrollBar.Min;
1006end;
1007
1008function TDpiScrollBar.GetOnChange: TNotifyEvent;
1009begin
1010 Result := VclScrollBar.OnChange;
1011end;
1012
1013function TDpiScrollBar.GetPageSize: Integer;
1014begin
1015 Result := VclScrollBar.PageSize;
1016end;
1017
1018function TDpiScrollBar.GetPosition: Integer;
1019begin
1020 Result := VclScrollBar.Position;
1021end;
1022
1023procedure TDpiScrollBar.SetBorderSpacing(AValue: TControlBorderSpacing);
1024begin
1025 VclScrollBar.BorderSpacing := AValue;
1026end;
1027
1028procedure TDpiScrollBar.SetKind(AValue: TScrollBarKind);
1029begin
1030 VclScrollBar.Kind := AValue;
1031end;
1032
1033procedure TDpiScrollBar.SetMax(AValue: Integer);
1034begin
1035 VclScrollBar.Max := AValue;
1036end;
1037
1038procedure TDpiScrollBar.SetMin(AValue: Integer);
1039begin
1040 VclScrollBar.Min := Avalue;
1041end;
1042
1043procedure TDpiScrollBar.SetOnChange(AValue: TNotifyEvent);
1044begin
1045 VclScrollBar.OnChange := AValue;
1046end;
1047
1048procedure TDpiScrollBar.SetPageSize(AValue: Integer);
1049begin
1050 VclScrollBar.PageSize := AValue;
1051end;
1052
1053procedure TDpiScrollBar.SetPosition(AValue: Integer);
1054begin
1055 VclScrollBar.Position := AValue;
1056end;
1057
1058function TDpiScrollBar.GetVclControl: TControl;
1059begin
1060 if not Assigned(VclScrollBar) then VclScrollBar := TScrollBar.Create(nil);
1061 Result := VclScrollBar;
1062end;
1063
1064destructor TDpiScrollBar.Destroy;
1065begin
1066 FreeAndNil(VclScrollBar);
1067 inherited Destroy;
1068end;
1069
1070{ TDpiRasterImage }
1071
1072function TDpiRasterImage.GetRawImage: TRawImage;
1073begin
1074 Result := GetVclRasterImage.RawImage;
1075end;
1076
1077function TDpiRasterImage.GetVclRasterImage: TRasterImage;
1078begin
1079 Result := GetVclRasterImage;
1080end;
1081
1082function TDpiRasterImage.GetVclGraphic: TGraphic;
1083begin
1084 Result := GetVclRasterImage;
1085end;
1086
1087{ TDpiGraphic }
1088
1089function TDpiGraphic.GetVclGraphic: TGraphic;
1090begin
1091 Result := nil;
1092end;
1093
1094procedure TDpiGraphic.LoadFromFile(const Filename: string);
1095begin
1096 GetVclGraphic.LoadFromFile(FileName);
1097end;
1098
1099{ TDpiBitmap }
1100
1101function TDpiBitmap.GetHeight: Integer;
1102begin
1103 Result := ScaleFromVcl(GetVclBitmap.Height);
1104end;
1105
1106function TDpiBitmap.GetCanvas: TDpiCanvas;
1107begin
1108 if not Assigned(FCanvas) then begin
1109 FCanvas := TDpiCanvas.Create;
1110 FCanvas.VclCanvas := GetVclBitmap.Canvas;
1111 end;
1112 Result := FCanvas;
1113end;
1114
1115function TDpiBitmap.GetPixelFormat: TPixelFormat;
1116begin
1117 Result := GetVclBitmap.PixelFormat;
1118end;
1119
1120function TDpiBitmap.GetScanLine(Row: Integer): Pointer;
1121begin
1122 Result := GetVclBitmap.ScanLine[Row];
1123end;
1124
1125function TDpiBitmap.GetWidth: Integer;
1126begin
1127 Result := ScaleFromVcl(GetVclBitmap.Width);
1128end;
1129
1130procedure TDpiBitmap.SetHeight(AValue: Integer);
1131begin
1132 GetVclBitmap.Height := ScaleToVcl(AValue);
1133end;
1134
1135procedure TDpiBitmap.SetPixelFormat(AValue: TPixelFormat);
1136begin
1137 GetVclBitmap.PixelFormat := AValue;
1138end;
1139
1140procedure TDpiBitmap.SetWidth(AValue: Integer);
1141begin
1142 GetVclBitmap.Width := ScaleToVcl(AValue);
1143end;
1144
1145function TDpiBitmap.GetVclBitmap: TCustomBitmap;
1146begin
1147 if not Assigned(VclBitmap) then begin
1148 VclBitmap := TBitmap.Create;
1149 Canvas.VclCanvas := VclBitmap.Canvas;
1150 end;
1151 Result := VclBitmap;
1152end;
1153
1154procedure TDpiBitmap.BeginUpdate;
1155begin
1156 GetVclBitmap.BeginUpdate;
1157end;
1158
1159procedure TDpiBitmap.EndUpdate;
1160begin
1161 GetVclBitmap.EndUpdate;
1162end;
1163
1164procedure TDpiBitmap.SetSize(Width, Height: Integer);
1165begin
1166 GetVclBitmap.SetSize(ScaleToVcl(Width), ScaleToVcl(Height));
1167end;
1168
1169constructor TDpiBitmap.Create;
1170begin
1171 inherited;
1172end;
1173
1174destructor TDpiBitmap.Destroy;
1175begin
1176 FreeAndNil(FCanvas);
1177 FreeAndNil(VclBitmap);
1178 inherited;
1179end;
1180
1181procedure TDpiBitmap.Assign(Source: TPersistent);
1182begin
1183 if Source is TDpiBitmap then begin
1184 GetVclBitmap.Assign((Source as TDpiBitmap).GetVclBitmap);
1185 end else inherited;
1186end;
1187
1188function TDpiBitmap.GetVclRasterImage: TRasterImage;
1189begin
1190 Result := GetVclBitmap;
1191end;
1192
1193{ TDpiListBox }
1194
1195function TDpiListBox.GetVclControl: TControl;
1196begin
1197 if not Assigned(VclListBox) then VclListBox := TListBox.Create(nil);
1198 Result := VclListBox;
1199end;
1200
1201destructor TDpiListBox.Destroy;
1202begin
1203 FreeAndNil(VclListBox);
1204 inherited Destroy;
1205end;
1206
1207{ TDpiPaintBox }
1208
1209function TDpiPaintBox.GetOnPaint: TNotifyEvent;
1210begin
1211 Result := VclPaintBox.OnPaint;
1212end;
1213
1214procedure TDpiPaintBox.SetOnPaint(AValue: TNotifyEvent);
1215begin
1216 VclPaintBox.OnPaint := AValue;
1217end;
1218
1219function TDpiPaintBox.GetVclGraphicControl: TGraphicControl;
1220begin
1221 if not Assigned(VclPaintBox) then VclPaintBox := TPaintBox.Create(nil);
1222 Result := VclPaintBox;
1223end;
1224
1225constructor TDpiPaintBox.Create(TheOwner: TComponent);
1226begin
1227 inherited;
1228 Canvas := TDpiCanvas.Create;
1229 Canvas.VclCanvas := VclPaintBox.Canvas;
1230 Canvas.Font.VclFont := VclPaintBox.Canvas.Font;
1231 UpdateVclControl;
1232 ScreenChanged;
1233end;
1234
1235destructor TDpiPaintBox.Destroy;
1236begin
1237 FreeAndNil(VclPaintBox);
1238 inherited;
1239end;
1240
1241{ TDpiPicture }
1242
1243procedure TDpiPicture.SetBitmap(AValue: TDpiBitmap);
1244begin
1245 if FBitmap = AValue then Exit;
1246 FBitmap := AValue;
1247end;
1248
1249procedure TDpiPicture.LoadFromFile(FileName: string);
1250begin
1251end;
1252
1253
1254{ TDpiCanvas }
1255
1256function TDpiCanvas.GetBrush: TBrush;
1257begin
1258 Result := GetVclCanvas.Brush;
1259end;
1260
1261function TDpiCanvas.GetHandle: HDC;
1262begin
1263 Result := GetVclCanvas.Handle;
1264end;
1265
1266function TDpiCanvas.GetHeight: Integer;
1267begin
1268 Result := ScaleFromVcl(GetVclCanvas.Height);
1269end;
1270
1271function TDpiCanvas.GetPen: TPen;
1272begin
1273 Result := GetVclCanvas.Pen;
1274end;
1275
1276function TDpiCanvas.GetPixel(X, Y: Integer): TColor;
1277begin
1278 Result := GetVclCanvas.Pixels[ScaleToVcl(X), ScaleToVcl(Y)];
1279end;
1280
1281function TDpiCanvas.GetWidth: Integer;
1282begin
1283 Result := ScaleFromVcl(GetVclCanvas.Width);
1284end;
1285
1286procedure TDpiCanvas.SetBrush(AValue: TBrush);
1287begin
1288 GetVclCanvas.Brush := AValue;
1289end;
1290
1291procedure TDpiCanvas.SetFont(AValue: TDpiFont);
1292begin
1293 if FFont = AValue then Exit;
1294 FFont := AValue;
1295end;
1296
1297procedure TDpiCanvas.SetHandle(AValue: HDC);
1298begin
1299 GetVclCanvas.Handle := AValue;
1300end;
1301
1302procedure TDpiCanvas.SetPen(AValue: TPen);
1303begin
1304 GetVclCanvas.Pen := AValue;
1305end;
1306
1307procedure TDpiCanvas.SetPixel(X, Y: Integer; AValue: TColor);
1308begin
1309 GetVclCanvas.Pixels[ScaleToVcl(X), ScaleToVcl(Y)] := AValue;
1310end;
1311
1312function TDpiCanvas.GetVclCanvas: TCanvas;
1313begin
1314 //if not Assigned(VclCanvas) then VclCanvas := TCanvas.Create;
1315 Result := VclCanvas;
1316end;
1317
1318procedure TDpiCanvas.FrameRect(Rect: TRect);
1319begin
1320 GetVclCanvas.FrameRect(ScaleRectToVcl(Rect));
1321end;
1322
1323procedure TDpiCanvas.Rectangle(X1, Y1, X2, Y2: Integer);
1324begin
1325 GetVclCanvas.Rectangle(ScaleToVcl(X1), ScaleToVcl(Y1), ScaleToVcl(X2), ScaleToVcl(Y2));
1326end;
1327
1328function TDpiCanvas.TextWidth(Text: string): Integer;
1329begin
1330 Result := ScaleFromVcl(GetVclCanvas.TextWidth(Text));
1331end;
1332
1333function TDpiCanvas.TextHeight(Text: string): Integer;
1334begin
1335 Result := ScaleFromVcl(GetVclCanvas.TextHeight(Text));
1336end;
1337
1338function TDpiCanvas.TextExtent(Text: string): TSize;
1339begin
1340 Result := GetVclCanvas.TextExtent(Text);
1341end;
1342
1343procedure TDpiCanvas.TextOut(X, Y: Integer; Text: string);
1344begin
1345 GetVclCanvas.TextOut(ScaleToVcl(X), ScaleToVcl(Y), Text);
1346end;
1347
1348procedure TDpiCanvas.TextRect(ARect: TRect; X, Y: Integer; Text: string);
1349begin
1350 GetVclCanvas.TextRect(ARect, X, Y, Text);
1351end;
1352
1353procedure TDpiCanvas.MoveTo(X, Y: Integer);
1354begin
1355 GetVclCanvas.MoveTo(ScaleToVcl(X), ScaleToVcl(Y));
1356end;
1357
1358procedure TDpiCanvas.LineTo(X, Y: Integer);
1359begin
1360 GetVclCanvas.LineTo(ScaleToVcl(X), ScaleToVcl(Y));
1361end;
1362
1363procedure TDpiCanvas.FillRect(ARect: TRect);
1364begin
1365 GetVclCanvas.FillRect(ScaleRectToVcl(ARect));
1366end;
1367
1368procedure TDpiCanvas.FillRect(X1, Y1, X2, Y2: Integer);
1369begin
1370 GetVclCanvas.FillRect(ScaleToVcl(X1), ScaleToVcl(Y1), ScaleToVcl(X2), ScaleToVcl(Y2));
1371end;
1372
1373procedure TDpiCanvas.Draw(X, Y: Integer; Source: TDpiGraphic);
1374begin
1375 GetVclCanvas.Draw(ScaleToVcl(X), ScaleToVcl(Y), Source.GetVclGraphic);
1376end;
1377
1378procedure TDpiCanvas.CopyRect(Dest: TRect; SrcCanvas: TDpiCanvas;
1379 Source: TRect);
1380begin
1381 GetVclCanvas.CopyRect(Dest, SrcCanvas.VclCanvas, Source);
1382end;
1383
1384constructor TDpiCanvas.Create;
1385begin
1386 FFont := TDpiFont.Create;
1387end;
1388
1389destructor TDpiCanvas.Destroy;
1390begin
1391 FreeAndNil(FFont);
1392 inherited;
1393end;
1394
1395{ TDpiGraphicControl }
1396
1397procedure TDpiGraphicControl.SetCanvas(AValue: TDpiCanvas);
1398begin
1399 if FCanvas = AValue then Exit;
1400 FCanvas := AValue;
1401end;
1402
1403procedure TDpiGraphicControl.PaintHandler(Sender: TObject);
1404begin
1405 Paint;
1406 if Assigned(FOnPaint) then
1407 FOnPaint(Sender);
1408end;
1409
1410procedure TDpiGraphicControl.Paint;
1411begin
1412end;
1413
1414function TDpiGraphicControl.GetVclControl: TControl;
1415begin
1416 Result := GetVclGraphicControl;
1417end;
1418
1419function TDpiGraphicControl.GetVclGraphicControl: TGraphicControl;
1420begin
1421 if not Assigned(VclGraphicControl) then begin
1422 VclGraphicControl := TGraphicControlEx.Create(nil);
1423 (VclGraphicControl as TGraphicControlEx).OnPaint := @PaintHandler;
1424 end;
1425 Result := VclGraphicControl;
1426end;
1427
1428procedure TDpiGraphicControl.UpdateVclControl;
1429begin
1430 inherited;
1431 (GetVclGraphicControl as TGraphicControlEx).OnMouseDown := @MouseDownHandler;
1432 (GetVclGraphicControl as TGraphicControlEx).OnMouseUp := @MouseUpHandler;
1433 (GetVclGraphicControl as TGraphicControlEx).OnMouseMove := @MouseMoveHandler;
1434end;
1435
1436constructor TDpiGraphicControl.Create(TheOwner: TComponent);
1437begin
1438 inherited;
1439 FCanvas := TDpiCanvas.Create;
1440 FCanvas.VclCanvas := GetVclGraphicControl.Canvas;
1441end;
1442
1443destructor TDpiGraphicControl.Destroy;
1444begin
1445 FreeAndNil(FCanvas);
1446 inherited;
1447end;
1448
1449
1450{ TDpiImage }
1451
1452procedure TDpiImage.SetStretch(AValue: Boolean);
1453begin
1454 if FStretch = AValue then Exit;
1455 FStretch := AValue;
1456 VclImage.Stretch := AValue;
1457end;
1458
1459procedure TDpiImage.SetPicture(AValue: TDpiPicture);
1460begin
1461 if FDpiPicture = AValue then Exit;
1462 FDpiPicture := AValue;
1463end;
1464
1465function TDpiImage.GetVclControl: TControl;
1466begin
1467 if not Assigned(VclImage) then VclImage := TImage.Create(nil);
1468 Result := VclImage;
1469end;
1470
1471destructor TDpiImage.Destroy;
1472begin
1473 FreeAndNil(VclImage);
1474 inherited Destroy;
1475end;
1476
1477{ TDpiFont }
1478
1479procedure TDpiFont.SetSize(AValue: Integer);
1480begin
1481 if FSize = AValue then Exit;
1482 FSize := AValue;
1483 DoChange;
1484end;
1485
1486procedure TDpiFont.DoChange;
1487begin
1488 if Assigned(FOnChange) then FOnChange(Self);
1489end;
1490
1491procedure TDpiFont.SetStyle(AValue: TFontStyles);
1492begin
1493 GetVclFont.Style := AValue;
1494end;
1495
1496procedure TDpiFont.ScreenChanged;
1497begin
1498 DoChange;
1499end;
1500
1501function TDpiFont.GetVclFont: TFont;
1502begin
1503 if not Assigned(VclFont) then VclFont := TFont.Create;
1504 Result := VclFont;
1505end;
1506
1507procedure TDpiFont.SetOnChange(AValue: TNotifyEvent);
1508begin
1509 if FOnChange = AValue then Exit;
1510 FOnChange := AValue;
1511end;
1512
1513procedure TDpiFont.SetPixelsPerInch(AValue: Integer);
1514begin
1515 GetVclFont.PixelsPerInch := PixelsPerInch;
1516end;
1517
1518function TDpiFont.GetName: string;
1519begin
1520 Result := GetVclFont.Name;
1521end;
1522
1523function TDpiFont.GetColor: TColor;
1524begin
1525 Result := GetVclFont.Color;
1526end;
1527
1528function TDpiFont.GetCharSet: TFontCharSet;
1529begin
1530 Result := GetVclFont.CharSet;
1531end;
1532
1533function TDpiFont.GetHeight: Integer;
1534begin
1535 Result := GetVclFont.Height;
1536end;
1537
1538function TDpiFont.GetPixelsPerInch: Integer;
1539begin
1540 Result := GetVclFont.PixelsPerInch;
1541end;
1542
1543function TDpiFont.GetStyle: TFontStyles;
1544begin
1545 Result := GetVclFont.Style;
1546end;
1547
1548function TDpiFont.IsNameStored: Boolean;
1549begin
1550 Result := GetVclFont.Name <> 'default';
1551end;
1552
1553procedure TDpiFont.SetCharSet(AValue: TFontCharSet);
1554begin
1555 GetVclFont.CharSet := AValue;
1556end;
1557
1558procedure TDpiFont.SetColor(AValue: TColor);
1559begin
1560 GetVclFont.Color := AValue;
1561end;
1562
1563procedure TDpiFont.SetHeight(AValue: Integer);
1564begin
1565 GetVclFont.Height := AValue;
1566end;
1567
1568procedure TDpiFont.SetName(AValue: string);
1569begin
1570 GetVclFont.Name := AValue;
1571end;
1572
1573constructor TDpiFont.Create;
1574begin
1575 Size := 8;
1576end;
1577
1578destructor TDpiFont.Destroy;
1579begin
1580 inherited Destroy;
1581end;
1582
1583procedure TDpiFont.Assign(Source: TPersistent);
1584begin
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;
1590end;
1591
1592{ TDpiWinControl }
1593
1594function TDpiWinControl.GetHandle: HWND;
1595begin
1596 Result := GetVclWinControl.Handle;
1597end;
1598
1599function TDpiWinControl.GetOnKeyDown: TKeyEvent;
1600begin
1601 Result := GetVclWinControl.OnKeyDown;
1602end;
1603
1604function TDpiWinControl.GetOnKeyPress: TKeyPressEvent;
1605begin
1606 Result := GetVclWinControl.OnKeyPress;
1607end;
1608
1609function TDpiWinControl.GetOnKeyUp: TKeyEvent;
1610begin
1611 Result := GetVclWinControl.OnKeyUp;
1612end;
1613
1614procedure TDpiWinControl.SetHandle(AValue: HWND);
1615begin
1616 GetVclWinControl.Handle := AValue;
1617end;
1618
1619procedure TDpiWinControl.SetOnKeyDown(AValue: TKeyEvent);
1620begin
1621 GetVclWinControl.OnKeyDown := AValue;
1622end;
1623
1624procedure TDpiWinControl.SetOnKeyPress(AValue: TKeyPressEvent);
1625begin
1626 GetVclWinControl.OnKeyPress := AValue;
1627end;
1628
1629procedure TDpiWinControl.SetOnKeyUp(AValue: TKeyEvent);
1630begin
1631 GetVclWinControl.OnKeyUp := AValue;
1632end;
1633
1634function TDpiWinControl.GetVclControl: TControl;
1635begin
1636 Result := GetVclWinControl;
1637end;
1638
1639function TDpiWinControl.GetVclWinControl: TWinControl;
1640begin
1641 Result := nil;
1642end;
1643
1644procedure TDpiWinControl.ScreenChanged;
1645var
1646 I: Integer;
1647begin
1648 inherited;
1649 for I := 0 to Controls.Count - 1 do
1650 Controls[I].ScreenChanged;
1651end;
1652
1653function TDpiWinControl.ControlCount: Integer;
1654begin
1655 Result := Controls.Count;
1656end;
1657
1658constructor TDpiWinControl.Create(TheOwner: TComponent);
1659begin
1660 Controls := TDpiControls.Create;
1661 Controls.FreeObjects := False;
1662 inherited;
1663end;
1664
1665destructor TDpiWinControl.Destroy;
1666begin
1667 FreeAndNil(Controls);
1668 inherited Destroy;
1669end;
1670
1671{ TDpiScreen }
1672
1673procedure TDpiScreen.SetDpi(AValue: Integer);
1674begin
1675 if FDpi = AValue then Exit;
1676 FDpi := AValue;
1677 UpdateForms;
1678end;
1679
1680function TDpiScreen.GetWidth: Integer;
1681begin
1682 Result := ScaleFromVcl(Screen.Width);
1683end;
1684
1685procedure TDpiScreen.SetActiveForm(AValue: TDpiForm);
1686begin
1687 FActiveForm := AValue;
1688end;
1689
1690function TDpiScreen.GetHeight: Integer;
1691begin
1692 Result := ScaleFromVcl(Screen.Height);
1693end;
1694
1695function TDpiScreen.GetFormCount: Integer;
1696begin
1697 Result := Forms.Count;
1698end;
1699
1700function TDpiScreen.GetActiveForm: TDpiForm;
1701begin
1702 Result := FActiveForm;
1703end;
1704
1705procedure TDpiScreen.UpdateForms;
1706var
1707 I: Integer;
1708begin
1709 for I := 0 to Forms.Count - 1 do
1710 Forms[I].ScreenChanged;
1711end;
1712
1713constructor TDpiScreen.Create;
1714begin
1715 Forms := TDpiForms.Create;
1716 Forms.FreeObjects := False;
1717 Dpi := 144;
1718end;
1719
1720destructor TDpiScreen.Destroy;
1721begin
1722 FreeAndNil(Forms);
1723 inherited Destroy;
1724end;
1725
1726{ TDpiWinControl }
1727
1728
1729{ TDpiButton }
1730
1731function TDpiButton.GetVclControl: TControl;
1732begin
1733 if not Assigned(VclButton) then VclButton := TButton.Create(nil);
1734 Result := VclButton;
1735end;
1736
1737destructor TDpiButton.Destroy;
1738begin
1739 FreeAndNil(VclButton);
1740 inherited;
1741end;
1742
1743{ TDpiControl }
1744
1745procedure TDpiControl.SetTop(AValue: Integer);
1746begin
1747 if FTop = AValue then Exit;
1748 FTop := AValue;
1749 UpdateBounds;
1750end;
1751
1752procedure TDpiControl.SetVisible(AValue: Boolean);
1753begin
1754 GetVclControl.Visible := AValue;
1755end;
1756
1757procedure TDpiControl.SetWidth(AValue: Integer);
1758begin
1759 if FWidth = AValue then Exit;
1760 FWidth := AValue;
1761 UpdateBounds;
1762end;
1763
1764function TDpiControl.GetVclControl: TControl;
1765begin
1766 Result := nil;
1767end;
1768
1769procedure TDpiControl.UpdateVclControl;
1770begin
1771 GetVclControl.OnResize := @VclFormResize;
1772 GetVclControl.OnChangeBounds := @VclChangeBounds;
1773end;
1774
1775procedure TDpiControl.MouseDownHandler(Sender: TObject; Button: TMouseButton;
1776 Shift: TShiftState; X, Y: Integer);
1777begin
1778 MouseDown(Button, Shift, ScaleFromVcl(X), ScaleFromVcl(Y));
1779 if Assigned(FOnMouseDown) then FOnMouseDown(Self, Button, Shift, ScaleFromVcl(X), ScaleFromVcl(Y));
1780end;
1781
1782procedure TDpiControl.MouseUpHandler(Sender: TObject; Button: TMouseButton;
1783 Shift: TShiftState; X, Y: Integer);
1784begin
1785 MouseUp(Button, Shift, ScaleFromVcl(X), ScaleFromVcl(Y));
1786 if Assigned(FOnMouseUp) then FOnMouseUp(Self, Button, Shift, ScaleFromVcl(X), ScaleFromVcl(Y));
1787end;
1788
1789procedure TDpiControl.MouseMoveHandler(Sender: TObject; Shift: TShiftState; X,
1790 Y: Integer);
1791begin
1792 MouseMove(Shift, ScaleFromVcl(X), ScaleFromVcl(Y));
1793 if Assigned(FOnMouseMove) then FOnMouseMove(Self, Shift, ScaleFromVcl(X), ScaleFromVcl(Y));
1794end;
1795
1796procedure TDpiControl.MouseWheelHandler(Sender: TObject; Shift: TShiftState;
1797 WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
1798begin
1799 if Assigned(FOnMouseWheel) then FOnMouseWheel(Self, Shift, WheelDelta,
1800 ScalePointFromVcl(MousePos), Handled);
1801end;
1802
1803procedure TDpiControl.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
1804 Y: Integer);
1805begin
1806end;
1807
1808procedure TDpiControl.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
1809 Y: Integer);
1810begin
1811end;
1812
1813procedure TDpiControl.MouseMove(Shift: TShiftState; X, Y: Integer);
1814begin
1815end;
1816
1817procedure TDpiControl.ScreenChanged;
1818begin
1819 UpdateBounds;
1820 Font.ScreenChanged;
1821end;
1822
1823procedure TDpiControl.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
1824begin
1825 FLeft := ALeft;
1826 FTop := ATop;
1827 FWidth := AWidth;
1828 FHeight := AHeight;
1829 UpdateBounds;
1830end;
1831
1832procedure TDpiControl.Show;
1833begin
1834 Visible := True;
1835end;
1836
1837procedure TDpiControl.Hide;
1838begin
1839 Visible := False;
1840end;
1841
1842procedure TDpiControl.Invalidate;
1843begin
1844 GetVclControl.Invalidate;
1845end;
1846
1847procedure TDpiControl.Repaint;
1848begin
1849 GetVclControl.Repaint;
1850end;
1851
1852procedure TDpiControl.Update;
1853begin
1854 GetVclControl.Update;
1855end;
1856
1857constructor TDpiControl.Create(TheOwner: TComponent);
1858begin
1859 inherited;
1860 FFont := TDpiFont.Create;
1861 FFont.OnChange := @FontChanged;
1862 FConstraints := TDpiSizeConstraints.Create;
1863 if Assigned(TheOwner) and (TheOwner is TDpiWinControl) then
1864 Parent := TDpiWinControl(TheOwner);
1865 GetVclControl;
1866 UpdateVclControl;
1867 ScreenChanged;
1868end;
1869
1870destructor TDpiControl.Destroy;
1871begin
1872 FreeAndNil(FConstraints);
1873 FreeAndNil(FFont);
1874 inherited Destroy;
1875end;
1876
1877procedure TDpiControl.SetLeft(AValue: Integer);
1878begin
1879 if FLeft = AValue then Exit;
1880 FLeft := AValue;
1881 UpdateBounds;
1882end;
1883
1884procedure TDpiControl.SetCaption(AValue: string);
1885begin
1886 GetVclControl.Caption := AValue;
1887end;
1888
1889procedure TDpiControl.SetParent(AValue: TDpiWinControl);
1890begin
1891 if FParent = AValue then Exit;
1892 if Assigned(FParent) then begin
1893 FParent.Controls.Remove(Self);
1894 if Assigned(FParent) and (FParent is TDpiWinControl) then
1895 GetVclControl.Parent := nil;
1896 end;
1897 FParent := AValue;
1898 if Assigned(FParent) then begin
1899 FParent.Controls.Add(Self);
1900 if Assigned(FParent) and (FParent is TDpiWinControl) then
1901 GetVclControl.Parent := TDpiWinControl(FParent).GetVclWinControl;
1902 end;
1903end;
1904
1905procedure TDpiControl.SetFont(AValue: TDpiFont);
1906begin
1907 if FFont = AValue then Exit;
1908 FFont := AValue;
1909end;
1910
1911procedure TDpiControl.SetHint(AValue: string);
1912begin
1913 GetVclControl.Hint := AValue;
1914end;
1915
1916function TDpiControl.GetBoundsRect: TRect;
1917begin
1918 Result.Left := Left;
1919 Result.Top := Top;
1920 Result.Right := Left + Width;
1921 Result.Bottom := Top + Height;
1922end;
1923
1924function TDpiControl.GetAlign: TAlign;
1925begin
1926 Result := GetVclControl.Align;
1927end;
1928
1929function TDpiControl.GetClientHeight: Integer;
1930begin
1931 Result := ScaleFromVcl(GetVclControl.ClientHeight);
1932end;
1933
1934function TDpiControl.GetClientWidth: Integer;
1935begin
1936 Result := ScaleFromVcl(GetVclControl.ClientWidth);
1937end;
1938
1939function TDpiControl.GetColor: TColor;
1940begin
1941 Result := GetVclControl.Color;
1942end;
1943
1944function TDpiControl.GetCursor: TCursor;
1945begin
1946 Result := GetVclControl.Cursor;
1947end;
1948
1949function TDpiControl.GetEnabled: Boolean;
1950begin
1951 Result := GetVclControl.Enabled;
1952end;
1953
1954function TDpiControl.GetHint: string;
1955begin
1956 Result := GetVclControl.Hint;
1957end;
1958
1959function TDpiControl.GetOnClick: TNotifyEvent;
1960begin
1961 Result := GetVclControl.OnClick;
1962end;
1963
1964function TDpiControl.GetShowHint: Boolean;
1965begin
1966 Result := GetVclControl.ShowHint;
1967end;
1968
1969function TDpiControl.GetVisible: Boolean;
1970begin
1971 Result := GetVclControl.Visible;
1972end;
1973
1974procedure TDpiControl.SetAlign(AValue: TAlign);
1975begin
1976 GetVclControl.Align := AValue;
1977end;
1978
1979procedure TDpiControl.SetBoundsRect(AValue: TRect);
1980begin
1981 SetBounds(AValue.Left, AValue.Top, AValue.Right - AValue.Left, AValue.Bottom - AValue.Top);
1982end;
1983
1984procedure TDpiControl.SetClientHeight(AValue: Integer);
1985begin
1986 GetVclControl.ClientHeight := ScaletoVcl(AValue);
1987end;
1988
1989procedure TDpiControl.SetClientWidth(AValue: Integer);
1990begin
1991 GetVclControl.ClientWidth := ScaletoVcl(AValue);
1992end;
1993
1994procedure TDpiControl.SetColor(AValue: TColor);
1995begin
1996 GetVclControl.Color := AValue;
1997end;
1998
1999procedure TDpiControl.SetCursor(AValue: TCursor);
2000begin
2001 GetVclControl.Cursor := AValue;
2002end;
2003
2004procedure TDpiControl.SetEnabled(AValue: Boolean);
2005begin
2006 GetVclControl.Enabled := AValue;
2007end;
2008
2009procedure TDpiControl.SetOnChangeBounds(AValue: TNotifyEvent);
2010begin
2011 if FOnChangeBounds = AValue then Exit;
2012 FOnChangeBounds := AValue;
2013end;
2014
2015procedure TDpiControl.SetOnClick(AValue: TNotifyEvent);
2016begin
2017 GetVclControl.OnClick := AValue;
2018end;
2019
2020procedure TDpiControl.SetOnResize(AValue: TNotifyEvent);
2021begin
2022 if FOnResize = AValue then Exit;
2023 FOnResize := AValue;
2024end;
2025
2026procedure TDpiControl.SetShowHint(AValue: Boolean);
2027begin
2028 GetVclControl.ShowHint := AValue;
2029end;
2030
2031procedure TDpiControl.VclFormResize(Sender: TObject);
2032begin
2033 BoundsRect := ScaleRectFromVcl(GetVclControl.BoundsRect);
2034 DoFormResize;
2035end;
2036
2037procedure TDpiControl.VclChangeBounds(Sender: TObject);
2038var
2039 NewBounds: TRect;
2040begin
2041 NewBounds := ScaleRectFromVcl(GetVclControl.BoundsRect);
2042 if NewBounds <> BoundsRect then begin
2043 BoundsRect := NewBounds;
2044 DoChangeBounds;
2045 end;
2046end;
2047
2048procedure TDpiControl.DoFormResize;
2049begin
2050 if Assigned(FOnResize) then FOnResize(Self);
2051end;
2052
2053procedure TDpiControl.DoChangeBounds;
2054begin
2055 if Assigned(FOnChangeBounds) then FOnChangeBounds(Self);
2056end;
2057
2058function TDpiControl.GetCaption: string;
2059begin
2060 Result := GetVclControl.Caption;
2061end;
2062
2063procedure TDpiControl.FontChanged(Sender: TObject);
2064begin
2065 GetVclControl.Font.Size := ScaleToVcl(Font.Size);
2066end;
2067
2068procedure TDpiControl.UpdateBounds;
2069begin
2070 GetVclControl.BoundsRect := ScaleRectToVcl(BoundsRect);
2071end;
2072
2073procedure TDpiControl.SetHeight(AValue: Integer);
2074begin
2075 if FHeight = AValue then Exit;
2076 FHeight := AValue;
2077 UpdateBounds;
2078end;
2079
2080{ TDpiFormFileDesc }
2081
2082constructor TDpiFormFileDesc.Create;
2083begin
2084 inherited Create;
2085 Name := 'DpiForm form';
2086 ResourceClass := TDpiForm;
2087 UseCreateFormStatements := False;
2088end;
2089
2090function TDpiFormFileDesc.GetInterfaceUsesSection: string;
2091begin
2092 Result := inherited GetInterfaceUsesSection;
2093 Result := Result + ', UDpiForm';
2094end;
2095
2096function TDpiFormFileDesc.GetLocalizedName: string;
2097begin
2098 Result := SDpiFormTitle;
2099end;
2100
2101function TDpiFormFileDesc.GetLocalizedDescription: string;
2102begin
2103 Result := SDpiFormDescription;
2104end;
2105
2106{ TDpiForm }
2107
2108function TDpiForm.GetBorderIcons: TBorderIcons;
2109begin
2110 Result := GetVclForm.BorderIcons;
2111end;
2112
2113function TDpiForm.GetBorderStyle: TBorderStyle;
2114begin
2115 Result := GetVclForm.BorderStyle;
2116end;
2117
2118function TDpiForm.GetDesignTimePPI: Integer;
2119begin
2120 Result := GetVclForm.DesignTimePPI;
2121end;
2122
2123function TDpiForm.GetFormState: TFormState;
2124begin
2125 Result := GetVclForm.FormState;
2126end;
2127
2128function TDpiForm.GetFormStyle: TFormStyle;
2129begin
2130 Result := GetVclForm.FormStyle;
2131end;
2132
2133function TDpiForm.GetKeyPreview: Boolean;
2134begin
2135 Result := GetVclForm.KeyPreview;
2136end;
2137
2138function TDpiForm.GetLCLVersion: string;
2139begin
2140 Result := GetVclForm.LCLVersion;
2141end;
2142
2143function TDpiForm.GetModalResult: TModalResult;
2144begin
2145 Result := GetVclForm.ModalResult;
2146end;
2147
2148function TDpiForm.GetOnClose: TCloseEvent;
2149begin
2150 Result := GetVclForm.OnClose;
2151end;
2152
2153function TDpiForm.GetOnCloseQuery: TCloseQueryEvent;
2154begin
2155 Result := GetVclForm.OnCloseQuery;
2156end;
2157
2158function TDpiForm.GetOnCreate: TNotifyEvent;
2159begin
2160 Result := GetVclForm.OnCreate;
2161end;
2162
2163function TDpiForm.GetOnDeactivate: TNotifyEvent;
2164begin
2165 Result := GetVclForm.OnDeactivate;
2166end;
2167
2168function TDpiForm.GetOnDestroy: TNotifyEvent;
2169begin
2170 Result := GetVclForm.OnDestroy;
2171end;
2172
2173function TDpiForm.GetOnHide: TNotifyEvent;
2174begin
2175 Result := GetVclForm.OnHide;
2176end;
2177
2178function TDpiForm.GetOnShow: TNotifyEvent;
2179begin
2180 Result := GetVclForm.OnShow;
2181end;
2182
2183function TDpiForm.GetPosition: TPosition;
2184begin
2185 Result := GetVclForm.Position;
2186end;
2187
2188function TDpiForm.GetWindowState: TWindowState;
2189begin
2190 Result := GetVclForm.WindowState;
2191end;
2192
2193procedure TDpiForm.SetBorderIcons(AValue: TBorderIcons);
2194begin
2195 GetVclForm.BorderIcons := AValue;
2196end;
2197
2198procedure TDpiForm.SetBorderStyle(AValue: TBorderStyle);
2199begin
2200 GetVclForm.BorderStyle := AValue;
2201end;
2202
2203procedure TDpiForm.SetDesignTimePPI(AValue: Integer);
2204begin
2205 GetVclForm.DesignTimePPI := AValue;
2206end;
2207
2208procedure TDpiForm.SetFormStyle(AValue: TFormStyle);
2209begin
2210 GetVclForm.FormStyle := AValue;
2211end;
2212
2213procedure TDpiForm.SetKeyPreview(AValue: Boolean);
2214begin
2215 GetVclForm.KeyPreview := AValue;
2216end;
2217
2218procedure TDpiForm.SetLCLVersion(AValue: string);
2219begin
2220 GetVclForm.LCLVersion := AValue;
2221end;
2222
2223procedure TDpiForm.SetModalResult(AValue: TModalResult);
2224begin
2225 GetVclForm.ModalResult := AValue;
2226end;
2227
2228procedure TDpiForm.SetOnClose(AValue: TCloseEvent);
2229begin
2230 GetVclForm.OnClose := AValue;
2231end;
2232
2233procedure TDpiForm.SetOnCloseQuery(AValue: TCloseQueryEvent);
2234begin
2235 GetVclForm.OnCloseQuery := AValue;
2236end;
2237
2238procedure TDpiForm.SetOnCreate(AValue: TNotifyEvent);
2239begin
2240 GetVclForm.OnCreate := AValue;
2241end;
2242
2243procedure TDpiForm.SetOnDeactivate(AValue: TNotifyEvent);
2244begin
2245 GetVclForm.OnDeactivate := AValue;
2246end;
2247
2248procedure TDpiForm.SetOnDestroy(AValue: TNotifyEvent);
2249begin
2250 GetVclForm.OnDestroy := AValue;
2251end;
2252
2253procedure TDpiForm.SetOnHide(AValue: TNotifyEvent);
2254begin
2255 GetVclForm.OnHide := AValue;
2256end;
2257
2258procedure TDpiForm.SetOnShow(AValue: TNotifyEvent);
2259begin
2260 GetVclForm.OnShow := AValue;
2261end;
2262
2263procedure TDpiForm.DoOnCreate;
2264begin
2265 if Assigned(GetVclForm.OnCreate) then
2266 GetVclForm.OnCreate(Self);
2267end;
2268
2269procedure TDpiForm.FormMessageHandler(var TheMessage: TLMessage);
2270begin
2271 Dispatch(TheMessage);
2272end;
2273
2274procedure TDpiForm.SetPosition(AValue: TPosition);
2275begin
2276 GetVclForm.Position := AValue;
2277end;
2278
2279procedure TDpiForm.SetWindowState(AValue: TWindowState);
2280begin
2281 GetVclForm.WindowState := AValue;
2282end;
2283
2284procedure TDpiForm.ActivateHandler(Sender: TObject);
2285begin
2286 DpiScreen.ActiveForm := Self;
2287 if Assigned(FOnActivate) then FOnActivate(Sender);
2288end;
2289
2290procedure TDpiForm.DeactivateHandler(Sender: TObject);
2291begin
2292 if Assigned(FOnDeactivate) then FOnDeactivate(Sender);
2293end;
2294
2295procedure TDpiForm.CreateParams(var p: TCreateParams);
2296begin
2297 // TODO: VclForm.CreateParams(P);
2298end;
2299
2300// This method is called by TWriter to retrieve the child components to write
2301procedure TDpiForm.GetChildren(Proc: TGetChildProc; Root: TComponent);
2302var
2303 I: Integer;
2304 OwnedComponent: TComponent;
2305begin
2306 DebugLn(['TDpiForm.GetChildren ComponentCount=', ComponentCount]);
2307 inherited GetChildren(Proc, Root);
2308 if Root = Self then begin
2309 for I := 0 to ComponentCount - 1 do begin
2310 OwnedComponent := Components[I];
2311 if not OwnedComponent.HasParent then Proc(OwnedComponent);
2312 end;
2313 end;
2314end;
2315
2316function TDpiForm.GetVclScrollingWinControl: TScrollingWinControl;
2317begin
2318 Result := GetVclForm;
2319end;
2320
2321function TDpiForm.GetVclForm: TForm;
2322begin
2323 if not Assigned(VclForm) then begin
2324 VclForm := TFormEx.Create(nil);
2325 (VclForm as TFormEx).OnMessage := @FormMessageHandler;
2326 end;
2327 Result := VclForm;
2328end;
2329
2330procedure TDpiForm.UpdateVclControl;
2331begin
2332 inherited;
2333 GetVclForm.OnMouseDown := @MouseDownHandler;
2334 GetVclForm.OnMouseUp := @MouseUpHandler;
2335 GetVclForm.OnMouseMove := @MouseMoveHandler;
2336 GetVclForm.OnActivate := @ActivateHandler;
2337 GetVclForm.OnDeactivate := @DeactivateHandler;
2338end;
2339
2340function TDpiForm.ShowModal: Integer;
2341begin
2342 Result := GetVclForm.ShowModal;
2343end;
2344
2345procedure TDpiForm.Close;
2346begin
2347 GetVclForm.Close;
2348end;
2349
2350procedure TDpiForm.BringToFront;
2351begin
2352 GetVclForm.BringToFront;
2353end;
2354
2355// Init the component with an IDE resource
2356constructor TDpiForm.Create(TheOwner: TComponent);
2357begin
2358 inherited;
2359 //DebugLn(['TDpiForm.Create ', DbgSName(TheOwner)]);
2360 GlobalNameSpace.BeginWrite;
2361 try
2362 if (ClassType <> TDpiForm) and not (csDesigning in ComponentState) then begin
2363 if not InitResourceComponent(Self, TDataModule) then begin
2364 raise EResNotFound.Create('Resource missing for class ' + ClassName);
2365 end;
2366 end;
2367 finally
2368 GlobalNameSpace.EndWrite;
2369 end;
2370 ScreenChanged;
2371 UpdateVclControl;
2372 DoOnCreate;
2373end;
2374
2375destructor TDpiForm.Destroy;
2376begin
2377 FreeAndNil(VclForm);
2378end;
2379
2380initialization
2381
2382RegisterPropertyToSkip(TDpiForm, 'OldCreateOrder', 'VCL compatibility property', '');
2383RegisterPropertyToSkip(TDpiForm, 'TextHeight', 'VCL compatibility property', '');
2384RegisterPropertyToSkip(TDpiForm, 'Scaled', 'VCL compatibility property', '');
2385RegisterPropertyToSkip(TDpiForm, 'TransparentColorValue', 'VCL compatibility property', '');
2386DpiScreen := TDpiScreen.Create;
2387DpiApplication := TDpiApplication.Create(nil);
2388
2389finalization
2390
2391FreeAndNil(DpiApplication);
2392FreeAndNil(DpiScreen);
2393
2394end.
2395
Note: See TracBrowser for help on using the repository browser.