lcl: implement ClientToParent, ParentToClient based on patch of David Jenkins (issue #0021763)

git-svn-id: trunk@36775 -

lcl/controls.pp

@@ -1523,6 +1523,8 @@ type
     function  ClientToScreen(const APoint: TPoint): TPoint;
     function  ScreenToControl(const APoint: TPoint): TPoint;
     function  ControlToScreen(const APoint: TPoint): TPoint;
+    function  ClientToParent(const Point: TPoint; AParent: TWinControl = nil): TPoint;
+    function  ParentToClient(const Point: TPoint; AParent: TWinControl = nil): TPoint;
     function GetChildsRect(Scrolled: boolean): TRect; virtual;
     procedure Show;
     procedure Update; virtual;
@@ -2864,6 +2866,8 @@ begin
     Include(Result, ssAlt);
   if ((GetKeyState(VK_LWIN) and $8000) <> 0) or ((GetKeyState(VK_RWIN) and $8000) <> 0) then
     Include(Result, ssMeta);
+  if (GetKeyState(VK_LWIN) < 0) or (GetKeyState(VK_RWIN) < 0) then 
+    Include(Result, ssMeta);
 end;
 
 {------------------------------------------------------------------------------

lcl/include/control.inc

@@ -1525,6 +1525,24 @@ begin
   Result.Y := APoint.Y + P.Y;
 end;
 
+function TControl.ClientToParent(const Point: TPoint; AParent: TWinControl): TPoint;
+begin
+  if not Assigned(AParent) then
+    AParent := Parent;
+  if not AParent.IsParentOf(Self) then
+    raise EInvalidOperation.CreateFmt(rsControlIsNotAParent, [AParent.Name, Name]);
+  Result := AParent.ScreenToClient(ClientToScreen(Point));
+end;
+
+function TControl.ParentToClient(const Point: TPoint; AParent: TWinControl): TPoint;
+begin
+  if not Assigned(AParent) then
+    AParent := Parent;
+  if not AParent.IsParentOf(Self) then
+    raise EInvalidOperation.CreateFmt(rsControlIsNotAParent, [AParent.Name, Name]);
+  Result := ScreenToClient(AParent.ClientToScreen(Point));
+end;
+
 {------------------------------------------------------------------------------
        TControl.DblClick
 ------------------------------------------------------------------------------}
@@ -4938,20 +4956,19 @@ end;
  ------------------------------------------------------------------------------}
 function TControl.IsParentOf(AControl: TControl): boolean;
 begin
-  Result:=false;
+  Result := False;
-  while AControl<>nil do begin
+  while Assigned(AControl) do
+  begin
     AControl := AControl.Parent;
-    if Self=AControl then begin
+    if Self = AControl then
-      Result:=true;
+      Exit(True);
-      exit;
-    end;
   end;
 end;
 
 function TControl.GetTopParent: TControl;
 begin
   Result := Self;
-  while Result.Parent<>nil do
+  while Assigned(Result.Parent) do
     Result := Result.Parent;
 end;
 

lcl/languages/lclstrconsts.ca.po

@@ -374,6 +374,10 @@ msgstr ""
 msgid "Control '%s' has no parent window"
 msgstr ""
 
+#: lclstrconsts.rscontrolisnotaparent
+msgid "'%s' is not a parent of '%s'"
+msgstr ""
+
 #: lclstrconsts.rscreamcolorcaption
 msgid "Cream"
 msgstr ""

lcl/languages/lclstrconsts.cs.po

@@ -374,6 +374,10 @@ msgstr "Prvek třídy '%s' nemůže mít prvek třídy '%s' jako dítě"
 msgid "Control '%s' has no parent window"
 msgstr "Prvek '%s' nemá rodičovské okno"
 
+#: lclstrconsts.rscontrolisnotaparent
+msgid "'%s' is not a parent of '%s'"
+msgstr ""
+
 #: lclstrconsts.rscreamcolorcaption
 msgid "Cream"
 msgstr "Krémová"

lcl/languages/lclstrconsts.de.po

@@ -376,6 +376,10 @@ msgstr ""
 msgid "Control '%s' has no parent window"
 msgstr ""
 
+#: lclstrconsts.rscontrolisnotaparent
+msgid "'%s' is not a parent of '%s'"
+msgstr ""
+
 #: lclstrconsts.rscreamcolorcaption
 msgid "Cream"
 msgstr "Cremefarbig"

lcl/languages/lclstrconsts.es.po

@@ -373,6 +373,10 @@ msgstr "El control de clase '%s' no puede tener al control de clase '%s' como hi
 msgid "Control '%s' has no parent window"
 msgstr "El control '%s' no tiene ventana padre"
 
+#: lclstrconsts.rscontrolisnotaparent
+msgid "'%s' is not a parent of '%s'"
+msgstr ""
+
 #: lclstrconsts.rscreamcolorcaption
 msgid "Cream"
 msgstr "Crema"

lcl/languages/lclstrconsts.fi.po

@@ -367,6 +367,10 @@ msgstr ""
 msgid "Control '%s' has no parent window"
 msgstr ""
 
+#: lclstrconsts.rscontrolisnotaparent
+msgid "'%s' is not a parent of '%s'"
+msgstr ""
+
 #: lclstrconsts.rscreamcolorcaption
 msgid "Cream"
 msgstr ""

lcl/languages/lclstrconsts.fr.po

@@ -376,6 +376,10 @@ msgstr ""
 msgid "Control '%s' has no parent window"
 msgstr ""
 
+#: lclstrconsts.rscontrolisnotaparent
+msgid "'%s' is not a parent of '%s'"
+msgstr ""
+
 #: lclstrconsts.rscreamcolorcaption
 msgid "Cream"
 msgstr ""

lcl/languages/lclstrconsts.he.po

@@ -372,6 +372,10 @@ msgstr "פקד של המחלקה  '%s' לא יכול לקבל פקד של מחל
 msgid "Control '%s' has no parent window"
 msgstr "לפקד s% אין חלון הורה"
 
+#: lclstrconsts.rscontrolisnotaparent
+msgid "'%s' is not a parent of '%s'"
+msgstr ""
+
 #: lclstrconsts.rscreamcolorcaption
 msgid "Cream"
 msgstr "קרמי"

lcl/languages/lclstrconsts.id.po

@@ -375,6 +375,10 @@ msgstr ""
 msgid "Control '%s' has no parent window"
 msgstr ""
 
+#: lclstrconsts.rscontrolisnotaparent
+msgid "'%s' is not a parent of '%s'"
+msgstr ""
+
 #: lclstrconsts.rscreamcolorcaption
 msgid "Cream"
 msgstr ""

lcl/languages/lclstrconsts.it.po

@@ -376,6 +376,10 @@ msgstr "Un controllo di classe '%s' non può avere figli di classe '%s'"
 msgid "Control '%s' has no parent window"
 msgstr "Il controllo '%s' non ha finestra padre"
 
+#: lclstrconsts.rscontrolisnotaparent
+msgid "'%s' is not a parent of '%s'"
+msgstr ""
+
 #: lclstrconsts.rscreamcolorcaption
 msgid "Cream"
 msgstr "Crema"

lcl/languages/lclstrconsts.lt.po

@@ -375,6 +375,10 @@ msgstr "„%s“ klasės valdiklis negali būti „%s“ klasės valdiklio tėva
 msgid "Control '%s' has no parent window"
 msgstr "„%s“ valdiklis neturi tėvinio lango"
 
+#: lclstrconsts.rscontrolisnotaparent
+msgid "'%s' is not a parent of '%s'"
+msgstr ""
+
 #: lclstrconsts.rscreamcolorcaption
 msgid "Cream"
 msgstr "Kreminė"

lcl/languages/lclstrconsts.nl.po

@@ -376,6 +376,10 @@ msgstr "Control of klasse '%s' kan control of klasse '%s' niet als kind hebben"
 msgid "Control '%s' has no parent window"
 msgstr "Control '%s' heeft geen venster als ouder"
 
+#: lclstrconsts.rscontrolisnotaparent
+msgid "'%s' is not a parent of '%s'"
+msgstr ""
+
 #: lclstrconsts.rscreamcolorcaption
 msgid "Cream"
 msgstr "Cream"

lcl/languages/lclstrconsts.no.po

@@ -374,6 +374,10 @@ msgstr ""
 msgid "Control '%s' has no parent window"
 msgstr ""
 
+#: lclstrconsts.rscontrolisnotaparent
+msgid "'%s' is not a parent of '%s'"
+msgstr ""
+
 #: lclstrconsts.rscreamcolorcaption
 msgid "Cream"
 msgstr ""

lcl/languages/lclstrconsts.pl.po

@@ -378,6 +378,10 @@ msgstr ""
 msgid "Control '%s' has no parent window"
 msgstr ""
 
+#: lclstrconsts.rscontrolisnotaparent
+msgid "'%s' is not a parent of '%s'"
+msgstr ""
+
 #: lclstrconsts.rscreamcolorcaption
 msgid "Cream"
 msgstr ""

lcl/languages/lclstrconsts.po

@@ -367,6 +367,10 @@ msgstr ""
 msgid "Control '%s' has no parent window"
 msgstr ""
 
+#: lclstrconsts.rscontrolisnotaparent
+msgid "'%s' is not a parent of '%s'"
+msgstr ""
+
 #: lclstrconsts.rscreamcolorcaption
 msgid "Cream"
 msgstr ""

lcl/languages/lclstrconsts.pt.po

@@ -374,6 +374,10 @@ msgstr "Controle de classe '%s' não pode ter controle de classe '%s' como filho
 msgid "Control '%s' has no parent window"
 msgstr "Controle '%s' não possui janela pai"
 
+#: lclstrconsts.rscontrolisnotaparent
+msgid "'%s' is not a parent of '%s'"
+msgstr ""
+
 #: lclstrconsts.rscreamcolorcaption
 msgid "Cream"
 msgstr "Creme"

lcl/languages/lclstrconsts.pt_BR.po

@@ -373,6 +373,10 @@ msgstr "Controle de classe '%s' não pode ter controle de classe '%s' como filho
 msgid "Control '%s' has no parent window"
 msgstr "Controle '%s' não possui janela pai"
 
+#: lclstrconsts.rscontrolisnotaparent
+msgid "'%s' is not a parent of '%s'"
+msgstr ""
+
 #: lclstrconsts.rscreamcolorcaption
 msgid "Cream"
 msgstr "Creme"

lcl/languages/lclstrconsts.ru.po

@@ -374,6 +374,10 @@ msgstr "Элемент управления класса '%s' не может и
 msgid "Control '%s' has no parent window"
 msgstr "Элемент управления '%s' не имеет родительского окна"
 
+#: lclstrconsts.rscontrolisnotaparent
+msgid "'%s' is not a parent of '%s'"
+msgstr ""
+
 #: lclstrconsts.rscreamcolorcaption
 msgid "Cream"
 msgstr "Кремовый"

lcl/languages/lclstrconsts.sk.po

@@ -377,6 +377,10 @@ msgstr ""
 msgid "Control '%s' has no parent window"
 msgstr ""
 
+#: lclstrconsts.rscontrolisnotaparent
+msgid "'%s' is not a parent of '%s'"
+msgstr ""
+
 #: lclstrconsts.rscreamcolorcaption
 msgid "Cream"
 msgstr ""

lcl/languages/lclstrconsts.tr.po

@@ -374,6 +374,10 @@ msgstr ""
 msgid "Control '%s' has no parent window"
 msgstr ""
 
+#: lclstrconsts.rscontrolisnotaparent
+msgid "'%s' is not a parent of '%s'"
+msgstr ""
+
 #: lclstrconsts.rscreamcolorcaption
 msgid "Cream"
 msgstr ""

lcl/languages/lclstrconsts.uk.po

@@ -374,6 +374,10 @@ msgstr "Елемент управління класу '%s' не може мат
 msgid "Control '%s' has no parent window"
 msgstr "Елемент управління '%s' не має батьківського вінка"
 
+#: lclstrconsts.rscontrolisnotaparent
+msgid "'%s' is not a parent of '%s'"
+msgstr ""
+
 #: lclstrconsts.rscreamcolorcaption
 msgid "Cream"
 msgstr "Кремовий"

lcl/languages/lclstrconsts.zh_CN.po

@@ -377,6 +377,10 @@ msgstr ""
 msgid "Control '%s' has no parent window"
 msgstr ""
 
+#: lclstrconsts.rscontrolisnotaparent
+msgid "'%s' is not a parent of '%s'"
+msgstr ""
+
 #: lclstrconsts.rscreamcolorcaption
 msgid "Cream"
 msgstr ""

lcl/lclstrconsts.pas

@@ -253,6 +253,7 @@ resourceString
   rsCreatingGdbCatchableError = 'Creating gdb catchable error:';
   rsAControlCanNotHaveItselfAsParent = 'A control can''t have itself as a parent';
   rsControlHasNoParentWindow = 'Control ''%s'' has no parent window';
+  rsControlIsNotAParent = '''%s'' is not a parent of ''%s''';
   rsControlClassCantContainChildClass = 'Control of class ''%s'' can''t have control of class ''%s'' as a child';
   lisLCLResourceSNotFound = 'Resource %s not found';
   rsFormResourceSNotFoundForResourcelessFormsCreateNew = 'Form resource %s '