1 unit customdrawnproc;
2
3 {$mode objfpc}{$H+}
4 {$include customdrawndefines.inc}
5
6 interface
7
8 uses
9 // rtl+ftl
10 Types, Classes, SysUtils,
11 fpimage, fpcanvas, Math,
12 // LazUtils
13 LazFileUtils,
14 {$ifndef CD_UseNativeText}
15 // LazFreeType
16 TTTypes, LazFreeTypeIntfDrawer, LazFreeType, EasyLazFreeType, IniFiles,
17 {$endif}
18 // Custom Drawn Canvas
19 IntfGraphics, lazcanvas, lazregions, customdrawndrawers, customdrawncontrols,
20 // LCL
21 GraphType, Controls, LCLMessageGlue, WSControls, LCLType, LCLProc,
22 StdCtrls, ExtCtrls, Forms, Graphics, ComCtrls,
23 InterfaceBase, LCLIntf;
24
25 type
26 { TCDBaseControl }
27
28 TCDBaseControl = class
29 private
30 FProps: TStringList;
GetPropsnull31 function GetProps(AnIndex: String): pointer;
32 procedure SetProps(AnIndex: String; AValue: pointer);
33 protected
34 FWinControl: TWinControl;
35 public
36 Children: TFPList; // of TCDWinControl;
37 // For scrolling a control
38 // The initial values are x=0, y=0 After scrolling downwards (by dragging upwards)
39 // it will be for example x=0, y=+27
40 ScrollX, ScrollY: Integer;
41 LastMousePos: TPoint;
42 IsScrolling: Boolean;
43 // Counter to keep track of when we requested Invalidate
44 // Some systems like X11 and Win32 will keep sending unnecessary paint messages
45 // so for them we just throw the previously painted image
46 InvalidateCount: Integer;
47 // painting objects
48 ControlImage: TLazIntfImage;
49 ControlCanvas: TLazCanvas;
50 constructor Create; virtual;
51 destructor Destroy; override;
52 procedure IncInvalidateCount;
AdjustCoordinatesForScrollingnull53 function AdjustCoordinatesForScrolling(AX, AY: Integer): TPoint;
54 procedure UpdateImageAndCanvas; virtual;
IsControlBackgroundVisiblenull55 function IsControlBackgroundVisible: Boolean; virtual;
GetWinControlnull56 function GetWinControl: TWinControl; virtual;
57 property Props[AnIndex:String]:pointer read GetProps write SetProps;
58 end;
59
60 { TCDWinControl }
61
62 TCDWinControl = class(TCDBaseControl)
63 public
64 Region: TLazRegionWithChilds;
65 WinControl: TWinControl;
66 CDControl: TCDControl;
67 CDControlInjected: Boolean;
68 procedure UpdateImageAndCanvas; override;
IsControlBackgroundVisiblenull69 function IsControlBackgroundVisible: Boolean; override;
GetWinControlnull70 function GetWinControl: TWinControl; override;
71 end;
72
73 { TCDForm }
74
75 TCDForm = class(TCDBaseControl)
76 public
77 LCLForm: TCustomForm;
78 NativeHandle: HWND;
79 //
80 LastMouseDownControl: TWinControl; // Stores the control which should receive the next MouseUp
81 FocusedControl: TWinControl; // The control focused in the form
82 FocusedIntfControl: TWinControl; // The intf control focused in the form
83 LayoutAutoAdjusted: Boolean; // Indicates if the form layout was already auto-adjusted once
84 // For merging invalidate requests, currently utilized in X11
85 InvalidateRequestedInAnyControl: Boolean;
86 // painting objects which represent the composed form image, don't confuse with ControlImage/ControlCanvas
87 Image: TLazIntfImage;
88 Canvas: TLazCanvas;
89 constructor Create; virtual;
90 function GetFocusedControl: TWinControl;
91 function GetFormVirtualHeight(AScreenHeight: Integer): Integer;
92 procedure SanityCheckScrollPos();
93 procedure UpdateImageAndCanvas; override;
94 function IsControlBackgroundVisible: Boolean; override;
95 function GetWinControl: TWinControl; override;
96 end;
97
98 TCDNonNativeForm = class(TCDForm)
99 public
100 Visible: Boolean;
101 end;
102
103 { TCDBitmap }
104
105 TCDBitmap = class
106 public
107 Image: TLazIntfImage;
108 destructor Destroy; override;
109 end;
110
111 TCDTimer = class
112 public
113 NativeHandle: PtrInt; // The X11 timer uses this to store the current time which is summed up to the next interval
114 NativeGlobalReference: PtrInt; // Utilized in Android to store the global JNI reference
115 Interval: integer;
116 TimerFunc: TWSTimerProc;
117 end;
118
119 // Routines for form managing (both native and non-native)
120
121 procedure AddCDWinControlToForm(const AForm: TCustomForm; ACDWinControl: TCDWinControl);
122 function GetCDWinControlList(const AForm: TCustomForm): TFPList;
123
124 // Routines for non-native form managing
125 procedure InitNonNativeForms();
126 function GetCurrentForm(): TCDNonNativeForm;
127 function GetForm(AIndex: Integer): TCDNonNativeForm;
128 function GetFormCount(): Integer;
129 function AddNewForm(AForm: TCustomForm): TCDNonNativeForm;
130 procedure AddFormWithCDHandle(AHandle: TCDForm);
131 function FindFormWithNativeHandle(AHandle: HWND): TCDForm;
132 procedure ShowForm(ACDForm: TCDNonNativeForm);
133 procedure HideForm(ACDForm: TCDNonNativeForm);
134 procedure BringFormToFront(ACDForm: TCDNonNativeForm);
135 procedure SendFormToBack(ACDForm: TCDNonNativeForm);
136 function FindTopMostVisibleForm: TCDNonNativeForm;
137
138 // Routines for non-native wincontrol
139
140 procedure UpdateControlLazImageAndCanvas(var AImage: TLazIntfImage;
141 var ACanvas: TLazCanvas; AWidth, AHeight: Integer; AFormat: TLazCanvasImageFormat;
142 AData: Pointer = nil; AForceUpdate: Boolean = False;
143 AFreeImageOnUpdate: Boolean = True; ADataOwner: Boolean = True);
144 procedure DrawFormBackground(var AImage: TLazIntfImage; var ACanvas: TLazCanvas; AForm: TCustomForm);
145 procedure RenderChildWinControls(var AImage: TLazIntfImage;
146 var ACanvas: TLazCanvas; ACDControlsList: TFPList; ACDForm: TCDForm);
147 function RenderWinControl(var AImage: TLazIntfImage;
148 var ACanvas: TLazCanvas; ACDWinControl: TCDWinControl; ACDForm: TCDForm): Boolean;
149 procedure RenderWinControlAndChildren(var AImage: TLazIntfImage;
150 var ACanvas: TLazCanvas; ACDWinControl: TCDWinControl; ACDForm: TCDForm);
151 procedure RenderForm(var AImage: TLazIntfImage;
152 var ACanvas: TLazCanvas; AForm: TCustomForm);
153 function FindControlWhichReceivedEvent(AForm: TCustomForm;
154 AControlsList: TFPList; AX, AY: Integer): TWinControl;
155 function FindControlPositionRelativeToTheForm(ALCLControl: TWinControl; AConsiderScrolling: Boolean = False): TPoint;
156 function FormPosToControlPos(ALCLControl: TWinControl; AX, AY: Integer): TPoint;
157
158 // Other routines
159
160 function DateTimeToMilliseconds(aDateTime: TDateTime): Int64;
161 function IsValidDC(ADC: HDC): Boolean;
162 function IsValidGDIObject(AGDIObj: HGDIOBJ): Boolean;
163 function IsValidBitmap(ABitmap: HBITMAP): Boolean;
164 function RemoveAccelChars(AStr: string): string;
165
166 // Timers list management (for platforms that need it)
167
168 procedure InitTimersList();
169 procedure AddTimer(ATimer: TCDTimer);
170 function GetTimer(AIndex: Integer): TCDTimer;
171 function GetTimerCount(): Integer;
172 function GetSmallestTimerInterval(): Integer;
173 procedure RemoveTimer(ATimer: TCDTimer);
174 function FindTimerWithNativeHandle(ANativeHandle: PtrInt): TCDTimer;
175
176 // Font choosing routines
177
178 {$ifndef CD_UseNativeText}
179 procedure VerifyAndCleanUpFontDirectories(AFontDirectories: TStringList);
180 procedure FontsScanForTTF(APath: string; var AFontTable: THashedStringList);
181 procedure FontsScanDir(APath: string; var AFontPaths: TStringList; var AFontList: THashedStringList);
182 {$endif}
183
184 implementation
185
186 uses customdrawnint;
187
188 var
189 // List with the Z-order of non-native forms, index=0 is the bottom-most form
190 NonNativeForms: TFPList = nil;
191 lCurrentForm: TCDNonNativeForm = nil;
192
193 // List of timers
194 TimersList: TFPList = nil;
195
196 procedure AddCDWinControlToForm(const AForm: TCustomForm; ACDWinControl: TCDWinControl);
197 var
198 lWindowInfo: TCDForm;
199 begin
200 lWindowInfo := TCDForm(AForm.Handle);
201 if lWindowInfo.Children = nil then lWindowInfo.Children := TFPList.Create;
202 lWindowInfo.Children.Add(ACDWinControl);
203 end;
204
205 function GetCDWinControlList(const AForm: TCustomForm): TFPList;
206 var
207 lWindowInfo: TCDForm;
208 begin
209 lWindowInfo := TCDForm(AForm.Handle);
210 if lWindowInfo.Children = nil then lWindowInfo.Children := TFPList.Create;
211 Result := lWindowInfo.Children;
212 end;
213
214 procedure InitNonNativeForms();
215 begin
216 if NonNativeForms <> nil then Exit;
217 NonNativeForms := TFPList.Create;
218 end;
219
220 function GetCurrentForm(): TCDNonNativeForm;
221 begin
222 {$IFDEF VerboseCDForms}
223 DebugLn('GetCurrentForm');
224 {$ENDIF}
225 Result := lCurrentForm;
226 end;
227
228 function GetForm(AIndex: Integer): TCDNonNativeForm;
229 begin
230 InitNonNativeForms();
231 Result := TCDNonNativeForm(NonNativeForms.Items[AIndex]);
232 end;
233
234 function GetFormCount: Integer;
235 begin
236 InitNonNativeForms();
237 Result := NonNativeForms.Count;
238 end;
239
240 function AddNewForm(AForm: TCustomForm): TCDNonNativeForm;
241 var
242 lFormInfo: TCDNonNativeForm;
243 begin
244 {$IFDEF VerboseCDForms}
245 DebugLn('AddNewForm');
246 {$ENDIF}
247 lFormInfo := TCDNonNativeForm.Create;
248 lFormInfo.LCLForm := AForm;
249 AddFormWithCDHandle(lFormInfo);
250 Result := lFormInfo;
251 end;
252
253 procedure AddFormWithCDHandle(AHandle: TCDForm);
254 begin
255 InitNonNativeForms();
256 NonNativeForms.Insert(0, AHandle);
257 end;
258
259 function FindFormWithNativeHandle(AHandle: HWND): TCDForm;
260 var
261 lCDForm: TCDForm;
262 i: Integer;
263 begin
264 Result := nil;
265 InitNonNativeForms();
266 for i := 0 to NonNativeForms.Count - 1 do
267 begin
268 lCDForm := TCDForm(NonNativeForms.Items[i]);
269 if lCDForm.NativeHandle = AHandle then
270 begin
271 Result := lCDForm;
272 Exit;
273 end;
274 end;
275 end;
276
277 procedure ShowForm(ACDForm: TCDNonNativeForm);
278 begin
279 {$IFDEF VerboseCDForms}
280 DebugLn(Format('ShowForm LCLForm=%s:%s', [ACDForm.LCLForm.Name, ACDForm.LCLForm.ClassName]));
281 {$ENDIF}
282 ACDForm.Visible := True;
283 BringFormToFront(ACDForm);
284 lCurrentForm := ACDForm;
285 end;
286
287 procedure HideForm(ACDForm: TCDNonNativeForm);
288 begin
289 ACDForm.Visible := False;
290 // update the Current Form if required, and invalidate too
291 if lCurrentForm = ACDForm then
292 begin
293 lCurrentForm := FindTopMostVisibleForm();
294 LCLIntf.InvalidateRect(HWND(lCurrentForm), nil, True);
295 end;
296 // Warn the LCL that the form was hidden
297 LCLSendCloseQueryMsg(ACDForm.LCLForm);
298 end;
299
300 procedure BringFormToFront(ACDForm: TCDNonNativeForm);
301 var
302 lCount, lCurIndex: Integer;
303 begin
304 InitNonNativeForms();
305 lCount := NonNativeForms.Count;
306 lCurIndex := NonNativeForms.IndexOf(ACDForm);
307 {$IFDEF VerboseCDForms}
308 DebugLn(Format('BringFormToFront lOldIndex=%d lNewIndex=%d', [lCurIndex, lCount-1]));
309 {$ENDIF}
310 NonNativeForms.Move(lCurIndex, lCount-1);
311 end;
312
313 procedure SendFormToBack(ACDForm: TCDNonNativeForm);
314 var
315 lCount, lCurIndex: Integer;
316 begin
317 // Hide the form
318 ACDForm.Visible := False;
319
320 InitNonNativeForms();
321 lCount := NonNativeForms.Count;
322 lCurIndex := NonNativeForms.IndexOf(ACDForm);
323 {$IFDEF VerboseCDForms}
324 DebugLn(Format('SendFormToBack lOldIndex=%d lNewIndex=0', [lCurIndex]));
325 {$ENDIF}
326 NonNativeForms.Move(lCurIndex, 0);
327 end;
328
329 function FindTopMostVisibleForm: TCDNonNativeForm;
330 var
331 lCount: Integer;
332 lForm: TCDNonNativeForm;
333 i: Integer;
334 begin
335 Result := nil;
336 InitNonNativeForms();
337 // Iterate starting from Count to zero until we find a visible form
338 lCount := NonNativeForms.Count;
339
340 for i := lCount-1 downto 0 do
341 begin
342 lForm := TCDNonNativeForm(NonNativeForms.Items[i]);
343 if lForm.Visible then
344 begin
345 Result := lForm;
346 Break;
347 end;
348 end;
349 {$IFDEF VerboseCDForms}
350 DebugLn(Format('FindTopMostVisibleForm FoundIndex=%d FoundForm=%s:%s',
351 [i, Result.LCLForm.Name, Result.LCLForm.ClassName]));
352 {$ENDIF}
353 end;
354
355 // If AForceUpdate=True then it will update even if the width and height remain the same
356 procedure UpdateControlLazImageAndCanvas(var AImage: TLazIntfImage;
357 var ACanvas: TLazCanvas; AWidth, AHeight: Integer; AFormat: TLazCanvasImageFormat;
358 AData: Pointer = nil; AForceUpdate: Boolean = False;
359 AFreeImageOnUpdate: Boolean = True; ADataOwner: Boolean = True);
360 var
361 lRawImage: TRawImage;
362 lPixelSize: Byte;
363 begin
364 {$IFDEF VerboseCDLazCanvas}
365 DebugLn(Format(':>[UpdateControlLazImageAndCanvas] Input Image: %x Canvas: %x',
366 [PtrInt(AImage), PtrInt(ACanvas)]));
367 {$ENDIF}
368 // Check if the image needs update
369 if (AImage = nil) or (AWidth <> AImage.Width) or (AHeight <> AImage.Height)
370 or AForceUpdate then
371 begin
372 if (AImage <> nil) and AFreeImageOnUpdate then AImage.Free;
373 // Free the canvas and create a new one if it is a dummy Canvas created for text metrics reading by GetDC(control)
374 if (ACanvas <> nil) and ACanvas.HasNoImage then
375 begin
376 ACanvas.Free;
377 ACanvas := nil;
378 end;
379
380 lRawImage.Init;
381 case AFormat of
382 clfRGB16_R5G6B5: lRawImage.Description.Init_BPP16_R5G6B5(AWidth, AHeight);
383 clfRGB24: lRawImage.Description.Init_BPP24_R8G8B8_BIO_TTB(AWidth, AHeight);
384 clfRGB24UpsideDown: lRawImage.Description.Init_BPP24_R8G8B8_BIO_TTB_UpsideDown(AWidth, AHeight);
385 clfBGR24: lRawImage.Description.Init_BPP24_B8G8R8_BIO_TTB(AWidth, AHeight);
386 clfBGRA32: lRawImage.Description.Init_BPP32_B8G8R8A8_BIO_TTB(AWidth, AHeight);
387 clfRGBA32: lRawImage.Description.Init_BPP32_R8G8B8A8_BIO_TTB(AWidth, AHeight);
388 clfARGB32: lRawImage.Description.Init_BPP32_A8R8G8B8_BIO_TTB(AWidth, AHeight);
389 end;
390
391 // Now connect the pixel buffer or create one
392 if AData = nil then lRawImage.CreateData(True)
393 else
394 begin
395 case AFormat of
396 clfRGB16_R5G6B5:
397 lPixelSize := 2;
398 clfRGB24, clfRGB24UpsideDown, clfBGR24:
399 lPixelSize := 3;
400 clfBGRA32, clfRGBA32, clfARGB32:
401 lPixelSize := 4;
402 end;
403
404 lRawImage.Data := AData;
405 lRawImage.DataSize := AWidth * lPixelSize * AHeight;
406 end;
407
408 AImage := TLazIntfImage.Create(AWidth, AHeight);
409 AImage.SetRawImage(lRawImage, ADataOwner);
410
411 if (ACanvas <> nil) then ACanvas.Free;
412 ACanvas := TLazCanvas.Create(AImage);
413 ACanvas.ImageFormat := AFormat;
414 end;
415 {$IFDEF VerboseCDLazCanvas}
416 DebugLn(Format(':<[UpdateControlLazImageAndCanvas] Output Image: %x Canvas: %x',
417 [PtrInt(AImage), PtrInt(ACanvas)]));
418 {$ENDIF}
419 end;
420
421 procedure DrawFormBackground(var AImage: TLazIntfImage; var ACanvas: TLazCanvas; AForm: TCustomForm);
422 var
423 lColor: TColor;
424 begin
425 ACanvas.SaveState;
426 ACanvas.ResetCanvasState;
427 lColor := AForm.Color;
428 if (lColor <> clForm) and (lColor <> clDefault) then
429 lColor := ColorToRGB(lColor)
430 else
431 lColor := ColorToRGB(clForm);
432 ACanvas.Brush.FPColor := TColorToFPColor(lColor);
433 ACanvas.Pen.FPColor := TColorToFPColor(lColor);
434 ACanvas.Rectangle(0, 0, AImage.Width, AImage.Height);
435 ACanvas.RestoreState(-1);
436 end;
437
438 // This does not render the win control itself, only it's children
439 // The WinControls themselves will render child TControls not descending from TWinControl
440 procedure RenderChildWinControls(var AImage: TLazIntfImage;
441 var ACanvas: TLazCanvas; ACDControlsList: TFPList; ACDForm: TCDForm);
442 var
443 i, lChildrenCount: Integer;
444 lCDWinControl: TCDWinControl;
445 begin
446 lChildrenCount := ACDControlsList.Count;
447 {$ifdef VerboseCDWinControl}
448 DebugLn(Format('[RenderChildWinControls] ACanvas=%x ACDControlsList=%x lChildrenCount=%d',
449 [PtrInt(ACanvas), PtrInt(ACDControlsList), lChildrenCount]));
450 {$endif}
451
452 for i := 0 to lChildrenCount-1 do
453 begin
454 {$ifdef VerboseCDWinControl}
455 DebugLn(Format('[RenderChildWinControls] i=%d', [i]));
456 {$endif}
457
458 lCDWinControl := TCDWinControl(ACDControlsList.Items[i]);
459
460 RenderWinControlAndChildren(AImage, ACanvas, lCDWinControl, ACDForm);
461 end;
462 end;
463
464 // Renders a WinControl, but not it's children
465 // Returns if the control is visible and therefore if its children should be rendered
466 function RenderWinControl(var AImage: TLazIntfImage; var ACanvas: TLazCanvas;
467 ACDWinControl: TCDWinControl; ACDForm: TCDForm): Boolean;
468 var
469 lWinControl, lParentControl: TWinControl;
470 struct : TPaintStruct;
471 lCanvas: TCanvas;
472 lControlCanvas: TLazCanvas;
473 lBaseWindowOrg: TPoint;
474 lControlStateEx: TCDControlStateEx;
475 lDrawControl: Boolean;
476 lRegion:TLazRegionWithChilds;
477 begin
478 Result := False;
479
480 lWinControl := ACDWinControl.WinControl;
481
482 {$ifdef VerboseCDWinControl}
483 DebugLn(Format('[RenderWinControl] lWinControl=%x Name=%s:%s Left=%d'
484 + ' Top=%d Width=%d Height=%d', [PtrInt(lWinControl), lWinControl.Name, lWinControl.ClassName,
485 lWinControl.Left, lWinControl.Top, lWinControl.Width, lWinControl.Height]));
486 {$endif}
487
488 if lWinControl.Visible = False then Exit;
489
490 // Disable the drawing itself, but keep the window org and region operations
491 // or else clicking and other things are broken
492 lDrawControl := ACDWinControl.IsControlBackgroundVisible();
493
494 // Save the Canvas state
495 ACanvas.SaveState;
496 ACanvas.ResetCanvasState;
497
498 // lBaseWindowOrg makes debugging easier
499 // Iterate to find the appropriate BaseWindowOrg relative to the parent control
500 lBaseWindowOrg := FindControlPositionRelativeToTheForm(lWinControl);
501 ACanvas.BaseWindowOrg := Point(lBaseWindowOrg.X, lBaseWindowOrg.Y - ACDForm.ScrollY);
502 ACanvas.WindowOrg := Point(0, 0);
503
504 // Prepare the clippping relative to the form
505 ACanvas.Clipping := True;
506 ACDWinControl.Region.Rect := Bounds(lBaseWindowOrg.X, lBaseWindowOrg.Y - ACDForm.ScrollY,
507 lWinControl.Width, lWinControl.Height);
508 lRegion := TLazRegionWithChilds.Create;
509 lRegion.Assign(ACDWinControl.Region);
510 ACanvas.ClipRegion := lRegion;
511
512 lControlCanvas := ACanvas;
513
514 if (ACDWinControl.InvalidateCount > 0) and lDrawControl then
515 begin
516 ACDWinControl.UpdateImageAndCanvas();
517 lControlCanvas := ACDWinControl.ControlCanvas;
518 ACDWinControl.InvalidateCount := 0;
519
520 // Special drawing for some native controls
521 if (lWinControl is TCustomPanel) or (lWinControl is TTabSheet)
522 or (lWinControl is TCustomPage) or (lWinControl is TNotebook) then
523 begin
524 // Erase the background of TPanel controls, since it can draw it's own border, but fails to draw it's own background
525 // and also erase the background for TTabSheet (children of TPageControl) and TCustomPage (children of TNotebook)
526 lControlCanvas.SaveState;
527 lControlCanvas.Brush.FPColor := TColorToFPColor(lWinControl.GetRGBColorResolvingParent());
528 lControlCanvas.Pen.FPColor := lControlCanvas.Brush.FPColor;
529 lControlCanvas.Rectangle(Bounds(0, 0, lWinControl.Width, lWinControl.Height));
530 lControlCanvas.RestoreState(-1);
531 end
532 else if lWinControl is TCustomGroupBox then
533 begin
534 lControlCanvas.SaveState;
535 lControlStateEx := TCDControlStateEx.Create;
536 try
537 lControlStateEx.Font := lWinControl.Font;
538 lControlStateEx.Caption := lWinControl.Caption;
539 lControlStateEx.ParentRGBColor := lWinControl.GetRGBColorResolvingParent();
540 GetDefaultDrawer().DrawGroupBox(lControlCanvas, Point(0,0),
541 Size(lWinControl.Width, lWinControl.Height), [], lControlStateEx);
542 finally
543 lControlStateEx.Free;
544 lControlCanvas.RestoreState(-1);
545 end;
546 end;
547
548 // Send the drawing message
549 {$ifdef VerboseCDWinControl}
550 DebugLn('[RenderWinControl] before LCLSendPaintMsg');
551 {$endif}
552 FillChar(struct, SizeOf(TPaintStruct), 0);
553 struct.hdc := HDC(lControlCanvas);
554 LCLSendEraseBackgroundMsg(lWinControl, struct.hdc);
555 LCLSendPaintMsg(lWinControl, struct.hdc, @struct);
556 {$ifdef VerboseCDWinControl}
557 DebugLn('[RenderWinControl] after LCLSendPaintMsg');
558 {$endif}
559 end;
560
561 // Here we actually blit the control to the form canvas
562 if lDrawControl then
563 ACanvas.CanvasCopyRect(ACDWinControl.ControlCanvas, 0, 0, 0, 0,
564 lWinControl.Width, lWinControl.Height);
565
566 // Now restore it
567 ACanvas.RestoreState(-1);
568
569 Result := True;
570 end;
571
572 // Render a WinControl and all it's children
573 procedure RenderWinControlAndChildren(var AImage: TLazIntfImage;
574 var ACanvas: TLazCanvas; ACDWinControl: TCDWinControl; ACDForm: TCDForm);
575 begin
576 if not RenderWinControl(AImage, ACanvas, ACDWinControl, ACDForm) then Exit;
577
578 // Now Draw all sub-controls
579 if ACDWinControl.Children <> nil then
580 RenderChildWinControls(AImage, ACanvas, ACDWinControl.Children, ACDForm);
581 end;
582
583 // Draws a form and all of its child controls
584 procedure RenderForm(var AImage: TLazIntfImage; var ACanvas: TLazCanvas;
585 AForm: TCustomForm);
586 var
587 struct : TPaintStruct;
588 lWindowHandle: TCDForm;
589 lFormCanvas: TLazCanvas;
590 lDrawControl: Boolean;
591 begin
592 lWindowHandle := TCDForm(AForm.Handle);
593
594 // Disable the drawing itself, but keep the window org and region operations
595 // or else clicking and other things are broken, specially in Android
596 //
597 // If the form is smaller then the buffer (this might happen in Android)
598 // then we need to force drawing the background to erase old contents of the buffer
599 //
600 // Consider also if the user wants to manually disable the background drawing
601 lDrawControl := lWindowHandle.IsControlBackgroundVisible() or (AForm.Height < AImage.Height);
602 if Assigned(CDWidgetset.DisableFormBackgroundDrawingProc) then
603 begin
604 if not CDWidgetset.DisableFormBackgroundDrawingProc(AForm) then
605 if lDrawControl then
606 DrawFormBackground(AImage, ACanvas, AForm);
607 end
608 else if lDrawControl then
609 DrawFormBackground(AImage, ACanvas, AForm);
610
611 // Consider the form scrolling
612 // ToDo: Figure out why this "div 2" factor is necessary for drawing non-windows controls and remove this factor
613 // If you remove this factor then the wincontrols are fine,
614 // but graphiccontrols scroll with a different speed which is a huge problem
615 ACanvas.BaseWindowOrg := Point(0, - lWindowHandle.ScrollY div 2);
616 ACanvas.WindowOrg := Point(0, 0);
617
618 lFormCanvas := ACanvas;
619
620 if lDrawControl then
621 begin
622 // Send the paint message to the LCL
623 {$IFDEF VerboseCDForms}
624 DebugLn(Format('[RenderForm] OnPaint event started context: %x', [struct.hdc]));
625 {$ENDIF}
626 FillChar(struct, SizeOf(TPaintStruct), 0);
627 struct.hdc := HDC(lFormCanvas);
628 LCLSendPaintMsg(AForm, struct.hdc, @struct);
629 {$IFDEF VerboseCDForms}
630 DebugLn('[RenderForm] OnPaint event ended');
631 {$ENDIF}
632 end;
633
634 // Now paint all child win controls
635 RenderChildWinControls(AImage, ACanvas, GetCDWinControlList(AForm), lWindowHandle);
636 end;
637
FindControlWhichReceivedEventnull638 function FindControlWhichReceivedEvent(AForm: TCustomForm;
639 AControlsList: TFPList; AX, AY: Integer): TWinControl;
640 var
641 i: Integer;
642 lRegionOfEvent: TLazRegionWithChilds;
643 lCurCDControl: TCDWinControl;
644 lEventPos: TPoint; // local, already adjusted for the scrolling
645 begin
646 Result := AForm;
647 lEventPos := Point(AX, AY); // Don't adjust for the scrolling because the regions are scrolled too
648
649 // The order of this loop is important to respect the Z-order of controls
650 for i := AControlsList.Count-1 downto 0 do
651 begin
652 lCurCDControl := TCDWinControl(AControlsList.Items[i]);
653 if lCurCDControl.Region = nil then Continue;
654 if not lCurCDControl.WinControl.HandleObjectShouldBeVisible then Continue;
655 lRegionOfEvent := lCurCDControl.Region.IsPointInRegion(lEventPos.X, lEventPos.Y);
656 if lRegionOfEvent <> nil then
657 begin
658 if lRegionOfEvent.UserData = nil then
659 raise Exception.Create('[FindControlWhichReceivedEvent] Malformed tree of regions');
660 Result := TWinControl(lRegionOfEvent.UserData);
661
662 // If it is a native LCL control, redirect to the CDControl
663 if lCurCDControl.CDControl <> nil then
664 Result := lCurCDControl.CDControl;
665
666 Exit;
667 end;
668 end;
669 end;
670
671 function FindControlPositionRelativeToTheForm(ALCLControl: TWinControl; AConsiderScrolling: Boolean = False): TPoint;
672 var
673 lParentControl: TWinControl;
674 lParentHandle: TCDBaseControl;
675 lScroll, lParentPos: TPoint;
676 begin
677 // Iterate to find the appropriate BaseWindowOrg relative to the parent control
678 Result := Point(ALCLControl.Left, ALCLControl.Top);
679 lParentControl := ALCLControl.Parent;
680 while (lParentControl <> nil) do
681 begin
682 if AConsiderScrolling and lParentControl.HandleAllocated then
683 begin
684 lParentHandle := TCDBaseControl(lParentControl.Handle);
685 lScroll := Point(lParentHandle.ScrollX, lParentHandle.ScrollY);
686 end
687 else lScroll := Point(0, 0);
688
689 if (lParentControl is TCustomForm) then lParentPos := Point(0, 0)
690 else lParentPos := Point(lParentControl.Left, lParentControl.Top);
691
692 Result.X := Result.X + lParentPos.X - lScroll.X;
693 Result.Y := Result.Y + lParentPos.Y - lScroll.Y;
694 lParentControl := lParentControl.Parent;
695 end;
696 end;
697
698 function FormPosToControlPos(ALCLControl: TWinControl; AX, AY: Integer): TPoint;
699 var
700 lControlPos: TPoint;
701 begin
702 lControlPos := FindControlPositionRelativeToTheForm(ALCLControl, True);
703 Result.X := AX - lControlPos.X;
704 Result.Y := AY - lControlPos.Y;
705 end;
706
707 function DateTimeToMilliseconds(aDateTime: TDateTime): Int64;
708 var
709 TimeStamp: TTimeStamp;
710 begin
711 {Call DateTimeToTimeStamp to convert DateTime to TimeStamp:}
712 TimeStamp:= DateTimeToTimeStamp (aDateTime);
713 {Multiply and add to complete the conversion:}
714 Result:= TimeStamp.Time;
715 end;
716
717 function IsValidDC(ADC: HDC): Boolean;
718 begin
719 Result := ADC <> 0;
720 end;
721
722 function IsValidGDIObject(AGDIObj: HGDIOBJ): Boolean;
723 begin
724 Result := AGDIObj <> 0;
725 end;
726
727 function IsValidBitmap(ABitmap: HBITMAP): Boolean;
728 begin
729 Result := ABitmap <> 0;
730 end;
731
732 function RemoveAccelChars(AStr: string): string;
733 begin
734 // ToDo convert && to & and keep it
735 Result := StringReplace(AStr, '&', '', [rfReplaceAll]);
736 end;
737
738 procedure InitTimersList;
739 begin
740 if TimersList = nil then TimersList := TFPList.Create;
741 end;
742
743 procedure AddTimer(ATimer: TCDTimer);
744 begin
745 InitTimersList();
746 TimersList.Add(ATimer);
747 end;
748
749 function GetTimer(AIndex: Integer): TCDTimer;
750 begin
751 InitTimersList();
752 Result := TCDTimer(TimersList.Items[AIndex]);
753 end;
754
755 function GetTimerCount: Integer;
756 begin
757 InitTimersList();
758 Result := TimersList.Count;
759 end;
760
761 function GetSmallestTimerInterval: Integer;
762 var
763 i: Integer;
764 lTimer: TCDTimer;
765 begin
766 Result := High(Integer);
767 for i := 0 to GetTimerCount()-1 do
768 begin
769 lTimer := GetTimer(i);
770 Result := Min(Result, lTimer.Interval);
771 end;
772 if Result = High(Integer) then Result := -1;
773 end;
774
775 procedure RemoveTimer(ATimer: TCDTimer);
776 begin
777 InitTimersList();
778 TimersList.Remove(ATimer);
779 end;
780
781 function FindTimerWithNativeHandle(ANativeHandle: PtrInt): TCDTimer;
782 var
783 lTimer: TCDTimer;
784 i: Integer;
785 begin
786 Result := nil;
787 InitTimersList();
788 for i := 0 to TimersList.Count - 1 do
789 begin
790 lTimer := TCDTimer(TimersList.Items[i]);
791 if lTimer.NativeHandle = ANativeHandle then
792 Exit(lTimer);
793 end;
794 end;
795
796 {$ifndef CD_UseNativeText}
797 procedure VerifyAndCleanUpFontDirectories(AFontDirectories: TStringList);
798 var
799 i, j: Integer;
800 begin
801 // Add path delimitiers to the end of all paths
802 for i := 0 to AFontDirectories.Count -1 do
803 begin
804 AFontDirectories.Strings[i] := IncludeTrailingPathDelimiter(AFontDirectories.Strings[i]);
805 end;
806
807 // remove all duplicates
808 i := 0;
809 while i < AFontDirectories.Count do
810 begin
811 j := i+1;
812 while j < AFontDirectories.Count do
813 begin
814 if AFontDirectories.Strings[i] = AFontDirectories.Strings[j] then
815 AFontDirectories.Delete(j);
816 Inc(j);
817 end;
818 Inc(i);
819 end;
820
821 // Now remove all directories which don't exist
822 i := 0;
823 while i < AFontDirectories.Count do
824 begin
825 if not DirectoryExistsUTF8(AFontDirectories.Strings[i]) then
826 AFontDirectories.Delete(i);
827 Inc(i);
828 end;
829
830 // Raise an exception if there are no font directories
831 if AFontDirectories.Count = 0 then
832 raise Exception.Create('[VerifyAndCleanUpFontDirectories] After cleaning up no font directories were found.');
833 end;
834
835 {------------------------------------------------------------------------------
836 Procedure: BackendScanForTTF - Scope=local
837 Params: APath - path for a font directory
838 AFontTable - Font name to Font path Hashed List
839
840 Scan a directory for ttf fonts and updates the FontTable
841 ------------------------------------------------------------------------------}
842 procedure FontsScanForTTF(APath: string; var AFontTable: THashedStringList);
843 var
844 Rslt: TSearchRec;
845 AFace: TT_Face;
846 ErrNum: TT_Error;
847 SearchResult, J: Integer;
848 FontPath: String;
849 NameCount: Integer;
850 NameString: Pchar;
851 NameLen: Integer;
852 Platform,Encoding,Language: Integer;
853 NameID: Integer;
854 AName: String;
855 {$ifdef CD_Debug_TTF}
856 DebugList: TstringList;
857 {$endif}
858 begin
859 SearchResult := FindFirstUTF8(APath+'*.ttf', faAnyFile, Rslt);
860 {$ifdef CD_Debug_TTF}
861 DebugList:= TStringList.Create;
862 {$endif}
863 while SearchResult = 0 do
864 begin
865 FontPath:= APath+Rslt.Name;
866
867 {$ifdef CD_Debug_TTF}
868 DebugLn(Format('[FontsScanForTTF] font=%s', [FontPath]));
869 {$endif}
870
871 // Work around for fonts which cause errors. See bug 21456
872 if Rslt.Name = 'tunga.ttf' then
873 begin
874 SearchResult := FindNextUTF8(Rslt);
875 Continue;
876 end;
877
878 ErrNum:= TT_Open_Face(FontPath, AFace);
879 if ErrNum = TT_Err_Ok then
880 begin
881 NameCount:= TT_Get_Name_Count(AFace);
882 for J:= 0 to NameCount-1 do
883 begin
884 ErrNum:= TT_Get_Name_ID(AFace, J, Platform, Encoding, Language, NameID);
885 { -------------------------------------------------------------------
886 NameID: 0= Copyright
887 1= Font Family (e.g. Arial, Times, Liberation )
888 2= Font Subfamily (e.g. Bold, Italic, Condensed)
889 3= Unique Font Identifier
890 4= Full Name - Human readable - the one used by the IDE
891 -----------------------------------------------------------------------}
892 {$ifdef CD_Debug_TTF}
893 if ErrNum = TT_Err_Ok then
894 begin
895 ErrNum:= TT_Get_Name_String(AFace,J,NameString,NameLen);
896 AName:= NameString;
897 if NameString <> '' then //DBG
898 begin
899 SetLength(AName,NameLen);
900 DebugList.Add('ID='+IntToStr(NameID)+' Path='+FontPath+' Name='+AName);
901 end
902 else DebugList.Add('ID='+IntToStr(NameID)+' Path='+FontPath+' Name=<Empty String>');
903 end;
904 {$endif}
905 if (ErrNum = TT_Err_Ok) and (NameID = 4) then begin
906 ErrNum:= TT_Get_Name_String(AFace,J,NameString,NameLen);
907 AName:= NameString;
908 // Skip empty entries
909 if NameString <> '' then begin
910 SetLength(AName,NameLen);
911 AFontTable.Add(AName+'='+FontPath);
912 end;
913 end;
914 end;
915 end;
916 {$ifdef CD_Debug_TTF}
917 DebugList.Add('------');
918 {$endif}
919 ErrNum:= TT_Close_Face(AFace);
920 SearchResult := FindNextUTF8(Rslt);
921 end;
922 FindCloseUTF8(Rslt);
923 {$ifdef CD_Debug_TTF}
924 AName:= ExtractFileDir(Apath);
925 AName:= ExtractFileName(AName) + '.txt';
926 DebugList.SaveToFile({$ifdef UNIX}'/tmp/'+{$endif}{$ifdef Windows}'C:\'+{$endif}AName);
927 DebugList.Free;
928 {$endif}
929 end;
930
931 {------------------------------------------------------------------------------
932 Procedure: BackendScanDir - Scope=Local
933 Params: APath - path for a font directory
934 AFontPaths - Font path List
935
936 Recursively scans font directories to find the ones populated only
937 by fonts
938 ------------------------------------------------------------------------------}
939 procedure FontsScanDir(APath: string; var AFontPaths: TStringList; var AFontList: THashedStringList);
940 var
941 NextPath: string;
942 Rslt: TSearchRec;
943 I: Integer;
944 DirFound,DirEmpty: Boolean;
945 TmpList: THashedStringList;
946 begin
947 DirFound:= False;
948 DirEmpty:= True;
949 I:= FindFirstUTF8(APath+'*',faAnyFile,Rslt);
950 while I >= 0 do begin
951 if (Rslt.Name <> '.') and (Rslt.Name <> '..') then
952 begin
953 DirEmpty:= False;
954 if (Rslt.Attr and faDirectory) <> 0 then
955 begin
956 NextPath:= APath + Rslt.Name + PathDelim;
957 DirFound:= true;
958 FontsScanDir(NextPath,AFontPaths,AFontList);
959 end;
960 end;
961 I:= FindNextUTF8(Rslt);
962 end;
963 FindCloseUTF8(Rslt);
964 if (not DirFound) and (not DirEmpty) then
965 AFontPaths.Add(APath);
966 end;
967
968 {$endif}
969
970 { TCDWinControl }
971
972 procedure TCDWinControl.UpdateImageAndCanvas;
973 begin
974 UpdateControlLazImageAndCanvas(ControlImage, ControlCanvas,
975 WinControl.Width, WinControl.Height, {$ifdef CD_Support_Alpha_Controls}clfARGB32{$else}CDWidgetset.ScreenFormat{$endif});
976 end;
977
TCDWinControl.IsControlBackgroundVisiblenull978 function TCDWinControl.IsControlBackgroundVisible: Boolean;
979 begin
980 FWinControl := WinControl;
981 Result:=inherited IsControlBackgroundVisible;
982 end;
983
GetWinControlnull984 function TCDWinControl.GetWinControl: TWinControl;
985 begin
986 Result := WinControl;
987 end;
988
989 { TCDBitmap }
990
991 destructor TCDBitmap.Destroy;
992 begin
993 if Image <> nil then Image.Free;
994 inherited Destroy;
995 end;
996
997 { TCDBaseControl }
998
TCDBaseControl.GetPropsnull999 function TCDBaseControl.GetProps(AnIndex: String): pointer;
1000 var
1001 i: Integer;
1002 begin
1003 i:=Fprops.IndexOf(AnIndex);
1004 if i>=0 then
1005 begin
1006 result:=Fprops.Objects[i];
1007 exit;
1008 end;
1009 result := nil;
1010 end;
1011
GetWinControlnull1012 function TCDBaseControl.GetWinControl: TWinControl;
1013 begin
1014 Result := FWinControl;
1015 end;
1016
1017 procedure TCDBaseControl.SetProps(AnIndex: String; AValue: pointer);
1018 var
1019 i: Integer;
1020 begin
1021 i := Fprops.IndexOf(AnIndex);
1022 if i < 0 then
1023 i := FProps.Add(AnIndex);
1024 Fprops.Objects[i] := TObject(AValue);
1025 end;
1026
1027 constructor TCDBaseControl.Create;
1028 begin
1029 inherited Create;
1030 FProps := TStringList.Create;
1031 //FProps.CaseSensitive:=false; commented as in the qt widgetset
1032 FProps.Sorted:=true;
1033 IncInvalidateCount(); // Always starts needing an invalidate
1034
1035 Children := TFPList.Create;
1036 end;
1037
1038 destructor TCDBaseControl.Destroy;
1039 begin
1040 FProps.Free;
1041 Children.Free;
1042
1043 // Free the Canvas and Image if required
1044 // Dont free for the Form because elsewhere this is taken care of
1045 if ControlCanvas <> nil then ControlCanvas.Free;
1046 if ControlImage <> nil then ControlImage.Free;
1047
1048 inherited Destroy;
1049 end;
1050
1051 procedure TCDBaseControl.IncInvalidateCount;
1052 begin
1053 Inc(InvalidateCount);
1054 end;
1055
TCDBaseControl.AdjustCoordinatesForScrollingnull1056 function TCDBaseControl.AdjustCoordinatesForScrolling(AX, AY: Integer): TPoint;
1057 begin
1058 DebugLn(Format('AX=%d AY=%d ScrollX=%d ScrollY=%d', [AX, AY, ScrollX, ScrollY]));
1059 Result := Point(AX + ScrollX, AY + ScrollY);
1060 end;
1061
1062 procedure TCDBaseControl.UpdateImageAndCanvas;
1063 begin
1064
1065 end;
1066
1067 // This is utilized for optimizing the painting. If we figure out that there is
1068 // nothing visible from a control, just give up drawing it completely
1069 //
1070 // What usually happens is that child controls might completely cover their
1071 // parent controls
1072 //
1073 // We should watch out for alpha-blending, however
IsControlBackgroundVisiblenull1074 function TCDBaseControl.IsControlBackgroundVisible: Boolean;
1075 var
1076 i: Integer;
1077 lChild: TControl;
1078 lWinChild: TWinControl;
1079 begin
1080 Result := True;
1081 if FWinControl = nil then Exit;
1082 for i := 0 to FWinControl.ControlCount-1 do
1083 begin
1084 lChild := FWinControl.Controls[i];
1085 if not (lChild is TWinControl) then Continue;
1086 lWinChild := TWinControl(lChild);
1087
1088 // Ignore invisible controls
1089 if not lWinChild.Visible then Continue;
1090
1091 // ToDo: Ignore alpha blended controls
1092
1093 // Basic case: alClient, but watch out for borders!!!
1094 if (lWinChild.Align = alClient) and
1095 (lWinChild.BorderSpacing.Around = 0) and
1096 (lWinChild.BorderSpacing.Bottom = 0) and
1097 (lWinChild.BorderSpacing.Left = 0) and
1098 (lWinChild.BorderSpacing.Right = 0) and
1099 (lWinChild.BorderSpacing.Top = 0) then Exit(False);
1100
1101 // Another case: coordinates match
1102 if (lWinChild.Left = 0) and (lWinChild.Top = 0) and
1103 (lWinChild.Width = FWinControl.Width) and (lWinChild.Height = FWinControl.Height) then
1104 Exit(False);
1105 end;
1106 end;
1107
1108 { TCDForm }
1109
1110 constructor TCDForm.Create;
1111 begin
1112 inherited Create;
1113 InvalidateCount := 1;
1114 end;
1115
GetFocusedControlnull1116 function TCDForm.GetFocusedControl: TWinControl;
1117 begin
1118 if FocusedIntfControl <> nil then Result := FocusedIntfControl
1119 else if FocusedControl <> nil then Result := FocusedControl
1120 else Result := LCLForm;
1121 end;
1122
TCDForm.GetFormVirtualHeightnull1123 function TCDForm.GetFormVirtualHeight(AScreenHeight: Integer): Integer;
1124 var
1125 i, lControlRequiredHeight: Integer;
1126 lControl: TControl;
1127 begin
1128 Result := AScreenHeight;
1129 for i := 0 to LCLForm.ControlCount-1 do
1130 begin
1131 lControl := LCLForm.Controls[i];
1132 lControlRequiredHeight := lControl.Top + lControl.Height;
1133 Result := Max(lControlRequiredHeight, Result);
1134 end;
1135 end;
1136
1137 procedure TCDForm.SanityCheckScrollPos;
1138 begin
1139 ScrollY := Max(ScrollY, 0);
1140 ScrollY := Min(ScrollY, GetFormVirtualHeight(Image.Height) - Image.Height);
1141 end;
1142
1143 procedure TCDForm.UpdateImageAndCanvas;
1144 begin
1145 UpdateControlLazImageAndCanvas(ControlImage, ControlCanvas,
1146 LCLForm.ClientWIdth, LCLForm.ClientHeight, clfARGB32);
1147 end;
1148
IsControlBackgroundVisiblenull1149 function TCDForm.IsControlBackgroundVisible: Boolean;
1150 begin
1151 FWinControl := LCLForm;
1152 Result:=inherited IsControlBackgroundVisible;
1153 end;
1154
GetWinControlnull1155 function TCDForm.GetWinControl: TWinControl;
1156 begin
1157 Result := LCLForm;
1158 end;
1159
1160 end.
1161
1162