1 | unit UDpiControls;
|
---|
2 |
|
---|
3 | {$mode objfpc}{$H+}
|
---|
4 |
|
---|
5 | interface
|
---|
6 |
|
---|
7 | uses
|
---|
8 | Classes, SysUtils, LCLProc, LResources, Forms, FormEditingIntf, ProjectIntf,
|
---|
9 | Controls, StdCtrls, fgl, Graphics, ComCtrls, ExtCtrls, LCLType, GraphType,
|
---|
10 | Types, CustApp, LMessages, LCLIntf;
|
---|
11 |
|
---|
12 | type
|
---|
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 |
|
---|
667 | var
|
---|
668 | DpiFormFileDesc: TDpiFormFileDesc;
|
---|
669 | DpiScreen: TDpiScreen;
|
---|
670 | DpiApplication: TDpiApplication;
|
---|
671 |
|
---|
672 | procedure Register;
|
---|
673 | function DpiBitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc: Integer; Rop: DWORD): Boolean;
|
---|
674 |
|
---|
675 |
|
---|
676 | implementation
|
---|
677 |
|
---|
678 | resourcestring
|
---|
679 | SDpiFormTitle = 'DpiForm form';
|
---|
680 | SDpiFormDescription = 'DPI aware form';
|
---|
681 |
|
---|
682 | procedure Register;
|
---|
683 | begin
|
---|
684 | FormEditingHook.RegisterDesignerBaseClass(TDpiForm);
|
---|
685 | DpiFormFileDesc := TDpiFormFileDesc.Create;
|
---|
686 | RegisterProjectFileDescriptor(DpiFormFileDesc);
|
---|
687 | RegisterComponents('DpiControls', [TDpiButton, TDpiImage, TDpiPaintBox, TDpiListBox]);
|
---|
688 | end;
|
---|
689 |
|
---|
690 | function ScaleToVcl(Value: Integer): Integer;
|
---|
691 | begin
|
---|
692 | Result := Round(Value * DpiScreen.Dpi / 96);
|
---|
693 | end;
|
---|
694 |
|
---|
695 | function ScaleFromVcl(Value: Integer): Integer;
|
---|
696 | begin
|
---|
697 | Result := Round(Value * 96 / DpiScreen.Dpi);
|
---|
698 | end;
|
---|
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 |
|
---|
712 | function ScaleRectToVcl(Value: TRect): TRect;
|
---|
713 | begin
|
---|
714 | Result.Left := ScaleToVcl(Value.Left);
|
---|
715 | Result.Top := ScaleToVcl(Value.Top);
|
---|
716 | Result.Right := ScaleToVcl(Value.Right);
|
---|
717 | Result.Bottom := ScaleToVcl(Value.Bottom);
|
---|
718 | end;
|
---|
719 |
|
---|
720 | function ScaleRectFromVcl(Value: TRect): TRect;
|
---|
721 | begin
|
---|
722 | Result.Left := ScaleFromVcl(Value.Left);
|
---|
723 | Result.Top := ScaleFromVcl(Value.Top);
|
---|
724 | Result.Right := ScaleFromVcl(Value.Right);
|
---|
725 | Result.Bottom := ScaleFromVcl(Value.Bottom);
|
---|
726 | end;
|
---|
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 |
|
---|
919 | { TDpiJpegImage }
|
---|
920 |
|
---|
921 | function TDpiJpegImage.GetVclBitmap: TCustomBitmap;
|
---|
922 | begin
|
---|
923 | Result := GetVclJpeg;
|
---|
924 | end;
|
---|
925 |
|
---|
926 | function TDpiJpegImage.GetVclJpeg: TJPEGImage;
|
---|
927 | begin
|
---|
928 | if not Assigned(VclJpeg) then VclJpeg := TJPEGImage.Create;
|
---|
929 | Result := VclJpeg;
|
---|
930 | end;
|
---|
931 |
|
---|
932 | { TDpiPortableNetworkGraphic }
|
---|
933 |
|
---|
934 | function TDpiPortableNetworkGraphic.GetVclBitmap: TCustomBitmap;
|
---|
935 | begin
|
---|
936 | Result := GetVclPng;
|
---|
937 | end;
|
---|
938 |
|
---|
939 | function TDpiPortableNetworkGraphic.GetVclPng: TPortableNetworkGraphic;
|
---|
940 | begin
|
---|
941 | if not Assigned(VclPng) then VclPng := TPortableNetworkGraphic.Create;
|
---|
942 | Result := VclPng;
|
---|
943 | end;
|
---|
944 |
|
---|
945 | { TDpiCustomControl }
|
---|
946 |
|
---|
947 | function TDpiCustomControl.GetOnPaint: TNotifyEvent;
|
---|
948 | begin
|
---|
949 | Result := GetVclCustomControl.OnPaint;
|
---|
950 | end;
|
---|
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 |
|
---|
966 | procedure TDpiCustomControl.SetOnPaint(AValue: TNotifyEvent);
|
---|
967 | begin
|
---|
968 | GetVclCustomControl.OnPaint := AValue;
|
---|
969 | end;
|
---|
970 |
|
---|
971 | procedure TDpiCustomControl.SetPixelsPerInch(AValue: Integer);
|
---|
972 | begin
|
---|
973 |
|
---|
974 | end;
|
---|
975 |
|
---|
976 | function TDpiCustomControl.GetVclWinControl: TWinControl;
|
---|
977 | begin
|
---|
978 | Result := GetVclCustomControl;
|
---|
979 | end;
|
---|
980 |
|
---|
981 | function TDpiCustomControl.GetVclCustomControl: TCustomControl;
|
---|
982 | begin
|
---|
983 | Result := nil;
|
---|
984 | end;
|
---|
985 |
|
---|
986 | { TDpiScrollBar }
|
---|
987 |
|
---|
988 | function TDpiScrollBar.GetBorderSpacing: TControlBorderSpacing;
|
---|
989 | begin
|
---|
990 | Result := VclScrollBar.BorderSpacing;
|
---|
991 | end;
|
---|
992 |
|
---|
993 | function TDpiScrollBar.GetKind: TScrollBarKind;
|
---|
994 | begin
|
---|
995 | Result := VclScrollBar.Kind;
|
---|
996 | end;
|
---|
997 |
|
---|
998 | function TDpiScrollBar.GetMax: Integer;
|
---|
999 | begin
|
---|
1000 | Result := VclScrollBar.Max;
|
---|
1001 | end;
|
---|
1002 |
|
---|
1003 | function TDpiScrollBar.GetMin: Integer;
|
---|
1004 | begin
|
---|
1005 | Result := VclScrollBar.Min;
|
---|
1006 | end;
|
---|
1007 |
|
---|
1008 | function TDpiScrollBar.GetOnChange: TNotifyEvent;
|
---|
1009 | begin
|
---|
1010 | Result := VclScrollBar.OnChange;
|
---|
1011 | end;
|
---|
1012 |
|
---|
1013 | function TDpiScrollBar.GetPageSize: Integer;
|
---|
1014 | begin
|
---|
1015 | Result := VclScrollBar.PageSize;
|
---|
1016 | end;
|
---|
1017 |
|
---|
1018 | function TDpiScrollBar.GetPosition: Integer;
|
---|
1019 | begin
|
---|
1020 | Result := VclScrollBar.Position;
|
---|
1021 | end;
|
---|
1022 |
|
---|
1023 | procedure TDpiScrollBar.SetBorderSpacing(AValue: TControlBorderSpacing);
|
---|
1024 | begin
|
---|
1025 | VclScrollBar.BorderSpacing := AValue;
|
---|
1026 | end;
|
---|
1027 |
|
---|
1028 | procedure TDpiScrollBar.SetKind(AValue: TScrollBarKind);
|
---|
1029 | begin
|
---|
1030 | VclScrollBar.Kind := AValue;
|
---|
1031 | end;
|
---|
1032 |
|
---|
1033 | procedure TDpiScrollBar.SetMax(AValue: Integer);
|
---|
1034 | begin
|
---|
1035 | VclScrollBar.Max := AValue;
|
---|
1036 | end;
|
---|
1037 |
|
---|
1038 | procedure TDpiScrollBar.SetMin(AValue: Integer);
|
---|
1039 | begin
|
---|
1040 | VclScrollBar.Min := Avalue;
|
---|
1041 | end;
|
---|
1042 |
|
---|
1043 | procedure TDpiScrollBar.SetOnChange(AValue: TNotifyEvent);
|
---|
1044 | begin
|
---|
1045 | VclScrollBar.OnChange := AValue;
|
---|
1046 | end;
|
---|
1047 |
|
---|
1048 | procedure TDpiScrollBar.SetPageSize(AValue: Integer);
|
---|
1049 | begin
|
---|
1050 | VclScrollBar.PageSize := AValue;
|
---|
1051 | end;
|
---|
1052 |
|
---|
1053 | procedure TDpiScrollBar.SetPosition(AValue: Integer);
|
---|
1054 | begin
|
---|
1055 | VclScrollBar.Position := AValue;
|
---|
1056 | end;
|
---|
1057 |
|
---|
1058 | function TDpiScrollBar.GetVclControl: TControl;
|
---|
1059 | begin
|
---|
1060 | if not Assigned(VclScrollBar) then VclScrollBar := TScrollBar.Create(nil);
|
---|
1061 | Result := VclScrollBar;
|
---|
1062 | end;
|
---|
1063 |
|
---|
1064 | destructor TDpiScrollBar.Destroy;
|
---|
1065 | begin
|
---|
1066 | FreeAndNil(VclScrollBar);
|
---|
1067 | inherited Destroy;
|
---|
1068 | end;
|
---|
1069 |
|
---|
1070 | { TDpiRasterImage }
|
---|
1071 |
|
---|
1072 | function TDpiRasterImage.GetRawImage: TRawImage;
|
---|
1073 | begin
|
---|
1074 | Result := GetVclRasterImage.RawImage;
|
---|
1075 | end;
|
---|
1076 |
|
---|
1077 | function TDpiRasterImage.GetVclRasterImage: TRasterImage;
|
---|
1078 | begin
|
---|
1079 | Result := GetVclRasterImage;
|
---|
1080 | end;
|
---|
1081 |
|
---|
1082 | function TDpiRasterImage.GetVclGraphic: TGraphic;
|
---|
1083 | begin
|
---|
1084 | Result := GetVclRasterImage;
|
---|
1085 | end;
|
---|
1086 |
|
---|
1087 | { TDpiGraphic }
|
---|
1088 |
|
---|
1089 | function TDpiGraphic.GetVclGraphic: TGraphic;
|
---|
1090 | begin
|
---|
1091 | Result := nil;
|
---|
1092 | end;
|
---|
1093 |
|
---|
1094 | procedure TDpiGraphic.LoadFromFile(const Filename: string);
|
---|
1095 | begin
|
---|
1096 | GetVclGraphic.LoadFromFile(FileName);
|
---|
1097 | end;
|
---|
1098 |
|
---|
1099 | { TDpiBitmap }
|
---|
1100 |
|
---|
1101 | function TDpiBitmap.GetHeight: Integer;
|
---|
1102 | begin
|
---|
1103 | Result := ScaleFromVcl(GetVclBitmap.Height);
|
---|
1104 | end;
|
---|
1105 |
|
---|
1106 | function TDpiBitmap.GetCanvas: TDpiCanvas;
|
---|
1107 | begin
|
---|
1108 | if not Assigned(FCanvas) then begin
|
---|
1109 | FCanvas := TDpiCanvas.Create;
|
---|
1110 | FCanvas.VclCanvas := GetVclBitmap.Canvas;
|
---|
1111 | end;
|
---|
1112 | Result := FCanvas;
|
---|
1113 | end;
|
---|
1114 |
|
---|
1115 | function TDpiBitmap.GetPixelFormat: TPixelFormat;
|
---|
1116 | begin
|
---|
1117 | Result := GetVclBitmap.PixelFormat;
|
---|
1118 | end;
|
---|
1119 |
|
---|
1120 | function TDpiBitmap.GetScanLine(Row: Integer): Pointer;
|
---|
1121 | begin
|
---|
1122 | Result := GetVclBitmap.ScanLine[Row];
|
---|
1123 | end;
|
---|
1124 |
|
---|
1125 | function TDpiBitmap.GetWidth: Integer;
|
---|
1126 | begin
|
---|
1127 | Result := ScaleFromVcl(GetVclBitmap.Width);
|
---|
1128 | end;
|
---|
1129 |
|
---|
1130 | procedure TDpiBitmap.SetHeight(AValue: Integer);
|
---|
1131 | begin
|
---|
1132 | GetVclBitmap.Height := ScaleToVcl(AValue);
|
---|
1133 | end;
|
---|
1134 |
|
---|
1135 | procedure TDpiBitmap.SetPixelFormat(AValue: TPixelFormat);
|
---|
1136 | begin
|
---|
1137 | GetVclBitmap.PixelFormat := AValue;
|
---|
1138 | end;
|
---|
1139 |
|
---|
1140 | procedure TDpiBitmap.SetWidth(AValue: Integer);
|
---|
1141 | begin
|
---|
1142 | GetVclBitmap.Width := ScaleToVcl(AValue);
|
---|
1143 | end;
|
---|
1144 |
|
---|
1145 | function TDpiBitmap.GetVclBitmap: TCustomBitmap;
|
---|
1146 | begin
|
---|
1147 | if not Assigned(VclBitmap) then begin
|
---|
1148 | VclBitmap := TBitmap.Create;
|
---|
1149 | Canvas.VclCanvas := VclBitmap.Canvas;
|
---|
1150 | end;
|
---|
1151 | Result := VclBitmap;
|
---|
1152 | end;
|
---|
1153 |
|
---|
1154 | procedure TDpiBitmap.BeginUpdate;
|
---|
1155 | begin
|
---|
1156 | GetVclBitmap.BeginUpdate;
|
---|
1157 | end;
|
---|
1158 |
|
---|
1159 | procedure TDpiBitmap.EndUpdate;
|
---|
1160 | begin
|
---|
1161 | GetVclBitmap.EndUpdate;
|
---|
1162 | end;
|
---|
1163 |
|
---|
1164 | procedure TDpiBitmap.SetSize(Width, Height: Integer);
|
---|
1165 | begin
|
---|
1166 | GetVclBitmap.SetSize(ScaleToVcl(Width), ScaleToVcl(Height));
|
---|
1167 | end;
|
---|
1168 |
|
---|
1169 | constructor TDpiBitmap.Create;
|
---|
1170 | begin
|
---|
1171 | inherited;
|
---|
1172 | end;
|
---|
1173 |
|
---|
1174 | destructor TDpiBitmap.Destroy;
|
---|
1175 | begin
|
---|
1176 | FreeAndNil(FCanvas);
|
---|
1177 | FreeAndNil(VclBitmap);
|
---|
1178 | inherited;
|
---|
1179 | end;
|
---|
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 |
|
---|
1188 | function TDpiBitmap.GetVclRasterImage: TRasterImage;
|
---|
1189 | begin
|
---|
1190 | Result := GetVclBitmap;
|
---|
1191 | end;
|
---|
1192 |
|
---|
1193 | { TDpiListBox }
|
---|
1194 |
|
---|
1195 | function TDpiListBox.GetVclControl: TControl;
|
---|
1196 | begin
|
---|
1197 | if not Assigned(VclListBox) then VclListBox := TListBox.Create(nil);
|
---|
1198 | Result := VclListBox;
|
---|
1199 | end;
|
---|
1200 |
|
---|
1201 | destructor TDpiListBox.Destroy;
|
---|
1202 | begin
|
---|
1203 | FreeAndNil(VclListBox);
|
---|
1204 | inherited Destroy;
|
---|
1205 | end;
|
---|
1206 |
|
---|
1207 | { TDpiPaintBox }
|
---|
1208 |
|
---|
1209 | function TDpiPaintBox.GetOnPaint: TNotifyEvent;
|
---|
1210 | begin
|
---|
1211 | Result := VclPaintBox.OnPaint;
|
---|
1212 | end;
|
---|
1213 |
|
---|
1214 | procedure TDpiPaintBox.SetOnPaint(AValue: TNotifyEvent);
|
---|
1215 | begin
|
---|
1216 | VclPaintBox.OnPaint := AValue;
|
---|
1217 | end;
|
---|
1218 |
|
---|
1219 | function TDpiPaintBox.GetVclGraphicControl: TGraphicControl;
|
---|
1220 | begin
|
---|
1221 | if not Assigned(VclPaintBox) then VclPaintBox := TPaintBox.Create(nil);
|
---|
1222 | Result := VclPaintBox;
|
---|
1223 | end;
|
---|
1224 |
|
---|
1225 | constructor TDpiPaintBox.Create(TheOwner: TComponent);
|
---|
1226 | begin
|
---|
1227 | inherited;
|
---|
1228 | Canvas := TDpiCanvas.Create;
|
---|
1229 | Canvas.VclCanvas := VclPaintBox.Canvas;
|
---|
1230 | Canvas.Font.VclFont := VclPaintBox.Canvas.Font;
|
---|
1231 | UpdateVclControl;
|
---|
1232 | ScreenChanged;
|
---|
1233 | end;
|
---|
1234 |
|
---|
1235 | destructor TDpiPaintBox.Destroy;
|
---|
1236 | begin
|
---|
1237 | FreeAndNil(VclPaintBox);
|
---|
1238 | inherited;
|
---|
1239 | end;
|
---|
1240 |
|
---|
1241 | { TDpiPicture }
|
---|
1242 |
|
---|
1243 | procedure TDpiPicture.SetBitmap(AValue: TDpiBitmap);
|
---|
1244 | begin
|
---|
1245 | if FBitmap = AValue then Exit;
|
---|
1246 | FBitmap := AValue;
|
---|
1247 | end;
|
---|
1248 |
|
---|
1249 | procedure TDpiPicture.LoadFromFile(FileName: string);
|
---|
1250 | begin
|
---|
1251 | end;
|
---|
1252 |
|
---|
1253 |
|
---|
1254 | { TDpiCanvas }
|
---|
1255 |
|
---|
1256 | function TDpiCanvas.GetBrush: TBrush;
|
---|
1257 | begin
|
---|
1258 | Result := GetVclCanvas.Brush;
|
---|
1259 | end;
|
---|
1260 |
|
---|
1261 | function TDpiCanvas.GetHandle: HDC;
|
---|
1262 | begin
|
---|
1263 | Result := GetVclCanvas.Handle;
|
---|
1264 | end;
|
---|
1265 |
|
---|
1266 | function TDpiCanvas.GetHeight: Integer;
|
---|
1267 | begin
|
---|
1268 | Result := ScaleFromVcl(GetVclCanvas.Height);
|
---|
1269 | end;
|
---|
1270 |
|
---|
1271 | function TDpiCanvas.GetPen: TPen;
|
---|
1272 | begin
|
---|
1273 | Result := GetVclCanvas.Pen;
|
---|
1274 | end;
|
---|
1275 |
|
---|
1276 | function TDpiCanvas.GetPixel(X, Y: Integer): TColor;
|
---|
1277 | begin
|
---|
1278 | Result := GetVclCanvas.Pixels[ScaleToVcl(X), ScaleToVcl(Y)];
|
---|
1279 | end;
|
---|
1280 |
|
---|
1281 | function TDpiCanvas.GetWidth: Integer;
|
---|
1282 | begin
|
---|
1283 | Result := ScaleFromVcl(GetVclCanvas.Width);
|
---|
1284 | end;
|
---|
1285 |
|
---|
1286 | procedure TDpiCanvas.SetBrush(AValue: TBrush);
|
---|
1287 | begin
|
---|
1288 | GetVclCanvas.Brush := AValue;
|
---|
1289 | end;
|
---|
1290 |
|
---|
1291 | procedure TDpiCanvas.SetFont(AValue: TDpiFont);
|
---|
1292 | begin
|
---|
1293 | if FFont = AValue then Exit;
|
---|
1294 | FFont := AValue;
|
---|
1295 | end;
|
---|
1296 |
|
---|
1297 | procedure TDpiCanvas.SetHandle(AValue: HDC);
|
---|
1298 | begin
|
---|
1299 | GetVclCanvas.Handle := AValue;
|
---|
1300 | end;
|
---|
1301 |
|
---|
1302 | procedure TDpiCanvas.SetPen(AValue: TPen);
|
---|
1303 | begin
|
---|
1304 | GetVclCanvas.Pen := AValue;
|
---|
1305 | end;
|
---|
1306 |
|
---|
1307 | procedure TDpiCanvas.SetPixel(X, Y: Integer; AValue: TColor);
|
---|
1308 | begin
|
---|
1309 | GetVclCanvas.Pixels[ScaleToVcl(X), ScaleToVcl(Y)] := AValue;
|
---|
1310 | end;
|
---|
1311 |
|
---|
1312 | function TDpiCanvas.GetVclCanvas: TCanvas;
|
---|
1313 | begin
|
---|
1314 | //if not Assigned(VclCanvas) then VclCanvas := TCanvas.Create;
|
---|
1315 | Result := VclCanvas;
|
---|
1316 | end;
|
---|
1317 |
|
---|
1318 | procedure TDpiCanvas.FrameRect(Rect: TRect);
|
---|
1319 | begin
|
---|
1320 | GetVclCanvas.FrameRect(ScaleRectToVcl(Rect));
|
---|
1321 | end;
|
---|
1322 |
|
---|
1323 | procedure TDpiCanvas.Rectangle(X1, Y1, X2, Y2: Integer);
|
---|
1324 | begin
|
---|
1325 | GetVclCanvas.Rectangle(ScaleToVcl(X1), ScaleToVcl(Y1), ScaleToVcl(X2), ScaleToVcl(Y2));
|
---|
1326 | end;
|
---|
1327 |
|
---|
1328 | function TDpiCanvas.TextWidth(Text: string): Integer;
|
---|
1329 | begin
|
---|
1330 | Result := ScaleFromVcl(GetVclCanvas.TextWidth(Text));
|
---|
1331 | end;
|
---|
1332 |
|
---|
1333 | function TDpiCanvas.TextHeight(Text: string): Integer;
|
---|
1334 | begin
|
---|
1335 | Result := ScaleFromVcl(GetVclCanvas.TextHeight(Text));
|
---|
1336 | end;
|
---|
1337 |
|
---|
1338 | function TDpiCanvas.TextExtent(Text: string): TSize;
|
---|
1339 | begin
|
---|
1340 | Result := GetVclCanvas.TextExtent(Text);
|
---|
1341 | end;
|
---|
1342 |
|
---|
1343 | procedure TDpiCanvas.TextOut(X, Y: Integer; Text: string);
|
---|
1344 | begin
|
---|
1345 | GetVclCanvas.TextOut(ScaleToVcl(X), ScaleToVcl(Y), Text);
|
---|
1346 | end;
|
---|
1347 |
|
---|
1348 | procedure TDpiCanvas.TextRect(ARect: TRect; X, Y: Integer; Text: string);
|
---|
1349 | begin
|
---|
1350 | GetVclCanvas.TextRect(ARect, X, Y, Text);
|
---|
1351 | end;
|
---|
1352 |
|
---|
1353 | procedure TDpiCanvas.MoveTo(X, Y: Integer);
|
---|
1354 | begin
|
---|
1355 | GetVclCanvas.MoveTo(ScaleToVcl(X), ScaleToVcl(Y));
|
---|
1356 | end;
|
---|
1357 |
|
---|
1358 | procedure TDpiCanvas.LineTo(X, Y: Integer);
|
---|
1359 | begin
|
---|
1360 | GetVclCanvas.LineTo(ScaleToVcl(X), ScaleToVcl(Y));
|
---|
1361 | end;
|
---|
1362 |
|
---|
1363 | procedure TDpiCanvas.FillRect(ARect: TRect);
|
---|
1364 | begin
|
---|
1365 | GetVclCanvas.FillRect(ScaleRectToVcl(ARect));
|
---|
1366 | end;
|
---|
1367 |
|
---|
1368 | procedure TDpiCanvas.FillRect(X1, Y1, X2, Y2: Integer);
|
---|
1369 | begin
|
---|
1370 | GetVclCanvas.FillRect(ScaleToVcl(X1), ScaleToVcl(Y1), ScaleToVcl(X2), ScaleToVcl(Y2));
|
---|
1371 | end;
|
---|
1372 |
|
---|
1373 | procedure TDpiCanvas.Draw(X, Y: Integer; Source: TDpiGraphic);
|
---|
1374 | begin
|
---|
1375 | GetVclCanvas.Draw(ScaleToVcl(X), ScaleToVcl(Y), Source.GetVclGraphic);
|
---|
1376 | end;
|
---|
1377 |
|
---|
1378 | procedure TDpiCanvas.CopyRect(Dest: TRect; SrcCanvas: TDpiCanvas;
|
---|
1379 | Source: TRect);
|
---|
1380 | begin
|
---|
1381 | GetVclCanvas.CopyRect(Dest, SrcCanvas.VclCanvas, Source);
|
---|
1382 | end;
|
---|
1383 |
|
---|
1384 | constructor TDpiCanvas.Create;
|
---|
1385 | begin
|
---|
1386 | FFont := TDpiFont.Create;
|
---|
1387 | end;
|
---|
1388 |
|
---|
1389 | destructor TDpiCanvas.Destroy;
|
---|
1390 | begin
|
---|
1391 | FreeAndNil(FFont);
|
---|
1392 | inherited;
|
---|
1393 | end;
|
---|
1394 |
|
---|
1395 | { TDpiGraphicControl }
|
---|
1396 |
|
---|
1397 | procedure TDpiGraphicControl.SetCanvas(AValue: TDpiCanvas);
|
---|
1398 | begin
|
---|
1399 | if FCanvas = AValue then Exit;
|
---|
1400 | FCanvas := AValue;
|
---|
1401 | end;
|
---|
1402 |
|
---|
1403 | procedure TDpiGraphicControl.PaintHandler(Sender: TObject);
|
---|
1404 | begin
|
---|
1405 | Paint;
|
---|
1406 | if Assigned(FOnPaint) then
|
---|
1407 | FOnPaint(Sender);
|
---|
1408 | end;
|
---|
1409 |
|
---|
1410 | procedure TDpiGraphicControl.Paint;
|
---|
1411 | begin
|
---|
1412 | end;
|
---|
1413 |
|
---|
1414 | function TDpiGraphicControl.GetVclControl: TControl;
|
---|
1415 | begin
|
---|
1416 | Result := GetVclGraphicControl;
|
---|
1417 | end;
|
---|
1418 |
|
---|
1419 | function TDpiGraphicControl.GetVclGraphicControl: TGraphicControl;
|
---|
1420 | begin
|
---|
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;
|
---|
1434 | end;
|
---|
1435 |
|
---|
1436 | constructor TDpiGraphicControl.Create(TheOwner: TComponent);
|
---|
1437 | begin
|
---|
1438 | inherited;
|
---|
1439 | FCanvas := TDpiCanvas.Create;
|
---|
1440 | FCanvas.VclCanvas := GetVclGraphicControl.Canvas;
|
---|
1441 | end;
|
---|
1442 |
|
---|
1443 | destructor TDpiGraphicControl.Destroy;
|
---|
1444 | begin
|
---|
1445 | FreeAndNil(FCanvas);
|
---|
1446 | inherited;
|
---|
1447 | end;
|
---|
1448 |
|
---|
1449 |
|
---|
1450 | { TDpiImage }
|
---|
1451 |
|
---|
1452 | procedure TDpiImage.SetStretch(AValue: Boolean);
|
---|
1453 | begin
|
---|
1454 | if FStretch = AValue then Exit;
|
---|
1455 | FStretch := AValue;
|
---|
1456 | VclImage.Stretch := AValue;
|
---|
1457 | end;
|
---|
1458 |
|
---|
1459 | procedure TDpiImage.SetPicture(AValue: TDpiPicture);
|
---|
1460 | begin
|
---|
1461 | if FDpiPicture = AValue then Exit;
|
---|
1462 | FDpiPicture := AValue;
|
---|
1463 | end;
|
---|
1464 |
|
---|
1465 | function TDpiImage.GetVclControl: TControl;
|
---|
1466 | begin
|
---|
1467 | if not Assigned(VclImage) then VclImage := TImage.Create(nil);
|
---|
1468 | Result := VclImage;
|
---|
1469 | end;
|
---|
1470 |
|
---|
1471 | destructor TDpiImage.Destroy;
|
---|
1472 | begin
|
---|
1473 | FreeAndNil(VclImage);
|
---|
1474 | inherited Destroy;
|
---|
1475 | end;
|
---|
1476 |
|
---|
1477 | { TDpiFont }
|
---|
1478 |
|
---|
1479 | procedure TDpiFont.SetSize(AValue: Integer);
|
---|
1480 | begin
|
---|
1481 | if FSize = AValue then Exit;
|
---|
1482 | FSize := AValue;
|
---|
1483 | DoChange;
|
---|
1484 | end;
|
---|
1485 |
|
---|
1486 | procedure TDpiFont.DoChange;
|
---|
1487 | begin
|
---|
1488 | if Assigned(FOnChange) then FOnChange(Self);
|
---|
1489 | end;
|
---|
1490 |
|
---|
1491 | procedure TDpiFont.SetStyle(AValue: TFontStyles);
|
---|
1492 | begin
|
---|
1493 | GetVclFont.Style := AValue;
|
---|
1494 | end;
|
---|
1495 |
|
---|
1496 | procedure TDpiFont.ScreenChanged;
|
---|
1497 | begin
|
---|
1498 | DoChange;
|
---|
1499 | end;
|
---|
1500 |
|
---|
1501 | function TDpiFont.GetVclFont: TFont;
|
---|
1502 | begin
|
---|
1503 | if not Assigned(VclFont) then VclFont := TFont.Create;
|
---|
1504 | Result := VclFont;
|
---|
1505 | end;
|
---|
1506 |
|
---|
1507 | procedure TDpiFont.SetOnChange(AValue: TNotifyEvent);
|
---|
1508 | begin
|
---|
1509 | if FOnChange = AValue then Exit;
|
---|
1510 | FOnChange := AValue;
|
---|
1511 | end;
|
---|
1512 |
|
---|
1513 | procedure TDpiFont.SetPixelsPerInch(AValue: Integer);
|
---|
1514 | begin
|
---|
1515 | GetVclFont.PixelsPerInch := PixelsPerInch;
|
---|
1516 | end;
|
---|
1517 |
|
---|
1518 | function TDpiFont.GetName: string;
|
---|
1519 | begin
|
---|
1520 | Result := GetVclFont.Name;
|
---|
1521 | end;
|
---|
1522 |
|
---|
1523 | function TDpiFont.GetColor: TColor;
|
---|
1524 | begin
|
---|
1525 | Result := GetVclFont.Color;
|
---|
1526 | end;
|
---|
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 |
|
---|
1538 | function TDpiFont.GetPixelsPerInch: Integer;
|
---|
1539 | begin
|
---|
1540 | Result := GetVclFont.PixelsPerInch;
|
---|
1541 | end;
|
---|
1542 |
|
---|
1543 | function TDpiFont.GetStyle: TFontStyles;
|
---|
1544 | begin
|
---|
1545 | Result := GetVclFont.Style;
|
---|
1546 | end;
|
---|
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 |
|
---|
1558 | procedure TDpiFont.SetColor(AValue: TColor);
|
---|
1559 | begin
|
---|
1560 | GetVclFont.Color := AValue;
|
---|
1561 | end;
|
---|
1562 |
|
---|
1563 | procedure TDpiFont.SetHeight(AValue: Integer);
|
---|
1564 | begin
|
---|
1565 | GetVclFont.Height := AValue;
|
---|
1566 | end;
|
---|
1567 |
|
---|
1568 | procedure TDpiFont.SetName(AValue: string);
|
---|
1569 | begin
|
---|
1570 | GetVclFont.Name := AValue;
|
---|
1571 | end;
|
---|
1572 |
|
---|
1573 | constructor TDpiFont.Create;
|
---|
1574 | begin
|
---|
1575 | Size := 8;
|
---|
1576 | end;
|
---|
1577 |
|
---|
1578 | destructor TDpiFont.Destroy;
|
---|
1579 | begin
|
---|
1580 | inherited Destroy;
|
---|
1581 | end;
|
---|
1582 |
|
---|
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;
|
---|
1590 | end;
|
---|
1591 |
|
---|
1592 | { TDpiWinControl }
|
---|
1593 |
|
---|
1594 | function TDpiWinControl.GetHandle: HWND;
|
---|
1595 | begin
|
---|
1596 | Result := GetVclWinControl.Handle;
|
---|
1597 | end;
|
---|
1598 |
|
---|
1599 | function TDpiWinControl.GetOnKeyDown: TKeyEvent;
|
---|
1600 | begin
|
---|
1601 | Result := GetVclWinControl.OnKeyDown;
|
---|
1602 | end;
|
---|
1603 |
|
---|
1604 | function TDpiWinControl.GetOnKeyPress: TKeyPressEvent;
|
---|
1605 | begin
|
---|
1606 | Result := GetVclWinControl.OnKeyPress;
|
---|
1607 | end;
|
---|
1608 |
|
---|
1609 | function TDpiWinControl.GetOnKeyUp: TKeyEvent;
|
---|
1610 | begin
|
---|
1611 | Result := GetVclWinControl.OnKeyUp;
|
---|
1612 | end;
|
---|
1613 |
|
---|
1614 | procedure TDpiWinControl.SetHandle(AValue: HWND);
|
---|
1615 | begin
|
---|
1616 | GetVclWinControl.Handle := AValue;
|
---|
1617 | end;
|
---|
1618 |
|
---|
1619 | procedure TDpiWinControl.SetOnKeyDown(AValue: TKeyEvent);
|
---|
1620 | begin
|
---|
1621 | GetVclWinControl.OnKeyDown := AValue;
|
---|
1622 | end;
|
---|
1623 |
|
---|
1624 | procedure TDpiWinControl.SetOnKeyPress(AValue: TKeyPressEvent);
|
---|
1625 | begin
|
---|
1626 | GetVclWinControl.OnKeyPress := AValue;
|
---|
1627 | end;
|
---|
1628 |
|
---|
1629 | procedure TDpiWinControl.SetOnKeyUp(AValue: TKeyEvent);
|
---|
1630 | begin
|
---|
1631 | GetVclWinControl.OnKeyUp := AValue;
|
---|
1632 | end;
|
---|
1633 |
|
---|
1634 | function TDpiWinControl.GetVclControl: TControl;
|
---|
1635 | begin
|
---|
1636 | Result := GetVclWinControl;
|
---|
1637 | end;
|
---|
1638 |
|
---|
1639 | function TDpiWinControl.GetVclWinControl: TWinControl;
|
---|
1640 | begin
|
---|
1641 | Result := nil;
|
---|
1642 | end;
|
---|
1643 |
|
---|
1644 | procedure TDpiWinControl.ScreenChanged;
|
---|
1645 | var
|
---|
1646 | I: Integer;
|
---|
1647 | begin
|
---|
1648 | inherited;
|
---|
1649 | for I := 0 to Controls.Count - 1 do
|
---|
1650 | Controls[I].ScreenChanged;
|
---|
1651 | end;
|
---|
1652 |
|
---|
1653 | function TDpiWinControl.ControlCount: Integer;
|
---|
1654 | begin
|
---|
1655 | Result := Controls.Count;
|
---|
1656 | end;
|
---|
1657 |
|
---|
1658 | constructor TDpiWinControl.Create(TheOwner: TComponent);
|
---|
1659 | begin
|
---|
1660 | Controls := TDpiControls.Create;
|
---|
1661 | Controls.FreeObjects := False;
|
---|
1662 | inherited;
|
---|
1663 | end;
|
---|
1664 |
|
---|
1665 | destructor TDpiWinControl.Destroy;
|
---|
1666 | begin
|
---|
1667 | FreeAndNil(Controls);
|
---|
1668 | inherited Destroy;
|
---|
1669 | end;
|
---|
1670 |
|
---|
1671 | { TDpiScreen }
|
---|
1672 |
|
---|
1673 | procedure TDpiScreen.SetDpi(AValue: Integer);
|
---|
1674 | begin
|
---|
1675 | if FDpi = AValue then Exit;
|
---|
1676 | FDpi := AValue;
|
---|
1677 | UpdateForms;
|
---|
1678 | end;
|
---|
1679 |
|
---|
1680 | function TDpiScreen.GetWidth: Integer;
|
---|
1681 | begin
|
---|
1682 | Result := ScaleFromVcl(Screen.Width);
|
---|
1683 | end;
|
---|
1684 |
|
---|
1685 | procedure TDpiScreen.SetActiveForm(AValue: TDpiForm);
|
---|
1686 | begin
|
---|
1687 | FActiveForm := AValue;
|
---|
1688 | end;
|
---|
1689 |
|
---|
1690 | function TDpiScreen.GetHeight: Integer;
|
---|
1691 | begin
|
---|
1692 | Result := ScaleFromVcl(Screen.Height);
|
---|
1693 | end;
|
---|
1694 |
|
---|
1695 | function TDpiScreen.GetFormCount: Integer;
|
---|
1696 | begin
|
---|
1697 | Result := Forms.Count;
|
---|
1698 | end;
|
---|
1699 |
|
---|
1700 | function TDpiScreen.GetActiveForm: TDpiForm;
|
---|
1701 | begin
|
---|
1702 | Result := FActiveForm;
|
---|
1703 | end;
|
---|
1704 |
|
---|
1705 | procedure TDpiScreen.UpdateForms;
|
---|
1706 | var
|
---|
1707 | I: Integer;
|
---|
1708 | begin
|
---|
1709 | for I := 0 to Forms.Count - 1 do
|
---|
1710 | Forms[I].ScreenChanged;
|
---|
1711 | end;
|
---|
1712 |
|
---|
1713 | constructor TDpiScreen.Create;
|
---|
1714 | begin
|
---|
1715 | Forms := TDpiForms.Create;
|
---|
1716 | Forms.FreeObjects := False;
|
---|
1717 | Dpi := 144;
|
---|
1718 | end;
|
---|
1719 |
|
---|
1720 | destructor TDpiScreen.Destroy;
|
---|
1721 | begin
|
---|
1722 | FreeAndNil(Forms);
|
---|
1723 | inherited Destroy;
|
---|
1724 | end;
|
---|
1725 |
|
---|
1726 | { TDpiWinControl }
|
---|
1727 |
|
---|
1728 |
|
---|
1729 | { TDpiButton }
|
---|
1730 |
|
---|
1731 | function TDpiButton.GetVclControl: TControl;
|
---|
1732 | begin
|
---|
1733 | if not Assigned(VclButton) then VclButton := TButton.Create(nil);
|
---|
1734 | Result := VclButton;
|
---|
1735 | end;
|
---|
1736 |
|
---|
1737 | destructor TDpiButton.Destroy;
|
---|
1738 | begin
|
---|
1739 | FreeAndNil(VclButton);
|
---|
1740 | inherited;
|
---|
1741 | end;
|
---|
1742 |
|
---|
1743 | { TDpiControl }
|
---|
1744 |
|
---|
1745 | procedure TDpiControl.SetTop(AValue: Integer);
|
---|
1746 | begin
|
---|
1747 | if FTop = AValue then Exit;
|
---|
1748 | FTop := AValue;
|
---|
1749 | UpdateBounds;
|
---|
1750 | end;
|
---|
1751 |
|
---|
1752 | procedure TDpiControl.SetVisible(AValue: Boolean);
|
---|
1753 | begin
|
---|
1754 | GetVclControl.Visible := AValue;
|
---|
1755 | end;
|
---|
1756 |
|
---|
1757 | procedure TDpiControl.SetWidth(AValue: Integer);
|
---|
1758 | begin
|
---|
1759 | if FWidth = AValue then Exit;
|
---|
1760 | FWidth := AValue;
|
---|
1761 | UpdateBounds;
|
---|
1762 | end;
|
---|
1763 |
|
---|
1764 | function TDpiControl.GetVclControl: TControl;
|
---|
1765 | begin
|
---|
1766 | Result := nil;
|
---|
1767 | end;
|
---|
1768 |
|
---|
1769 | procedure TDpiControl.UpdateVclControl;
|
---|
1770 | begin
|
---|
1771 | GetVclControl.OnResize := @VclFormResize;
|
---|
1772 | GetVclControl.OnChangeBounds := @VclChangeBounds;
|
---|
1773 | end;
|
---|
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 |
|
---|
1803 | procedure TDpiControl.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
|
---|
1804 | Y: Integer);
|
---|
1805 | begin
|
---|
1806 | end;
|
---|
1807 |
|
---|
1808 | procedure TDpiControl.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
|
---|
1809 | Y: Integer);
|
---|
1810 | begin
|
---|
1811 | end;
|
---|
1812 |
|
---|
1813 | procedure TDpiControl.MouseMove(Shift: TShiftState; X, Y: Integer);
|
---|
1814 | begin
|
---|
1815 | end;
|
---|
1816 |
|
---|
1817 | procedure TDpiControl.ScreenChanged;
|
---|
1818 | begin
|
---|
1819 | UpdateBounds;
|
---|
1820 | Font.ScreenChanged;
|
---|
1821 | end;
|
---|
1822 |
|
---|
1823 | procedure TDpiControl.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
|
---|
1824 | begin
|
---|
1825 | FLeft := ALeft;
|
---|
1826 | FTop := ATop;
|
---|
1827 | FWidth := AWidth;
|
---|
1828 | FHeight := AHeight;
|
---|
1829 | UpdateBounds;
|
---|
1830 | end;
|
---|
1831 |
|
---|
1832 | procedure TDpiControl.Show;
|
---|
1833 | begin
|
---|
1834 | Visible := True;
|
---|
1835 | end;
|
---|
1836 |
|
---|
1837 | procedure TDpiControl.Hide;
|
---|
1838 | begin
|
---|
1839 | Visible := False;
|
---|
1840 | end;
|
---|
1841 |
|
---|
1842 | procedure TDpiControl.Invalidate;
|
---|
1843 | begin
|
---|
1844 | GetVclControl.Invalidate;
|
---|
1845 | end;
|
---|
1846 |
|
---|
1847 | procedure TDpiControl.Repaint;
|
---|
1848 | begin
|
---|
1849 | GetVclControl.Repaint;
|
---|
1850 | end;
|
---|
1851 |
|
---|
1852 | procedure TDpiControl.Update;
|
---|
1853 | begin
|
---|
1854 | GetVclControl.Update;
|
---|
1855 | end;
|
---|
1856 |
|
---|
1857 | constructor TDpiControl.Create(TheOwner: TComponent);
|
---|
1858 | begin
|
---|
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;
|
---|
1868 | end;
|
---|
1869 |
|
---|
1870 | destructor TDpiControl.Destroy;
|
---|
1871 | begin
|
---|
1872 | FreeAndNil(FConstraints);
|
---|
1873 | FreeAndNil(FFont);
|
---|
1874 | inherited Destroy;
|
---|
1875 | end;
|
---|
1876 |
|
---|
1877 | procedure TDpiControl.SetLeft(AValue: Integer);
|
---|
1878 | begin
|
---|
1879 | if FLeft = AValue then Exit;
|
---|
1880 | FLeft := AValue;
|
---|
1881 | UpdateBounds;
|
---|
1882 | end;
|
---|
1883 |
|
---|
1884 | procedure TDpiControl.SetCaption(AValue: string);
|
---|
1885 | begin
|
---|
1886 | GetVclControl.Caption := AValue;
|
---|
1887 | end;
|
---|
1888 |
|
---|
1889 | procedure TDpiControl.SetParent(AValue: TDpiWinControl);
|
---|
1890 | begin
|
---|
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;
|
---|
1903 | end;
|
---|
1904 |
|
---|
1905 | procedure TDpiControl.SetFont(AValue: TDpiFont);
|
---|
1906 | begin
|
---|
1907 | if FFont = AValue then Exit;
|
---|
1908 | FFont := AValue;
|
---|
1909 | end;
|
---|
1910 |
|
---|
1911 | procedure TDpiControl.SetHint(AValue: string);
|
---|
1912 | begin
|
---|
1913 | GetVclControl.Hint := AValue;
|
---|
1914 | end;
|
---|
1915 |
|
---|
1916 | function TDpiControl.GetBoundsRect: TRect;
|
---|
1917 | begin
|
---|
1918 | Result.Left := Left;
|
---|
1919 | Result.Top := Top;
|
---|
1920 | Result.Right := Left + Width;
|
---|
1921 | Result.Bottom := Top + Height;
|
---|
1922 | end;
|
---|
1923 |
|
---|
1924 | function TDpiControl.GetAlign: TAlign;
|
---|
1925 | begin
|
---|
1926 | Result := GetVclControl.Align;
|
---|
1927 | end;
|
---|
1928 |
|
---|
1929 | function TDpiControl.GetClientHeight: Integer;
|
---|
1930 | begin
|
---|
1931 | Result := ScaleFromVcl(GetVclControl.ClientHeight);
|
---|
1932 | end;
|
---|
1933 |
|
---|
1934 | function TDpiControl.GetClientWidth: Integer;
|
---|
1935 | begin
|
---|
1936 | Result := ScaleFromVcl(GetVclControl.ClientWidth);
|
---|
1937 | end;
|
---|
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 |
|
---|
1949 | function TDpiControl.GetEnabled: Boolean;
|
---|
1950 | begin
|
---|
1951 | Result := GetVclControl.Enabled;
|
---|
1952 | end;
|
---|
1953 |
|
---|
1954 | function TDpiControl.GetHint: string;
|
---|
1955 | begin
|
---|
1956 | Result := GetVclControl.Hint;
|
---|
1957 | end;
|
---|
1958 |
|
---|
1959 | function TDpiControl.GetOnClick: TNotifyEvent;
|
---|
1960 | begin
|
---|
1961 | Result := GetVclControl.OnClick;
|
---|
1962 | end;
|
---|
1963 |
|
---|
1964 | function TDpiControl.GetShowHint: Boolean;
|
---|
1965 | begin
|
---|
1966 | Result := GetVclControl.ShowHint;
|
---|
1967 | end;
|
---|
1968 |
|
---|
1969 | function TDpiControl.GetVisible: Boolean;
|
---|
1970 | begin
|
---|
1971 | Result := GetVclControl.Visible;
|
---|
1972 | end;
|
---|
1973 |
|
---|
1974 | procedure TDpiControl.SetAlign(AValue: TAlign);
|
---|
1975 | begin
|
---|
1976 | GetVclControl.Align := AValue;
|
---|
1977 | end;
|
---|
1978 |
|
---|
1979 | procedure TDpiControl.SetBoundsRect(AValue: TRect);
|
---|
1980 | begin
|
---|
1981 | SetBounds(AValue.Left, AValue.Top, AValue.Right - AValue.Left, AValue.Bottom - AValue.Top);
|
---|
1982 | end;
|
---|
1983 |
|
---|
1984 | procedure TDpiControl.SetClientHeight(AValue: Integer);
|
---|
1985 | begin
|
---|
1986 | GetVclControl.ClientHeight := ScaletoVcl(AValue);
|
---|
1987 | end;
|
---|
1988 |
|
---|
1989 | procedure TDpiControl.SetClientWidth(AValue: Integer);
|
---|
1990 | begin
|
---|
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;
|
---|
2002 | end;
|
---|
2003 |
|
---|
2004 | procedure TDpiControl.SetEnabled(AValue: Boolean);
|
---|
2005 | begin
|
---|
2006 | GetVclControl.Enabled := AValue;
|
---|
2007 | end;
|
---|
2008 |
|
---|
2009 | procedure TDpiControl.SetOnChangeBounds(AValue: TNotifyEvent);
|
---|
2010 | begin
|
---|
2011 | if FOnChangeBounds = AValue then Exit;
|
---|
2012 | FOnChangeBounds := AValue;
|
---|
2013 | end;
|
---|
2014 |
|
---|
2015 | procedure TDpiControl.SetOnClick(AValue: TNotifyEvent);
|
---|
2016 | begin
|
---|
2017 | GetVclControl.OnClick := AValue;
|
---|
2018 | end;
|
---|
2019 |
|
---|
2020 | procedure TDpiControl.SetOnResize(AValue: TNotifyEvent);
|
---|
2021 | begin
|
---|
2022 | if FOnResize = AValue then Exit;
|
---|
2023 | FOnResize := AValue;
|
---|
2024 | end;
|
---|
2025 |
|
---|
2026 | procedure TDpiControl.SetShowHint(AValue: Boolean);
|
---|
2027 | begin
|
---|
2028 | GetVclControl.ShowHint := AValue;
|
---|
2029 | end;
|
---|
2030 |
|
---|
2031 | procedure TDpiControl.VclFormResize(Sender: TObject);
|
---|
2032 | begin
|
---|
2033 | BoundsRect := ScaleRectFromVcl(GetVclControl.BoundsRect);
|
---|
2034 | DoFormResize;
|
---|
2035 | end;
|
---|
2036 |
|
---|
2037 | procedure TDpiControl.VclChangeBounds(Sender: TObject);
|
---|
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;
|
---|
2046 | end;
|
---|
2047 |
|
---|
2048 | procedure TDpiControl.DoFormResize;
|
---|
2049 | begin
|
---|
2050 | if Assigned(FOnResize) then FOnResize(Self);
|
---|
2051 | end;
|
---|
2052 |
|
---|
2053 | procedure TDpiControl.DoChangeBounds;
|
---|
2054 | begin
|
---|
2055 | if Assigned(FOnChangeBounds) then FOnChangeBounds(Self);
|
---|
2056 | end;
|
---|
2057 |
|
---|
2058 | function TDpiControl.GetCaption: string;
|
---|
2059 | begin
|
---|
2060 | Result := GetVclControl.Caption;
|
---|
2061 | end;
|
---|
2062 |
|
---|
2063 | procedure TDpiControl.FontChanged(Sender: TObject);
|
---|
2064 | begin
|
---|
2065 | GetVclControl.Font.Size := ScaleToVcl(Font.Size);
|
---|
2066 | end;
|
---|
2067 |
|
---|
2068 | procedure TDpiControl.UpdateBounds;
|
---|
2069 | begin
|
---|
2070 | GetVclControl.BoundsRect := ScaleRectToVcl(BoundsRect);
|
---|
2071 | end;
|
---|
2072 |
|
---|
2073 | procedure TDpiControl.SetHeight(AValue: Integer);
|
---|
2074 | begin
|
---|
2075 | if FHeight = AValue then Exit;
|
---|
2076 | FHeight := AValue;
|
---|
2077 | UpdateBounds;
|
---|
2078 | end;
|
---|
2079 |
|
---|
2080 | { TDpiFormFileDesc }
|
---|
2081 |
|
---|
2082 | constructor TDpiFormFileDesc.Create;
|
---|
2083 | begin
|
---|
2084 | inherited Create;
|
---|
2085 | Name := 'DpiForm form';
|
---|
2086 | ResourceClass := TDpiForm;
|
---|
2087 | UseCreateFormStatements := False;
|
---|
2088 | end;
|
---|
2089 |
|
---|
2090 | function TDpiFormFileDesc.GetInterfaceUsesSection: string;
|
---|
2091 | begin
|
---|
2092 | Result := inherited GetInterfaceUsesSection;
|
---|
2093 | Result := Result + ', UDpiForm';
|
---|
2094 | end;
|
---|
2095 |
|
---|
2096 | function TDpiFormFileDesc.GetLocalizedName: string;
|
---|
2097 | begin
|
---|
2098 | Result := SDpiFormTitle;
|
---|
2099 | end;
|
---|
2100 |
|
---|
2101 | function TDpiFormFileDesc.GetLocalizedDescription: string;
|
---|
2102 | begin
|
---|
2103 | Result := SDpiFormDescription;
|
---|
2104 | end;
|
---|
2105 |
|
---|
2106 | { TDpiForm }
|
---|
2107 |
|
---|
2108 | function TDpiForm.GetBorderIcons: TBorderIcons;
|
---|
2109 | begin
|
---|
2110 | Result := GetVclForm.BorderIcons;
|
---|
2111 | end;
|
---|
2112 |
|
---|
2113 | function TDpiForm.GetBorderStyle: TBorderStyle;
|
---|
2114 | begin
|
---|
2115 | Result := GetVclForm.BorderStyle;
|
---|
2116 | end;
|
---|
2117 |
|
---|
2118 | function TDpiForm.GetDesignTimePPI: Integer;
|
---|
2119 | begin
|
---|
2120 | Result := GetVclForm.DesignTimePPI;
|
---|
2121 | end;
|
---|
2122 |
|
---|
2123 | function TDpiForm.GetFormState: TFormState;
|
---|
2124 | begin
|
---|
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;
|
---|
2141 | end;
|
---|
2142 |
|
---|
2143 | function TDpiForm.GetModalResult: TModalResult;
|
---|
2144 | begin
|
---|
2145 | Result := GetVclForm.ModalResult;
|
---|
2146 | end;
|
---|
2147 |
|
---|
2148 | function TDpiForm.GetOnClose: TCloseEvent;
|
---|
2149 | begin
|
---|
2150 | Result := GetVclForm.OnClose;
|
---|
2151 | end;
|
---|
2152 |
|
---|
2153 | function TDpiForm.GetOnCloseQuery: TCloseQueryEvent;
|
---|
2154 | begin
|
---|
2155 | Result := GetVclForm.OnCloseQuery;
|
---|
2156 | end;
|
---|
2157 |
|
---|
2158 | function TDpiForm.GetOnCreate: TNotifyEvent;
|
---|
2159 | begin
|
---|
2160 | Result := GetVclForm.OnCreate;
|
---|
2161 | end;
|
---|
2162 |
|
---|
2163 | function TDpiForm.GetOnDeactivate: TNotifyEvent;
|
---|
2164 | begin
|
---|
2165 | Result := GetVclForm.OnDeactivate;
|
---|
2166 | end;
|
---|
2167 |
|
---|
2168 | function TDpiForm.GetOnDestroy: TNotifyEvent;
|
---|
2169 | begin
|
---|
2170 | Result := GetVclForm.OnDestroy;
|
---|
2171 | end;
|
---|
2172 |
|
---|
2173 | function TDpiForm.GetOnHide: TNotifyEvent;
|
---|
2174 | begin
|
---|
2175 | Result := GetVclForm.OnHide;
|
---|
2176 | end;
|
---|
2177 |
|
---|
2178 | function TDpiForm.GetOnShow: TNotifyEvent;
|
---|
2179 | begin
|
---|
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;
|
---|
2191 | end;
|
---|
2192 |
|
---|
2193 | procedure TDpiForm.SetBorderIcons(AValue: TBorderIcons);
|
---|
2194 | begin
|
---|
2195 | GetVclForm.BorderIcons := AValue;
|
---|
2196 | end;
|
---|
2197 |
|
---|
2198 | procedure TDpiForm.SetBorderStyle(AValue: TBorderStyle);
|
---|
2199 | begin
|
---|
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;
|
---|
2221 | end;
|
---|
2222 |
|
---|
2223 | procedure TDpiForm.SetModalResult(AValue: TModalResult);
|
---|
2224 | begin
|
---|
2225 | GetVclForm.ModalResult := AValue;
|
---|
2226 | end;
|
---|
2227 |
|
---|
2228 | procedure TDpiForm.SetOnClose(AValue: TCloseEvent);
|
---|
2229 | begin
|
---|
2230 | GetVclForm.OnClose := AValue;
|
---|
2231 | end;
|
---|
2232 |
|
---|
2233 | procedure TDpiForm.SetOnCloseQuery(AValue: TCloseQueryEvent);
|
---|
2234 | begin
|
---|
2235 | GetVclForm.OnCloseQuery := AValue;
|
---|
2236 | end;
|
---|
2237 |
|
---|
2238 | procedure TDpiForm.SetOnCreate(AValue: TNotifyEvent);
|
---|
2239 | begin
|
---|
2240 | GetVclForm.OnCreate := AValue;
|
---|
2241 | end;
|
---|
2242 |
|
---|
2243 | procedure TDpiForm.SetOnDeactivate(AValue: TNotifyEvent);
|
---|
2244 | begin
|
---|
2245 | GetVclForm.OnDeactivate := AValue;
|
---|
2246 | end;
|
---|
2247 |
|
---|
2248 | procedure TDpiForm.SetOnDestroy(AValue: TNotifyEvent);
|
---|
2249 | begin
|
---|
2250 | GetVclForm.OnDestroy := AValue;
|
---|
2251 | end;
|
---|
2252 |
|
---|
2253 | procedure TDpiForm.SetOnHide(AValue: TNotifyEvent);
|
---|
2254 | begin
|
---|
2255 | GetVclForm.OnHide := AValue;
|
---|
2256 | end;
|
---|
2257 |
|
---|
2258 | procedure TDpiForm.SetOnShow(AValue: TNotifyEvent);
|
---|
2259 | begin
|
---|
2260 | GetVclForm.OnShow := AValue;
|
---|
2261 | end;
|
---|
2262 |
|
---|
2263 | procedure TDpiForm.DoOnCreate;
|
---|
2264 | begin
|
---|
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);
|
---|
2293 | end;
|
---|
2294 |
|
---|
2295 | procedure TDpiForm.CreateParams(var p: TCreateParams);
|
---|
2296 | begin
|
---|
2297 | // TODO: VclForm.CreateParams(P);
|
---|
2298 | end;
|
---|
2299 |
|
---|
2300 | // This method is called by TWriter to retrieve the child components to write
|
---|
2301 | procedure TDpiForm.GetChildren(Proc: TGetChildProc; Root: TComponent);
|
---|
2302 | var
|
---|
2303 | I: Integer;
|
---|
2304 | OwnedComponent: TComponent;
|
---|
2305 | begin
|
---|
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;
|
---|
2314 | end;
|
---|
2315 |
|
---|
2316 | function TDpiForm.GetVclScrollingWinControl: TScrollingWinControl;
|
---|
2317 | begin
|
---|
2318 | Result := GetVclForm;
|
---|
2319 | end;
|
---|
2320 |
|
---|
2321 | function TDpiForm.GetVclForm: TForm;
|
---|
2322 | begin
|
---|
2323 | if not Assigned(VclForm) then begin
|
---|
2324 | VclForm := TFormEx.Create(nil);
|
---|
2325 | (VclForm as TFormEx).OnMessage := @FormMessageHandler;
|
---|
2326 | end;
|
---|
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;
|
---|
2338 | end;
|
---|
2339 |
|
---|
2340 | function TDpiForm.ShowModal: Integer;
|
---|
2341 | begin
|
---|
2342 | Result := GetVclForm.ShowModal;
|
---|
2343 | end;
|
---|
2344 |
|
---|
2345 | procedure TDpiForm.Close;
|
---|
2346 | begin
|
---|
2347 | GetVclForm.Close;
|
---|
2348 | end;
|
---|
2349 |
|
---|
2350 | procedure TDpiForm.BringToFront;
|
---|
2351 | begin
|
---|
2352 | GetVclForm.BringToFront;
|
---|
2353 | end;
|
---|
2354 |
|
---|
2355 | // Init the component with an IDE resource
|
---|
2356 | constructor TDpiForm.Create(TheOwner: TComponent);
|
---|
2357 | begin
|
---|
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;
|
---|
2373 | end;
|
---|
2374 |
|
---|
2375 | destructor TDpiForm.Destroy;
|
---|
2376 | begin
|
---|
2377 | FreeAndNil(VclForm);
|
---|
2378 | end;
|
---|
2379 |
|
---|
2380 | initialization
|
---|
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', '');
|
---|
2386 | DpiScreen := TDpiScreen.Create;
|
---|
2387 | DpiApplication := TDpiApplication.Create(nil);
|
---|
2388 |
|
---|
2389 | finalization
|
---|
2390 |
|
---|
2391 | FreeAndNil(DpiApplication);
|
---|
2392 | FreeAndNil(DpiScreen);
|
---|
2393 |
|
---|
2394 | end.
|
---|
2395 |
|
---|