source: trunk/Packages/DpiControls/Dpi.Controls.pas

Last change on this file was 570, checked in by chronos, 2 months ago
  • Fixed: Workaround for incorrectly styling TEdit controls under Gtk2.
File size: 34.9 KB
Line 
1unit Dpi.Controls;
2
3interface
4
5uses
6 Classes, SysUtils, Controls, Graphics, LCLType, Generics.Collections,
7 Dpi.Graphics;
8
9const
10 CM_MOUSELEAVE = Controls.CM_MOUSELEAVE;
11
12type
13 TMouseButton = Controls.TMouseButton;
14 TKeyEvent = Controls.TKeyEvent;
15 TAlign = Controls.TAlign;
16 TBorderStyle = Controls.TBorderStyle;
17
18 { TControlEx }
19
20 TControlEx = class(Controls.TControl)
21 public
22 property ParentColor;
23 property OnMouseDown;
24 property OnMouseUp;
25 property OnMouseMove;
26 property OnMouseWheel;
27 property OnMouseLeave;
28 property OnMouseEnter;
29 property OnDblClick;
30 property ParentFont;
31 end;
32
33 { TGraphicControlEx }
34
35 TGraphicControlEx = class(Controls.TGraphicControl)
36 public
37 property OnPaint;
38 procedure Paint; override;
39 end;
40
41 TWinControlEx = class(Controls.TWinControl)
42 public
43 property BorderStyle;
44 property OnKeyDown;
45 end;
46
47 TWinControl = class;
48 TControlBorderSpacing = class;
49
50 { TSizeConstraints }
51
52 TSizeConstraints = class(TPersistent)
53 private
54 FMaxHeight: TConstraintSize;
55 FMaxWidth: TConstraintSize;
56 FMinHeight: TConstraintSize;
57 FMinWidth: TConstraintSize;
58 procedure SetMaxHeight(AValue: TConstraintSize);
59 procedure SetMaxWidth(AValue: TConstraintSize);
60 procedure SetMinHeight(AValue: TConstraintSize);
61 procedure SetMinWidth(AValue: TConstraintSize);
62 published
63 property MaxHeight: TConstraintSize read FMaxHeight write SetMaxHeight default 0;
64 property MaxWidth: TConstraintSize read FMaxWidth write SetMaxWidth default 0;
65 property MinHeight: TConstraintSize read FMinHeight write SetMinHeight default 0;
66 property MinWidth: TConstraintSize read FMinWidth write SetMinWidth default 0;
67 end;
68
69 { TControl }
70
71 TControl = class(TComponent)
72 private
73 FBorderSpacing: TControlBorderSpacing;
74 FConstraints: TSizeConstraints;
75 FFont: TFont;
76 FHeight: Integer;
77 FLeft: Integer;
78 FOnChangeBounds: TNotifyEvent;
79 FOnMouseUp: TMouseEvent;
80 FOnMouseDown: TMouseEvent;
81 FOnMouseMove: TMouseMoveEvent;
82 FOnMouseEnter: TNotifyEvent;
83 FOnMouseLeave: TNotifyEvent;
84 FOnMouseWheel: TMouseWheelEvent;
85 FOnResize: TNotifyEvent;
86 FTop: Integer;
87 FWidth: Integer;
88 FParent: TWinControl;
89 function GetAlign: TAlign;
90 function GetAnchors: TAnchors;
91 function GetAutoSize: Boolean;
92 function GetBoundsRect: TRect;
93 function GetClientHeight: Integer;
94 function GetClientWidth: Integer;
95 function GetColor: TColor;
96 function GetCursor: TCursor;
97 function GetEnabled: Boolean;
98 function GetHint: string;
99 function GetOnClick: TNotifyEvent;
100 function GetOnDblClick: TNotifyEvent;
101 function GetParentColor: Boolean;
102 function GetParentFont: Boolean;
103 function GetShowHint: Boolean;
104 function GetVisible: Boolean;
105 function GetWindowProc: TWndMethod;
106 function IsAnchorsStored: Boolean;
107 procedure SetAlign(AValue: TAlign);
108 procedure SetAnchors(AValue: TAnchors);
109 procedure SetAutoSize(AValue: Boolean);
110 procedure SetBorderSpacing(AValue: TControlBorderSpacing);
111 procedure SetBoundsRect(AValue: TRect);
112 procedure SetClientHeight(AValue: Integer);
113 procedure SetClientWidth(AValue: Integer);
114 procedure SetColor(AValue: TColor);
115 procedure SetCursor(AValue: TCursor);
116 procedure SetEnabled(AValue: Boolean);
117 procedure SetFont(AValue: TFont);
118 procedure SetHint(AValue: string);
119 procedure SetOnClick(AValue: TNotifyEvent);
120 procedure SetOnDblClick(AValue: TNotifyEvent);
121 procedure SetParentColor(AValue: Boolean);
122 procedure SetParentFont(AValue: Boolean);
123 procedure SetShowHint(AValue: Boolean);
124 procedure NativeFormResize(Sender: TObject);
125 procedure NativeChangeBounds(Sender: TObject);
126 procedure DoFormResize;
127 procedure DoChangeBounds;
128 procedure MouseDownHandler(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
129 X, Y: Integer); virtual;
130 procedure MouseUpHandler(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
131 X, Y: Integer); virtual;
132 procedure MouseMoveHandler(Sender: TObject; Shift: TShiftState; X, Y: Integer); virtual;
133 procedure MouseWheelHandler(Sender: TObject; Shift: TShiftState;
134 WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean); virtual;
135 procedure MouseLeaveHandler(Sender: TObject); virtual;
136 procedure MouseEnterHandler(Sender: TObject); virtual;
137 procedure SetWindowProc(AValue: TWndMethod);
138 function ColorIsStored: Boolean; virtual;
139 protected
140 procedure DoBorderSpacingChange(Sender: TObject; InnerSpaceChanged: Boolean); virtual;
141 function GetText: TCaption; virtual;
142 procedure SetText(AValue: TCaption); virtual;
143 procedure UpdateBounds; virtual;
144 procedure FontChanged(Sender: TObject); virtual;
145 function GetCaption: string; virtual;
146 procedure SetParent(AValue: TWinControl); virtual;
147 procedure SetCaption(AValue: string); virtual;
148 procedure SetHeight(AValue: Integer); virtual;
149 procedure SetLeft(AValue: Integer); virtual;
150 procedure SetTop(AValue: Integer); virtual;
151 procedure SetVisible(AValue: Boolean); virtual;
152 procedure SetWidth(AValue: Integer); virtual;
153 function GetNativeControl: Controls.TControl; virtual;
154 procedure UpdateNativeControl; virtual;
155 procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
156 X, Y: Integer); virtual;
157 procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
158 X, Y: Integer); virtual;
159 procedure MouseMove(Shift: TShiftState; X, Y: Integer); virtual;
160 procedure MouseLeave; virtual;
161 procedure MouseEnter; virtual;
162 property Text: TCaption read GetText write SetText;
163 property ParentFont: Boolean read GetParentFont write SetParentFont default True;
164 property ParentColor: Boolean read GetParentColor write SetParentColor default True;
165 public
166 function ScreenToClient(const APoint: TPoint): TPoint; virtual;
167 function ClientToScreen(const APoint: TPoint): TPoint; virtual;
168 procedure AddHandlerOnVisibleChanged(const OnVisibleChangedEvent: TNotifyEvent;
169 AsFirst: boolean = false);
170 procedure RemoveHandlerOnVisibleChanged(const OnVisibleChangedEvent: TNotifyEvent);
171 procedure ScreenChanged; virtual;
172 procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); virtual;
173 procedure Show;
174 procedure Hide;
175 procedure Invalidate;
176 procedure Repaint;
177 procedure Update;
178 procedure Refresh;
179 function IsParentOf(AControl: TControl): Boolean; virtual;
180 function Scale96ToScreen(const ASize: Integer): Integer;
181 constructor Create(TheOwner: TComponent); override;
182 destructor Destroy; override;
183 property Parent: TWinControl read FParent write SetParent;
184 property BoundsRect: TRect read GetBoundsRect write SetBoundsRect;
185 property Visible: Boolean read GetVisible write SetVisible;
186 property Anchors: TAnchors read GetAnchors write SetAnchors stored IsAnchorsStored default [akLeft, akTop];
187 property BorderSpacing: TControlBorderSpacing read FBorderSpacing write SetBorderSpacing;
188 property WindowProc: TWndMethod read GetWindowProc write SetWindowProc;
189 published
190 property AutoSize: Boolean read GetAutoSize write SetAutoSize default False;
191 property ClientHeight: Integer read GetClientHeight write SetClientHeight;
192 property ClientWidth: Integer read GetClientWidth write SetClientWidth;
193 property Hint: string read GetHint write SetHint;
194 property Top: Integer read FTop write SetTop;
195 property Left: Integer read FLeft write SetLeft;
196 property Width: Integer read FWidth write SetWidth;
197 property Height: Integer read FHeight write SetHeight;
198 property Caption: string read GetCaption write SetCaption;
199 property Enabled: Boolean read GetEnabled write SetEnabled;
200 property ShowHint: Boolean read GetShowHint write SetShowHint;
201 property Font: TFont read FFont write SetFont;
202 property Align: TAlign read GetAlign write SetAlign;
203 property Color: TColor read GetColor write SetColor stored ColorIsStored default {$ifdef UseCLDefault}clDefault{$else}clWindow{$endif};
204 property Constraints: TSizeConstraints read FConstraints write FConstraints;
205 property Cursor: TCursor read GetCursor write SetCursor default crDefault;
206 property OnResize: TNotifyEvent read FOnResize write FOnResize;
207 property OnChangeBounds: TNotifyEvent read FOnChangeBounds write FOnChangeBounds;
208 property OnClick: TNotifyEvent read GetOnClick write SetOnClick;
209 property OnDblClick: TNotifyEvent read GetOnDblClick write SetOnDblClick;
210 property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;
211 property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;
212 property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp;
213 property OnMouseWheel: TMouseWheelEvent read FOnMouseWheel write FOnMouseWheel;
214 end;
215
216 TDpiControls = TObjectList<TControl>;
217
218 { TWinControl }
219
220 TWinControl = class(TControl)
221 private
222 FOnKeyDown: TKeyEvent;
223 function GetBorderStyle: TBorderStyle;
224 function GetHandle: HWND;
225 function GetOnKeyDown: TKeyEvent;
226 function GetOnKeyPress: TKeyPressEvent;
227 function GetOnKeyUp: TKeyEvent;
228 function GetTabOrder: TTabOrder;
229 function GetTabStop: Boolean;
230 procedure SetBorderStyle(AValue: TBorderStyle);
231 procedure SetHandle(AValue: HWND);
232 procedure SetOnKeyDown(AValue: TKeyEvent);
233 procedure SetOnKeyPress(AValue: TKeyPressEvent);
234 procedure SetOnKeyUp(AValue: TKeyEvent);
235 procedure SetTabOrder(AValue: TTabOrder);
236 procedure SetTabStop(AValue: Boolean);
237 procedure KeyDownHandler(Sender: TObject; var Key: Word; Shift: TShiftState);
238 protected
239 procedure UpdateNativeControl; override;
240 function GetNativeControl: Controls.TControl; override;
241 function GetNativeWinControl: Controls.TWinControl; virtual;
242 property BorderStyle: TBorderStyle read GetBorderStyle write SetBorderStyle default bsNone;
243 procedure KeyDown(var Key: Word; Shift: TShiftState); virtual;
244 public
245 Controls: TDpiControls;
246 function HandleAllocated: Boolean;
247 procedure ScreenChanged; override;
248 function ControlCount: Integer;
249 procedure SetFocus; virtual;
250 constructor Create(TheOwner: TComponent); override;
251 destructor Destroy; override;
252 property Handle: HWND read GetHandle write SetHandle;
253 published
254 property TabOrder: TTabOrder read GetTabOrder write SetTabOrder default -1;
255 property TabStop: Boolean read GetTabStop write SetTabStop default False;
256 property OnKeyDown: TKeyEvent read FOnKeyDown write FOnKeyDown;
257 property OnKeyPress: TKeyPressEvent read GetOnKeyPress write SetOnKeyPress;
258 property OnKeyUp: TKeyEvent read GetOnKeyUp write SetOnKeyUp;
259 end;
260
261 { TControlBorderSpacing }
262
263 TControlBorderSpacing = class(TPersistent)
264 private
265 FAround: TSpacingSize;
266 FBottom: TSpacingSize;
267 FLeft: TSpacingSize;
268 FOnChange: TNotifyEvent;
269 FRight: TSpacingSize;
270 FTop: TSpacingSize;
271 FControl: TControl;
272 FDefault: PControlBorderSpacingDefault;
273 function IsAroundStored: Boolean;
274 function IsBottomStored: Boolean;
275 function IsLeftStored: Boolean;
276 function IsRightStored: Boolean;
277 function IsTopStored: Boolean;
278 procedure SetAround(AValue: TSpacingSize);
279 procedure SetBottom(AValue: TSpacingSize);
280 procedure SetLeft(AValue: TSpacingSize);
281 procedure SetRight(AValue: TSpacingSize);
282 procedure SetTop(AValue: TSpacingSize);
283 procedure Change(InnerSpaceChanged: Boolean); virtual;
284 public
285 constructor Create(OwnerControl: TControl; ADefault: PControlBorderSpacingDefault = nil);
286 published
287 property OnChange: TNotifyEvent read FOnChange write FOnChange;
288 property Around: TSpacingSize read FAround write SetAround stored IsAroundStored;
289 property Left: TSpacingSize read FLeft write SetLeft stored IsLeftStored;
290 property Top: TSpacingSize read FTop write SetTop stored IsTopStored;
291 property Right: TSpacingSize read FRight write SetRight stored IsRightStored;
292 property Bottom: TSpacingSize read FBottom write SetBottom stored IsBottomStored;
293 end;
294
295 { TCustomControl }
296
297 TCustomControl = class(TWinControl)
298 private
299 FCanvas: TCanvas;
300 function GetCanvas: TCanvas;
301 function GetOnPaint: TNotifyEvent;
302 function GetPixelsPerInch: Integer;
303 procedure SetOnPaint(AValue: TNotifyEvent);
304 procedure SetPixelsPerInch(AValue: Integer);
305 protected
306 function GetNativeWinControl: Controls.TWinControl; override;
307 function GetNativeCustomControl: Controls.TCustomControl; virtual;
308 public
309 constructor Create(TheOwner: TComponent); override;
310 destructor Destroy; override;
311 property Canvas: TCanvas read GetCanvas;
312 published
313 property PixelsPerInch: Integer read GetPixelsPerInch write SetPixelsPerInch stored False;
314 property OnPaint: TNotifyEvent read GetOnPaint write SetOnPaint;
315 end;
316
317 { TGraphicControl }
318
319 TGraphicControl = class(TControl)
320 private
321 FOnPaint: TNotifyEvent;
322 NativeGraphicControl: Controls.TGraphicControl;
323 FCanvas: TCanvas;
324 function GetOnPaint: TNotifyEvent;
325 procedure SetCanvas(AValue: TCanvas);
326 procedure PaintHandler(Sender: TObject);
327 procedure SetOnPaint(AValue: TNotifyEvent);
328 protected
329 procedure Paint; virtual;
330 function GetNativeControl: Controls.TControl; override;
331 function GetNativeGraphicControl: Controls.TGraphicControl; virtual;
332 procedure UpdateNativeControl; override;
333 property OnPaint: TNotifyEvent read GetOnPaint write SetOnPaint;
334 public
335 constructor Create(TheOwner: TComponent); override;
336 destructor Destroy; override;
337 published
338 property Canvas: TCanvas read FCanvas write SetCanvas;
339 end;
340
341 { TMouse }
342
343 TMouse = class
344 private
345 function GetCursorPos: TPoint;
346 procedure SetCursorPos(AValue: TPoint);
347 public
348 constructor Create;
349 destructor Destroy; override;
350 property CursorPos: TPoint read GetCursorPos write SetCursorPos;
351 end;
352
353 { TImageList }
354
355 TImageList = class(TComponent)
356 private
357 NativeImageList: Controls.TImageList;
358 function GetCount: Integer;
359 function GetHeight: Integer;
360 function GetWidth: Integer;
361 procedure SetHeight(AValue: Integer);
362 procedure SetWidth(AValue: Integer);
363 public
364 function GetNativeImageList: Controls.TImageList;
365 procedure GetBitmap(Index: Integer; Image: TBitmap);
366 procedure BeginUpdate;
367 procedure EndUpdate;
368 procedure Clear;
369 function Add(Image, Mask: TBitmap): Integer;
370 constructor Create(TheOwner: TComponent); override;
371 destructor Destroy; override;
372 property Width: Integer read GetWidth write SetWidth default 16;
373 property Height: Integer read GetHeight write SetHeight default 16;
374 property Count: Integer read GetCount;
375 end;
376
377
378var
379 Mouse: TMouse;
380
381
382implementation
383
384uses
385 Dpi.Common;
386
387{ TCustomControl }
388
389function TCustomControl.GetOnPaint: TNotifyEvent;
390begin
391 Result := GetNativeCustomControl.OnPaint;
392end;
393
394function TCustomControl.GetPixelsPerInch: Integer;
395begin
396 //Result := GetNativeCustomControl.Pix;
397end;
398
399function TCustomControl.GetCanvas: TCanvas;
400begin
401 Result := FCanvas;
402end;
403
404procedure TCustomControl.SetOnPaint(AValue: TNotifyEvent);
405begin
406 GetNativeCustomControl.OnPaint := AValue;
407end;
408
409procedure TCustomControl.SetPixelsPerInch(AValue: Integer);
410begin
411end;
412
413function TCustomControl.GetNativeWinControl: Controls.TWinControl;
414begin
415 Result := GetNativeCustomControl;
416end;
417
418function TCustomControl.GetNativeCustomControl: Controls.TCustomControl;
419begin
420 Result := nil;
421end;
422
423constructor TCustomControl.Create(TheOwner: TComponent);
424begin
425 inherited;
426 FCanvas := TCanvas.Create;
427 FCanvas.NativeCanvas := GetNativeCustomControl.Canvas;
428end;
429
430destructor TCustomControl.Destroy;
431begin
432 FreeAndNil(FCanvas);
433 inherited;
434end;
435
436{ TWinControl }
437
438function TWinControl.GetBorderStyle: TBorderStyle;
439begin
440 {$objectChecks-}
441 Result := TWinControlEx(GetNativeWinControl).BorderStyle;
442 {$objectChecks+}
443end;
444
445function TWinControl.GetHandle: HWND;
446begin
447 Result := GetNativeWinControl.Handle;
448end;
449
450function TWinControl.GetOnKeyDown: TKeyEvent;
451begin
452 Result := GetNativeWinControl.OnKeyDown;
453end;
454
455function TWinControl.GetOnKeyPress: TKeyPressEvent;
456begin
457 Result := GetNativeWinControl.OnKeyPress;
458end;
459
460function TWinControl.GetOnKeyUp: TKeyEvent;
461begin
462 Result := GetNativeWinControl.OnKeyUp;
463end;
464
465function TWinControl.GetTabOrder: TTabOrder;
466begin
467 Result := GetNativeWinControl.TabOrder;
468end;
469
470function TWinControl.GetTabStop: Boolean;
471begin
472 Result := GetNativeWinControl.TabStop;
473end;
474
475procedure TWinControl.SetBorderStyle(AValue: TBorderStyle);
476begin
477 {$objectChecks-}
478 TWinControlEx(GetNativeWinControl).BorderStyle := AValue;
479 {$objectChecks+}
480end;
481
482procedure TWinControl.SetHandle(AValue: HWND);
483begin
484 GetNativeWinControl.Handle := AValue;
485end;
486
487procedure TWinControl.SetOnKeyDown(AValue: TKeyEvent);
488begin
489 GetNativeWinControl.OnKeyDown := AValue;
490end;
491
492procedure TWinControl.SetOnKeyPress(AValue: TKeyPressEvent);
493begin
494 GetNativeWinControl.OnKeyPress := AValue;
495end;
496
497procedure TWinControl.SetOnKeyUp(AValue: TKeyEvent);
498begin
499 GetNativeWinControl.OnKeyUp := AValue;
500end;
501
502procedure TWinControl.SetTabOrder(AValue: TTabOrder);
503begin
504 GetNativeWinControl.TabOrder := AValue;
505end;
506
507procedure TWinControl.SetTabStop(AValue: Boolean);
508begin
509 GetNativeWinControl.TabStop := AValue;
510end;
511
512procedure TWinControl.KeyDownHandler(Sender: TObject; var Key: Word;
513 Shift: TShiftState);
514begin
515 KeyDown(Key, Shift);
516 if Assigned(FOnKeyDown) then FOnKeyDown(Self, Key, Shift);
517end;
518
519procedure TWinControl.UpdateNativeControl;
520begin
521 inherited;
522 GetNativeWinControl.OnKeyDown := KeyDownHandler;
523end;
524
525function TWinControl.GetNativeControl: Controls.TControl;
526begin
527 Result := GetNativeWinControl;
528end;
529
530function TWinControl.GetNativeWinControl: Controls.TWinControl;
531begin
532 Result := nil;
533end;
534
535procedure TWinControl.KeyDown(var Key: Word; Shift: TShiftState);
536begin
537end;
538
539function TWinControl.HandleAllocated: Boolean;
540begin
541 Result := GetNativeWinControl.HandleAllocated;
542end;
543
544procedure TWinControl.ScreenChanged;
545var
546 I: Integer;
547begin
548 inherited;
549 for I := 0 to Controls.Count - 1 do
550 Controls[I].ScreenChanged;
551end;
552
553function TWinControl.ControlCount: Integer;
554begin
555 Result := Controls.Count;
556end;
557
558procedure TWinControl.SetFocus;
559begin
560 GetNativeWinControl.SetFocus;
561end;
562
563constructor TWinControl.Create(TheOwner: TComponent);
564begin
565 Controls := TDpiControls.Create;
566 Controls.OwnsObjects := False;
567 inherited;
568end;
569
570destructor TWinControl.Destroy;
571begin
572 FreeAndNil(Controls);
573 inherited;
574end;
575
576{ TControl }
577
578procedure TControl.SetTop(AValue: Integer);
579begin
580 if FTop = AValue then Exit;
581 FTop := AValue;
582 UpdateBounds;
583end;
584
585procedure TControl.SetVisible(AValue: Boolean);
586begin
587 GetNativeControl.Visible := AValue;
588end;
589
590procedure TControl.SetWidth(AValue: Integer);
591begin
592 if FWidth = AValue then Exit;
593 FWidth := AValue;
594 UpdateBounds;
595end;
596
597function TControl.GetNativeControl: Controls.TControl;
598begin
599 Result := nil;
600end;
601
602procedure TControl.UpdateNativeControl;
603begin
604 Font.NativeFont := GetNativeControl.Font;
605 GetNativeControl.OnResize := NativeFormResize;
606 GetNativeControl.OnChangeBounds := NativeChangeBounds;
607
608 {$objectChecks-}
609 TControlEx(GetNativeControl).OnMouseDown := MouseDownHandler;
610 TControlEx(GetNativeControl).OnMouseUp := MouseUpHandler;
611 TControlEx(GetNativeControl).OnMouseMove := MouseMoveHandler;
612 TControlEx(GetNativeControl).OnMouseEnter := MouseEnterHandler;
613 TControlEx(GetNativeControl).OnMouseLeave := MouseLeaveHandler;
614 TControlEx(GetNativeControl).OnMouseWheel := MouseWheelHandler;
615 {$objectChecks+}
616end;
617
618procedure TControl.MouseDownHandler(Sender: TObject; Button: TMouseButton;
619 Shift: TShiftState; X, Y: Integer);
620begin
621 MouseDown(Button, Shift, ScaleFromNative(X), ScaleFromNative(Y));
622 if Assigned(FOnMouseDown) then FOnMouseDown(Self, Button, Shift, ScaleFromNative(X), ScaleFromNative(Y));
623end;
624
625procedure TControl.MouseUpHandler(Sender: TObject; Button: TMouseButton;
626 Shift: TShiftState; X, Y: Integer);
627begin
628 MouseUp(Button, Shift, ScaleFromNative(X), ScaleFromNative(Y));
629 if Assigned(FOnMouseUp) then FOnMouseUp(Self, Button, Shift, ScaleFromNative(X), ScaleFromNative(Y));
630end;
631
632procedure TControl.MouseMoveHandler(Sender: TObject; Shift: TShiftState; X,
633 Y: Integer);
634begin
635 MouseMove(Shift, ScaleFromNative(X), ScaleFromNative(Y));
636 if Assigned(FOnMouseMove) then FOnMouseMove(Self, Shift, ScaleFromNative(X), ScaleFromNative(Y));
637end;
638
639procedure TControl.MouseWheelHandler(Sender: TObject; Shift: TShiftState;
640 WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
641begin
642 if Assigned(FOnMouseWheel) then FOnMouseWheel(Self, Shift, WheelDelta,
643 ScalePointFromNative(MousePos), Handled);
644end;
645
646procedure TControl.MouseLeaveHandler(Sender: TObject);
647begin
648 MouseLeave;
649 if Assigned(FOnMouseLeave) then FOnMouseLeave(Self);
650end;
651
652procedure TControl.MouseEnterHandler(Sender: TObject);
653begin
654 MouseEnter;
655 if Assigned(FOnMouseEnter) then FOnMouseEnter(Self);
656end;
657
658procedure TControl.SetWindowProc(AValue: TWndMethod);
659begin
660 GetNativeControl.WindowProc := AValue;
661end;
662
663function TControl.ColorIsStored: Boolean;
664begin
665 Result := not ParentColor;
666end;
667
668procedure TControl.DoBorderSpacingChange(Sender: TObject;
669 InnerSpaceChanged: Boolean);
670begin
671 GetNativeControl.BorderSpacing.Left := ScaleToNative(FBorderSpacing.Left);
672 GetNativeControl.BorderSpacing.Right := ScaleToNative(FBorderSpacing.Right);
673 GetNativeControl.BorderSpacing.Top := ScaleToNative(FBorderSpacing.Top);
674 GetNativeControl.BorderSpacing.Bottom := ScaleToNative(FBorderSpacing.Bottom);
675 GetNativeControl.BorderSpacing.Around := ScaleToNative(FBorderSpacing.Around);
676end;
677
678procedure TControl.SetText(AValue: TCaption);
679begin
680
681end;
682
683procedure TControl.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
684 Y: Integer);
685begin
686end;
687
688procedure TControl.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
689 Y: Integer);
690begin
691end;
692
693procedure TControl.MouseMove(Shift: TShiftState; X, Y: Integer);
694begin
695end;
696
697procedure TControl.MouseLeave;
698begin
699end;
700
701procedure TControl.MouseEnter;
702begin
703end;
704
705function TControl.ScreenToClient(const APoint: TPoint): TPoint;
706begin
707 Result := ScalePointFromNative(GetNativeControl.ScreenToClient(ScalePointToNative(APoint)));
708end;
709
710function TControl.ClientToScreen(const APoint: TPoint): TPoint;
711begin
712 Result := ScalePointFromNative(GetNativeControl.ClientToScreen(ScalePointToNative(APoint)));
713end;
714
715procedure TControl.AddHandlerOnVisibleChanged(
716 const OnVisibleChangedEvent: TNotifyEvent; AsFirst: boolean);
717begin
718 GetNativeControl.AddHandlerOnVisibleChanged(OnVisibleChangedEvent, AsFirst);
719end;
720
721procedure TControl.RemoveHandlerOnVisibleChanged(
722 const OnVisibleChangedEvent: TNotifyEvent);
723begin
724 GetNativeControl.RemoveHandlerOnVisibleChanged(OnVisibleChangedEvent);
725end;
726
727procedure TControl.ScreenChanged;
728begin
729 UpdateBounds;
730 Font.ScreenChanged;
731end;
732
733procedure TControl.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
734begin
735 FLeft := ALeft;
736 FTop := ATop;
737 FWidth := AWidth;
738 FHeight := AHeight;
739 UpdateBounds;
740end;
741
742procedure TControl.Show;
743begin
744 Visible := True;
745end;
746
747procedure TControl.Hide;
748begin
749 Visible := False;
750end;
751
752procedure TControl.Invalidate;
753begin
754 GetNativeControl.Invalidate;
755end;
756
757procedure TControl.Repaint;
758begin
759 GetNativeControl.Repaint;
760end;
761
762procedure TControl.Update;
763begin
764 GetNativeControl.Update;
765end;
766
767procedure TControl.Refresh;
768begin
769 GetNativeControl.Refresh;
770end;
771
772function TControl.IsParentOf(AControl: TControl): Boolean;
773begin
774 Result := False;
775 while Assigned(AControl) do
776 begin
777 AControl := AControl.Parent;
778 if Self = AControl then
779 Exit(True);
780 end;
781end;
782
783function TControl.Scale96ToScreen(const ASize: Integer): Integer;
784begin
785 Result := MulDiv(ASize, ScreenInfo.Dpi, 96);
786end;
787
788constructor TControl.Create(TheOwner: TComponent);
789begin
790 inherited;
791 FFont := TFont.Create;
792 FFont.OnChange := FontChanged;
793 FConstraints := TSizeConstraints.Create;
794 if Assigned(TheOwner) and (TheOwner is TWinControl) then
795 Parent := TWinControl(TheOwner);
796 FBorderSpacing := TControlBorderSpacing.Create(Self);
797 GetNativeControl;
798 UpdateNativeControl;
799 ScreenChanged;
800end;
801
802destructor TControl.Destroy;
803begin
804 FreeAndNil(FBorderSpacing);
805 FreeAndNil(FConstraints);
806 FreeAndNil(FFont);
807 inherited;
808end;
809
810procedure TControl.SetLeft(AValue: Integer);
811begin
812 if FLeft = AValue then Exit;
813 FLeft := AValue;
814 UpdateBounds;
815end;
816
817procedure TControl.SetCaption(AValue: string);
818begin
819 GetNativeControl.Caption := AValue;
820end;
821
822procedure TControl.SetParent(AValue: TWinControl);
823begin
824 if FParent = AValue then Exit;
825 if Assigned(FParent) then begin
826 FParent.Controls.Remove(Self);
827 if Assigned(FParent) and (FParent is TWinControl) then
828 GetNativeControl.Parent := nil;
829 end;
830 FParent := AValue;
831 if Assigned(FParent) then begin
832 FParent.Controls.Add(Self);
833 if Assigned(FParent) and (FParent is TWinControl) then
834 GetNativeControl.Parent := TWinControl(FParent).GetNativeWinControl;
835 end;
836end;
837
838procedure TControl.SetFont(AValue: TFont);
839begin
840 if FFont = AValue then Exit;
841 FFont := AValue;
842end;
843
844procedure TControl.SetHint(AValue: string);
845begin
846 GetNativeControl.Hint := AValue;
847end;
848
849function TControl.GetBoundsRect: TRect;
850begin
851 Result.Left := Left;
852 Result.Top := Top;
853 Result.Right := Left + Width;
854 Result.Bottom := Top + Height;
855end;
856
857function TControl.GetAlign: TAlign;
858begin
859 Result := GetNativeControl.Align;
860end;
861
862function TControl.GetAnchors: TAnchors;
863begin
864 Result := GetNativeControl.Anchors;
865end;
866
867function TControl.GetAutoSize: Boolean;
868begin
869 Result := GetNativeControl.AutoSize;
870end;
871
872function TControl.GetClientHeight: Integer;
873begin
874 Result := ScaleFromNative(GetNativeControl.ClientHeight);
875end;
876
877function TControl.GetClientWidth: Integer;
878begin
879 Result := ScaleFromNative(GetNativeControl.ClientWidth);
880end;
881
882function TControl.GetColor: TColor;
883begin
884 Result := GetNativeControl.Color;
885end;
886
887function TControl.GetCursor: TCursor;
888begin
889 Result := GetNativeControl.Cursor;
890end;
891
892function TControl.GetEnabled: Boolean;
893begin
894 Result := GetNativeControl.Enabled;
895end;
896
897function TControl.GetHint: string;
898begin
899 Result := GetNativeControl.Hint;
900end;
901
902function TControl.GetOnClick: TNotifyEvent;
903begin
904 Result := GetNativeControl.OnClick;
905end;
906
907function TControl.GetOnDblClick: TNotifyEvent;
908begin
909 {$objectChecks-}
910 Result := TControlEx(GetNativeControl).OnDblClick;
911 {$objectChecks+}
912end;
913
914function TControl.GetParentColor: Boolean;
915begin
916 {$objectChecks-}
917 Result := TControlEx(GetNativeControl).ParentColor;
918 {$objectChecks+}
919end;
920
921function TControl.GetParentFont: Boolean;
922begin
923 {$objectChecks-}
924 Result := TControlEx(GetNativeControl).ParentFont;
925 {$objectChecks+}
926end;
927
928function TControl.GetShowHint: Boolean;
929begin
930 Result := GetNativeControl.ShowHint;
931end;
932
933function TControl.GetText: TCaption;
934begin
935 Result := '';
936end;
937
938function TControl.GetVisible: Boolean;
939begin
940 Result := GetNativeControl.Visible;
941end;
942
943function TControl.GetWindowProc: TWndMethod;
944begin
945 Result := GetNativeControl.WindowProc;
946end;
947
948function TControl.IsAnchorsStored: Boolean;
949begin
950
951end;
952
953procedure TControl.SetAlign(AValue: TAlign);
954begin
955 GetNativeControl.Align := AValue;
956end;
957
958procedure TControl.SetAnchors(AValue: TAnchors);
959begin
960 GetNativeControl.Anchors := AValue;
961end;
962
963procedure TControl.SetAutoSize(AValue: Boolean);
964begin
965 GetNativeControl.AutoSize := AValue;
966end;
967
968procedure TControl.SetBorderSpacing(AValue: TControlBorderSpacing);
969begin
970 if FBorderSpacing = AValue then Exit;
971 FBorderSpacing := AValue;
972end;
973
974procedure TControl.SetBoundsRect(AValue: TRect);
975begin
976 SetBounds(AValue.Left, AValue.Top, AValue.Right - AValue.Left, AValue.Bottom - AValue.Top);
977end;
978
979procedure TControl.SetClientHeight(AValue: Integer);
980begin
981 GetNativeControl.ClientHeight := ScaleToNative(AValue);
982end;
983
984procedure TControl.SetClientWidth(AValue: Integer);
985begin
986 GetNativeControl.ClientWidth := ScaleToNative(AValue);
987end;
988
989procedure TControl.SetColor(AValue: TColor);
990begin
991 GetNativeControl.Color := AValue;
992end;
993
994procedure TControl.SetCursor(AValue: TCursor);
995begin
996 GetNativeControl.Cursor := AValue;
997end;
998
999procedure TControl.SetEnabled(AValue: Boolean);
1000begin
1001 GetNativeControl.Enabled := AValue;
1002end;
1003
1004procedure TControl.SetOnClick(AValue: TNotifyEvent);
1005begin
1006 GetNativeControl.OnClick := AValue;
1007end;
1008
1009procedure TControl.SetOnDblClick(AValue: TNotifyEvent);
1010begin
1011 {$objectChecks-}
1012 TControlEx(GetNativeControl).OnDblClick := AValue;
1013 {$objectChecks+}
1014end;
1015
1016procedure TControl.SetParentColor(AValue: Boolean);
1017begin
1018 {$objectChecks-}
1019 TControlEx(GetNativeControl).ParentColor := AValue;
1020 {$objectChecks+}
1021end;
1022
1023procedure TControl.SetParentFont(AValue: Boolean);
1024begin
1025 {$objectChecks-}
1026 TControlEx(GetNativeControl).ParentFont := AValue;
1027 {$objectChecks+}
1028end;
1029
1030procedure TControl.SetShowHint(AValue: Boolean);
1031begin
1032 GetNativeControl.ShowHint := AValue;
1033end;
1034
1035procedure TControl.NativeFormResize(Sender: TObject);
1036var
1037 R: TRect;
1038begin
1039 R := ScaleRectFromNative(GetNativeControl.BoundsRect);
1040 FLeft := R.Left;
1041 FTop := R.Top;
1042 FWidth := R.Width;
1043 FHeight := R.Height;
1044 DoFormResize;
1045end;
1046
1047procedure TControl.NativeChangeBounds(Sender: TObject);
1048var
1049 NewBounds: TRect;
1050begin
1051 NewBounds := ScaleRectFromNative(GetNativeControl.BoundsRect);
1052 if NewBounds <> BoundsRect then begin
1053 FLeft := NewBounds.Left;
1054 FTop := NewBounds.Top;
1055 FWidth := NewBounds.Width;
1056 FHeight := NewBounds.Height;
1057 DoChangeBounds;
1058 end;
1059end;
1060
1061procedure TControl.DoFormResize;
1062begin
1063 if Assigned(FOnResize) then begin
1064 FOnResize(Self);
1065 end;
1066end;
1067
1068procedure TControl.DoChangeBounds;
1069begin
1070 if Assigned(FOnChangeBounds) then FOnChangeBounds(Self);
1071end;
1072
1073function TControl.GetCaption: string;
1074begin
1075 Result := GetNativeControl.Caption;
1076end;
1077
1078procedure TControl.FontChanged(Sender: TObject);
1079begin
1080 GetNativeControl.Font.Size := ScaleToNative(Font.Size);
1081end;
1082
1083procedure TControl.UpdateBounds;
1084begin
1085 GetNativeControl.BoundsRect := ScaleRectToNative(BoundsRect);
1086end;
1087
1088procedure TControl.SetHeight(AValue: Integer);
1089begin
1090 if FHeight = AValue then Exit;
1091 FHeight := AValue;
1092 UpdateBounds;
1093end;
1094
1095{ TControlBorderSpacing }
1096
1097function TControlBorderSpacing.IsBottomStored: Boolean;
1098begin
1099 if FDefault = nil
1100 then Result := FBottom <> 0
1101 else Result := FBottom <> FDefault^.Bottom;
1102end;
1103
1104function TControlBorderSpacing.IsAroundStored: Boolean;
1105begin
1106 if FDefault = nil
1107 then Result := FAround <> 0
1108 else Result := FAround <> FDefault^.Around;
1109end;
1110
1111function TControlBorderSpacing.IsLeftStored: Boolean;
1112begin
1113 if FDefault = nil
1114 then Result := FLeft <> 0
1115 else Result := FLeft <> FDefault^.Left;
1116end;
1117
1118function TControlBorderSpacing.IsRightStored: Boolean;
1119begin
1120 if FDefault = nil
1121 then Result := FRight <> 0
1122 else Result := FRight <> FDefault^.Right;
1123end;
1124
1125function TControlBorderSpacing.IsTopStored: Boolean;
1126begin
1127 if FDefault = nil
1128 then Result := FTop <> 0
1129 else Result := FTop <> FDefault^.Top;
1130end;
1131
1132procedure TControlBorderSpacing.SetAround(AValue: TSpacingSize);
1133begin
1134 if FAround = AValue then Exit;
1135 FAround := AValue;
1136 Change(False);
1137end;
1138
1139procedure TControlBorderSpacing.SetBottom(AValue: TSpacingSize);
1140begin
1141 if FBottom = AValue then Exit;
1142 FBottom := AValue;
1143 Change(False);
1144end;
1145
1146procedure TControlBorderSpacing.SetLeft(AValue: TSpacingSize);
1147begin
1148 if FLeft = AValue then Exit;
1149 FLeft := AValue;
1150 Change(False);
1151end;
1152
1153procedure TControlBorderSpacing.SetRight(AValue: TSpacingSize);
1154begin
1155 if FRight = AValue then Exit;
1156 FRight := AValue;
1157 Change(False);
1158end;
1159
1160procedure TControlBorderSpacing.SetTop(AValue: TSpacingSize);
1161begin
1162 if FTop = AValue then Exit;
1163 FTop := AValue;
1164 Change(False);
1165end;
1166
1167procedure TControlBorderSpacing.Change(InnerSpaceChanged: Boolean);
1168begin
1169 if FControl <> nil then
1170 FControl.DoBorderSpacingChange(Self, InnerSpaceChanged);
1171 if Assigned(OnChange) then OnChange(Self);
1172end;
1173
1174constructor TControlBorderSpacing.Create(OwnerControl: TControl;
1175 ADefault: PControlBorderSpacingDefault);
1176begin
1177 FControl := OwnerControl;
1178 FDefault := ADefault;
1179 if ADefault <> nil then
1180 begin
1181 FLeft := ADefault^.Left;
1182 FRight := ADefault^.Right;
1183 FTop := ADefault^.Top;
1184 FBottom := ADefault^.Bottom;
1185 FAround := ADefault^.Around;
1186 end;
1187 inherited Create;
1188end;
1189
1190{ TSizeConstraints }
1191
1192procedure TSizeConstraints.SetMaxHeight(AValue: TConstraintSize);
1193begin
1194 if FMaxHeight=AValue then Exit;
1195 FMaxHeight:=AValue;
1196end;
1197
1198procedure TSizeConstraints.SetMaxWidth(AValue: TConstraintSize);
1199begin
1200 if FMaxWidth=AValue then Exit;
1201 FMaxWidth:=AValue;
1202end;
1203
1204procedure TSizeConstraints.SetMinHeight(AValue: TConstraintSize);
1205begin
1206 if FMinHeight=AValue then Exit;
1207 FMinHeight:=AValue;
1208end;
1209
1210procedure TSizeConstraints.SetMinWidth(AValue: TConstraintSize);
1211begin
1212 if FMinWidth=AValue then Exit;
1213 FMinWidth:=AValue;
1214end;
1215
1216{ TGraphicControl }
1217
1218procedure TGraphicControl.SetCanvas(AValue: TCanvas);
1219begin
1220 if FCanvas = AValue then Exit;
1221 FCanvas := AValue;
1222end;
1223
1224procedure TGraphicControl.PaintHandler(Sender: TObject);
1225begin
1226 Paint;
1227 if Assigned(FOnPaint) then
1228 FOnPaint(Sender);
1229end;
1230
1231procedure TGraphicControl.Paint;
1232begin
1233end;
1234
1235function TGraphicControl.GetNativeControl: Controls.TControl;
1236begin
1237 Result := GetNativeGraphicControl;
1238end;
1239
1240function TGraphicControl.GetNativeGraphicControl: Controls.TGraphicControl;
1241begin
1242 Result := NativeGraphicControl;
1243end;
1244
1245procedure TGraphicControl.UpdateNativeControl;
1246begin
1247 inherited;
1248 {$objectChecks-}
1249 TGraphicControlEx(GetNativeGraphicControl).OnPaint := PaintHandler;
1250 {$objectChecks+}
1251end;
1252
1253function TGraphicControl.GetOnPaint: TNotifyEvent;
1254begin
1255 Result := FOnPaint;
1256end;
1257
1258procedure TGraphicControl.SetOnPaint(AValue: TNotifyEvent);
1259begin
1260 FOnPaint := AValue;
1261end;
1262
1263constructor TGraphicControl.Create(TheOwner: TComponent);
1264begin
1265 NativeGraphicControl := Controls.TGraphicControl.Create(nil);
1266 inherited;
1267 FCanvas := TCanvas.Create;
1268 FCanvas.NativeCanvas := GetNativeGraphicControl.Canvas;
1269end;
1270
1271destructor TGraphicControl.Destroy;
1272begin
1273 FreeAndNil(FCanvas);
1274 FreeAndNil(NativeGraphicControl);
1275 inherited;
1276end;
1277
1278{ TGraphicControlEx }
1279
1280procedure TGraphicControlEx.Paint;
1281begin
1282 inherited Paint;
1283end;
1284
1285{ TMouse }
1286
1287function TMouse.GetCursorPos: TPoint;
1288begin
1289 Result := ScalePointFromNative(Controls.Mouse.CursorPos);
1290end;
1291
1292procedure TMouse.SetCursorPos(AValue: TPoint);
1293begin
1294 Controls.Mouse.CursorPos := ScalePointToNative(AValue);
1295end;
1296
1297constructor TMouse.Create;
1298begin
1299end;
1300
1301destructor TMouse.Destroy;
1302begin
1303 inherited;
1304end;
1305
1306{ TImageList }
1307
1308function TImageList.GetHeight: Integer;
1309begin
1310
1311end;
1312
1313function TImageList.GetCount: Integer;
1314begin
1315
1316end;
1317
1318function TImageList.GetWidth: Integer;
1319begin
1320
1321end;
1322
1323procedure TImageList.SetHeight(AValue: Integer);
1324begin
1325
1326end;
1327
1328procedure TImageList.SetWidth(AValue: Integer);
1329begin
1330
1331end;
1332
1333function TImageList.GetNativeImageList: Controls.TImageList;
1334begin
1335 if not Assigned(NativeImageList) then
1336 NativeImageList := Controls.TImageList.Create(nil);
1337 Result := NativeImageList;
1338end;
1339
1340procedure TImageList.GetBitmap(Index: Integer; Image: TBitmap);
1341begin
1342
1343end;
1344
1345procedure TImageList.BeginUpdate;
1346begin
1347
1348end;
1349
1350procedure TImageList.EndUpdate;
1351begin
1352
1353end;
1354
1355procedure TImageList.Clear;
1356begin
1357
1358end;
1359
1360function TImageList.Add(Image, Mask: TBitmap): Integer;
1361begin
1362
1363end;
1364
1365constructor TImageList.Create(TheOwner: TComponent);
1366begin
1367 inherited Create(TheOwner);
1368end;
1369
1370destructor TImageList.Destroy;
1371begin
1372 FreeAndNil(NativeImageList);
1373 inherited;
1374end;
1375
1376initialization
1377
1378Mouse := TMouse.Create;
1379
1380finalization;
1381
1382FreeAndNil(Mouse);
1383
1384end.
1385
Note: See TracBrowser for help on using the repository browser.