paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-08 09:38:12 +02:00
Code Issues Packages Projects Releases Wiki Activity

fixed TControl painting for win32

Browse Source 
git-svn-id: trunk@4551 -
This commit is contained in:
mattias 2003-08-31 17:30:49 +00:00
parent 0f2cc7f29c
commit 6c5073cde1
8 changed files with 184 additions and 264 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

206
lcl/include/customform.inc
View File

@ -1308,16 +1308,19 @@ begin
end
else begin
case Position of
//TODO:poDefault, poDefaultPosOnly, poDefaultSizeOnly
poScreenCenter, poDesktopCenter : begin
//TODO:poDefault, poDefaultPosOnly, poDefaultSizeOnly
poScreenCenter, poDesktopCenter :
begin
X:= (Screen.Width - Width) div 2;
Y:= (Screen.Height - Height) div 2;
end;
poMainFormCenter : if (Self <> Application.MainForm) then begin
poMainFormCenter :
if (Self <> Application.MainForm) then begin
X:= ((Application.MainForm.Width - Width) div 2) + Application.MainForm.Left;
Y:= ((Application.MainForm.Height - Height) div 2) + Application.MainForm.Top;
end;
poOwnerFormCenter : if (Owner is TCustomForm) then begin
poOwnerFormCenter :
if (Owner is TCustomForm) then begin
X:= ((TCustomForm(Owner).Width - Width) div 2) + TCustomForm(Owner).Left;
Y:= ((TCustomForm(Owner).Height - Height) div 2) + TCustomForm(Owner).Top;
end;
@ -1426,6 +1429,9 @@ end;
{ =============================================================================
$Log$
Revision 1.112 2003/08/31 17:30:49 mattias
fixed TControl painting for win32
Revision 1.111 2003/08/28 12:08:30 mattias
fixed register color prop edit
@ -1791,194 +1797,4 @@ end;
Revision 1.1 2000/07/13 10:28:25 michael
+ Initial import
Revision 1.5 2000/05/09 02:07:40 lazarus
Replaced writelns with Asserts. CAW
Revision 1.4 2000/05/03 17:19:29 lazarus
Added the TScreem forms code by hongli@telekabel.nl
Shane
Revision 1.3 2000/04/10 14:03:07 lazarus
Added SetProp and GetProp winapi calls.
Added ONChange to the TEdit's published property list.
Shane
Revision 1.2 2000/04/07 16:59:55 lazarus
Implemented GETCAPTURE and SETCAPTURE along with RELEASECAPTURE.
Shane
Revision 1.1 2000/04/02 20:49:56 lazarus
MWE:
Moved lazarus/lcl/*.inc files to lazarus/lcl/include
Revision 1.37 2000/03/30 18:07:53 lazarus
Added some drag and drop code
Added code to change the unit name when it's saved as a different name. Not perfect yet because if you are in a comment it fails.
Shane
Revision 1.36 2000/03/15 20:15:31 lazarus
MOdified TBitmap but couldn't get it to work
Shane
Revision 1.35 2000/03/03 20:22:03 lazarus
Trying to add TBitBtn
Shane
Revision 1.34 2000/03/01 00:41:02 lazarus
MWE:
Fixed updateshowing problem
Added some debug code to display the name of messages
Did a bit of cleanup in main.pp to get the code a bit more readable
(my editor does funny things with tabs if the indent differs)
Revision 1.33 2000/02/28 19:16:04 lazarus
Added code to the FILE CLOSE to check if the file was modified. HAven't gotten the application.messagebox working yet though. It won't stay visible.
Shane
Revision 1.32 2000/02/28 00:15:54 lazarus
MWE:
Fixed creation of visible componets at runtime. (when a new editor
was created it didn't show up)
Made the hiding/showing of controls more delphi compatible
Revision 1.31 2000/02/24 21:15:30 lazarus
Added TCustomForm.GetClientRect and RequestAlign to try and get the controls to align correctly when a MENU is present. Not Complete yet.
Fixed the bug in TEdit that caused it not to update it's text property. I will have to
look at TMemo to see if anything there was affected.
Added SetRect to WinAPI calls
Added AdjustWindowRectEx to WINAPI calls.
Shane
Revision 1.30 2000/02/23 14:19:09 lazarus
Fixed the conflicts caused when two people worked on the ShowModal method for CustomForm and CustomDialog at the same time.
Shane
Revision 1.29 2000/02/22 22:19:49 lazarus
TCustomDialog is a descendant of TComponent.
Initial cuts a form's proper Close behaviour.
Revision 1.28 2000/02/22 17:32:49 lazarus
Modified the ShowModal call.
For TCustomForm is simply sets the visible to true now and adds fsModal to FFormState. In gtkObject.inc FFormState is checked. If it contains fsModal then either gtk_grab_add or gtk_grab_remove is called depending on the value of VISIBLE.
The same goes for TCustomDialog (open, save, font, color).
I moved the Execute out of the individual dialogs and moved it into TCustomDialog and made it virtual because FONT needs to set some stuff before calling the inherited execute.
Shane
Revision 1.27 2000/02/19 18:11:59 lazarus
More work on moving, resizing, forms' border style etc.
Revision 1.26 2000/02/18 19:38:52 lazarus
Implemented TCustomForm.Position
Better implemented border styles. Still needs some tweaks.
Changed TComboBox and TListBox to work again, at least partially.
Minor cleanups.
Revision 1.25 2000/01/03 00:19:21 lazarus
MWE:
Added keyup and buttonup events
Added LM_MOUSEMOVE callback
Started with scrollbars in editor
Revision 1.24 1999/12/22 01:16:03 lazarus
MWE:
Changed/recoded keyevent callbacks
We Can Edit!
Commented out toolbar stuff
Revision 1.23 1999/12/14 00:16:43 lazarus
MWE:
Renamed LM... message handlers to WM... to be compatible and to
get more edit parts to compile
Started to implement GetSystemMetrics
Removed some Lazarus specific parts from mwEdit
Revision 1.22 1999/12/10 00:47:01 lazarus
MWE:
Fixed some samples
Fixed Dialog parent is no longer needed
Fixed (Win)Control Destruction
Fixed MenuClick
Revision 1.21 1999/12/08 00:56:07 lazarus
MWE:
Fixed menus. Events aren't enabled yet (dumps --> invalid typecast ??)
Revision 1.20 1999/12/07 01:19:25 lazarus
MWE:
Removed some double events
Changed location of SetCallBack
Added call to remove signals
Restructured somethings
Started to add default handlers in TWinControl
Made some parts of TControl and TWinControl more delphi compatible
... and lots more ...
Revision 1.19 1999/11/23 22:06:27 lazarus
Minor changes to get it running again with the latest compiler. There is something wrong with the compiler that is preventing certain things from working.
Shane
Revision 1.18 1999/11/04 21:52:08 lazarus
wndproc being used a little
Shane
Revision 1.17 1999/11/02 16:02:34 lazarus
Added a bunch of wndproc stuff and a lot of functions that really don't do a thing at this point.
Shane
Revision 1.16 1999/11/01 09:53:16 lazarus
MWE: Implemented HandleNeeded/CreateHandle/CreateWND
Now controls are created on demand. A call to CreateComponent shouldn't
be needed. It is now part of CreateWnd
Revision 1.15 1999/10/28 23:48:57 lazarus
MWE: Added new menu classes and started to use handleneeded
Revision 1.14 1999/10/28 20:37:34 lazarus
TCustomForm.ClientWndProc added.
Shane
Revision 1.13 1999/10/27 17:27:07 lazarus
Added alot of changes and TODO: statements
shane
Revision 1.12 1999/10/27 12:53:23 lazarus
Added LCLLinux.pp and removed Linux.pp
Also, added the TCustomForm.ISFORM function.
Shane
Revision 1.11 1999/09/21 23:46:53 lazarus
*** empty log message ***
Revision 1.10 1999/08/07 17:59:16 lazarus
buttons.pp the DoLeave and DoEnter were connected to the wrong
event.
The rest were modified to use the new CNSendMEssage function. MAH
Revision 1.9 1999/08/02 01:13:32 lazarus
Added new colors and corrected BTNFACE
Need the TSCrollbar class to go further with the editor.
Mouse doesn't seem to be working correctly yet when I click on the editor window
Revision 1.8 1999/08/01 21:46:24 lazarus
Modified the GETWIDTH and GETHEIGHT of TFOnt so you can use it to calculate the length in Pixels of a string. This is now used in the editor.
Shane
Revision 1.7 1999/07/31 06:39:20 lazarus
Modified the IntCNSendMEssage3 to include a data variable. It isn't used
yet but will help in merging the Message2 and Message3 features.
Adjusted TColor routines to match Delphi color format
Added a TGdkColorToTColor routine in gtkproc.inc
Finished the TColorDialog added to comDialog example. MAH
}
}

8
lcl/include/interfacebase.inc
View File

@ -850,9 +850,10 @@ begin
Result := False;
end;
Function TInterfaceBase.GetClientBounds(handle : HWND; var Rect : TRect) : Boolean;
Function TInterfaceBase.GetClientBounds(Handle : HWND;
var ARect: TRect) : Boolean;
begin
Result := False;
Result := false;
end;
Function TInterfaceBase.GetClientRect(handle : HWND; var Rect : TRect) : Boolean;
@ -1827,6 +1828,9 @@ end;
{ =============================================================================
$Log$
Revision 1.103 2003/08/31 17:30:49 mattias
fixed TControl painting for win32
Revision 1.102 2003/08/26 08:12:33 mattias
applied listbox/combobox patch from Karl

5
lcl/include/winapih.inc
View File

@ -122,7 +122,7 @@ function GetBitmapRawImageDescription(Bitmap: HBITMAP; Desc: PRawImageDescriptio
function GetCapture : HWND; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function GetCaretPos(var lpPoint: TPoint): Boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function GetCaretRespondToFocus(handle: HWND; var ShowHideOnFocus: boolean): Boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
Function GetClientBounds(handle : HWND; var Rect: TRect) : Boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
Function GetClientBounds(handle : HWND; var ARect: TRect) : Boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
Function GetClientRect(handle : HWND; var Rect: TRect) : Boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
Function GetClipBox(DC : hDC; lpRect : PRect) : Longint; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
Function GetClipRGN(DC : hDC; RGN : hRGN) : Longint; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
@ -397,6 +397,9 @@ procedure RaiseLastOSError;
{ =============================================================================
$Log$
Revision 1.88 2003/08/31 17:30:49 mattias
fixed TControl painting for win32
Revision 1.87 2003/08/26 08:12:33 mattias
applied listbox/combobox patch from Karl

25
lcl/include/wincontrol.inc
View File

@ -736,9 +736,9 @@ End;
returns the screen coordinate of the topleft coordinate 0,0 of the client area
Note that this value is the position as stored in the interface and is not
always consistent with the LCL. When a control is moved, the LCL sets the
bounds to the wanted position and sends a move message to the interface. It is
up to the interface to handle moves instantly or queued.
always in sync with the LCL. When a control is moved, the LCL sets the bounds
to the wanted position and sends a move message to the interface. It is up to
the interface to handle moves instantly or queued.
-------------------------------------------------------------------------------}
Function TWinControl.GetClientOrigin: TPoint;
var
@ -2337,6 +2337,7 @@ var
PS : TPaintStruct;
MemWidth: Integer;
MemHeight: Integer;
ClientBoundRect: TRect;
begin
//writeln('[TWinControl.WMPaint] ',Name,':',ClassName,' ',HexStr(Msg.DC,8));
if ([csDestroying,csLoading]*ComponentState<>[]) or (not HandleAllocated) then
@ -2368,15 +2369,26 @@ begin
MemDC := CreateCompatibleDC(0);
OldBitmap := SelectObject(MemDC, MemBitmap);
try
// Fetch a DC of the whole Handle (including client area)
DC := BeginPaint(Handle, PS);
if DC=0 then exit;
// erase background
Include(FFlags,wcfEraseBackground);
Perform(LM_ERASEBKGND, MemDC, 0);
Exclude(FFlags,wcfEraseBackground);
// create a paint message to paint the child controls.
// WMPaint expects the DC origin to be equal to the client origin of its
// parent
// -> Move the DC Origin to the client origin
if not GetClientBounds(Handle,ClientBoundRect) then exit;
MoveWindowOrgEx(MemDC,ClientBoundRect.Left,ClientBoundRect.Top);
// handle the paint message
Msg.DC := MemDC;
WMPaint(Msg);
Msg.DC := 0;
//TODO:bitblt
BitBlt(DC, 0, 0, MemWidth, MemHeight, MemDC, 0, 0, SRCCOPY);
// restore the DC origin
MoveWindowOrgEx(MemDC,-ClientBoundRect.Left,-ClientBoundRect.Top);
BitBlt(DC, 0,0, MemWidth, MemHeight, MemDC, 0, 0, SRCCOPY);
EndPaint(Handle, PS);
finally
Exclude(FFlags,wcfEraseBackground);
@ -3064,6 +3076,9 @@ end;
{ =============================================================================
$Log$
Revision 1.166 2003/08/31 17:30:49 mattias
fixed TControl painting for win32
Revision 1.165 2003/08/27 11:01:10 mattias
started TDockTree

9
lcl/interfaces/win32/win32object.inc
View File

@ -445,7 +445,7 @@ Begin
Begin
if Sender=nil then Handle := GetDesktopWindow
else Handle := ObjectToHwnd(Sender);
DC := GetDC(Handle);
DC := Windows.GetDC(Handle);
//WriteLn('LM_SCREENINIT called --> should go to TWin32Object.Init');
//WriteLn('TODO: check this');
PLMScreenInit(Data)^.PixelsPerInchX := GetDeviceCaps(DC, LogPixelsX);
@ -1771,7 +1771,7 @@ Begin
// Temphack to set backcolor, till better solution
If HandleAllocated Then
Begin
DC := GetDC(Handle);
DC := Windows.GetDC(Handle);
SetBKColor(Handle, Color);
ReleaseDC(Handle, DC);
End;
@ -1931,7 +1931,7 @@ Begin
End;
csImage:
Begin
DC := GetDC(Handle);
DC := Windows.GetDC(Handle);
With TImage(Sender).Picture.Bitmap Do
Window := CreateBitmap(Width, Height, GetDeviceCaps(DC, PLANES), BitsPerPixel[Monochrome], Nil);
SetOwner(Window, Sender);
@ -2815,6 +2815,9 @@ End;
{
$Log$
Revision 1.104 2003/08/31 17:30:49 mattias
fixed TControl painting for win32
Revision 1.103 2003/08/31 14:48:15 mattias
replaced some as from Micha

78
lcl/interfaces/win32/win32proc.inc
View File

@ -618,51 +618,76 @@ Begin
Result := GetProp(Control, 'AccelKey');
End;
Procedure LCLBoundsToWin32Bounds(Sender: TObject;
var Left, Top, Width, Height: Integer);
{-------------------------------------------------------------------------------
function GetLCLClientOriginOffset(Sender: TObject;
var LeftOffset, TopOffset: integer): boolean;
Returns the difference between the client origin of a win32 handle
and the definition of the LCL counterpart.
For example:
TGroupBox's client area is the area inside the groupbox frame.
Hence, the LeftOffset is the frame width and the TopOffset is the caption
height.
-------------------------------------------------------------------------------}
function GetLCLClientOriginOffset(Sender: TObject;
var LeftOffset, TopOffset: integer): boolean;
var
TM: TextMetricA;
DC: HDC;
Handle: HWND;
TheWinControl: TWinControl;
Begin
Result:=false;
LeftOffset:=0;
TopOffset:=0;
if (Sender = nil) or (not (Sender is TWinControl)) then exit;
TheWinControl:=TWinControl(Sender);
If (TheWinControl.Parent Is TCustomGroupBox) Then
if not TheWinControl.HandleAllocated then exit;
If (TheWinControl is TCustomGroupBox) Then
Begin
// The client area of a groupbox under win32 is the whole size, including
// the frame. The LCL defines the client area without the frame.
// -> Adjust the position
Handle := TheWinControl.Parent.Handle;
DC := GetDC(Handle);
Handle := TheWinControl.Handle;
DC := Windows.GetDC(Handle);
GetTextMetrics(DC, TM);
inc(Top,TM.TMHeight); // add the upper frame with the caption
inc(Left,2); // add the left frame border
inc(TopOffset,TM.TMHeight); // add the upper frame with the caption
inc(LeftOffset,2); // add the left frame border
ReleaseDC(Handle, DC);
End;
Result:=true;
end;
function GetLCLClientOriginOffset(Handle: HWnd;
var LeftOffset, TopOffset: integer): boolean;
var
OwnerObject: TObject;
begin
OwnerObject := TObject(GetProp(Handle, 'Lazarus'));
Result:=GetLCLClientOriginOffset(OwnerObject,LeftOffset,TopOffset);
end;
Procedure LCLBoundsToWin32Bounds(Sender: TObject;
var Left, Top, Width, Height: Integer);
var
LeftOffset: integer;
TopOffset: integer;
Begin
if (Sender=nil) or (not (Sender is TWinControl)) then exit;
GetLCLClientOriginOffset(TWinControl(Sender).Parent,LeftOffset,TopOffset);
inc(Left,LeftOffset);
inc(Top,TopOffset);
End;
Procedure Win32PosToLCLPos(Sender: TObject; var Left, Top: SmallInt);
var
TM: TextMetricA;
DC: HDC;
Handle: HWND;
TheWinControl: TWinControl;
LeftOffset: integer;
TopOffset: integer;
Begin
if (Sender = nil) or (not (Sender is TWinControl)) then exit;
TheWinControl:=TWinControl(Sender);
If (TheWinControl.Parent Is TCustomGroupBox) Then
Begin
// The client area of a groupbox under win32 is the whole size, including
// the frame. The LCL defines the client area without the frame.
// -> Adjust the position
Handle := TheWinControl.Parent.Handle;
DC := GetDC(Handle);
GetTextMetrics(DC, TM);
dec(Top,TM.TMHeight); // subtract the upper frame with the caption
dec(Left,2); // subtract the left frame border
ReleaseDC(Handle, DC);
End;
if (Sender=nil) or (not (Sender is TWinControl)) then exit;
GetLCLClientOriginOffset(TWinControl(Sender).Parent,LeftOffset,TopOffset);
dec(Left,LeftOffset);
dec(Top,TopOffset);
End;
{$IFDEF ASSERT_IS_ON}
@ -673,6 +698,9 @@ End;
{ =============================================================================
$Log$
Revision 1.25 2003/08/31 17:30:49 mattias
fixed TControl painting for win32
Revision 1.24 2003/08/28 09:10:01 mattias
listbox and comboboxes now set sort and selection at handle creation

113
lcl/interfaces/win32/win32winapi.inc
View File

@ -139,23 +139,46 @@ End;
functions for the message.
------------------------------------------------------------------------------}
Procedure TWin32Object.CallDefaultWndHandler(Sender: TObject; var Message);
var
Handle: HWND;
PrevWndProc: pointer;
begin
Handle := ObjectToHwnd(Sender);
case TLMessage(Message).Msg of
LM_PAINT:
begin
procedure CallWin32PaintHandler;
var
PaintMsg: TLMPaint;
Handle: HWND;
PrevWndProc: pointer;
ClientBoundRect: TRect;
begin
// the LCL creates paint messages, with a DC origin set to the client
// origin of the emitting control. The paint handler of win32 expects the
// DC origin at the origin of the control.
// -> move the windoworigin
Handle := ObjectToHwnd(Sender);
ClientBoundRect:=Rect(0,0,0,0);
if Sender is TWinControl then
if not GetClientBounds(Handle,ClientBoundRect) then exit;
PaintMsg:=TLMPaint(Message);
MoveWindowOrgEx(PaintMsg.DC,-ClientBoundRect.Left,-ClientBoundRect.Top);
try
// call win32 paint handler
PrevWndProc := GetProp(Handle, 'DefWndProc');
if PrevWndProc = nil then
DefWindowProc(Handle, WM_PAINT, TLMessage(Message).WParam, TLMessage(Message).LParam)
DefWindowProc(Handle, WM_PAINT, TLMessage(Message).WParam,
TLMessage(Message).LParam)
else
CallWindowProc(PrevWndProc, Handle, WM_PAINT,
TLMessage(Message).WParam, TLMessage(Message).LParam);
finally
// restore DC origin
MoveWindowOrgEx(PaintMsg.DC,ClientBoundRect.Left,ClientBoundRect.Top);
end;
end;
begin
case TLMessage(Message).Msg of
LM_PAINT:
CallWin32PaintHandler;
end;
end;
{------------------------------------------------------------------------------
@ -218,8 +241,15 @@ End;
Converts client coordinates to screen coordinates
------------------------------------------------------------------------------}
Function TWin32Object.ClientToScreen(Handle: HWND; Var P: TPoint): Boolean;
var
LeftOffset, TopOffset: integer;
Begin
Result := Windows.ClientToScreen(Handle, @P);
if (not Result) then exit;
Result := GetLCLClientOriginOffset(Handle,LeftOffset,TopOffset);
if not Result then exit;
inc(P.X,LeftOffset);
inc(P.X,TopOffset);
End;
{------------------------------------------------------------------------------
@ -681,7 +711,7 @@ Begin
End;
If (Width <> 0) And (Height <> 0) Then Begin
hdcScreen := GetDC(GetDesktopWindow);
hdcScreen := Windows.GetDC(GetDesktopWindow);
hdcBitmap := CreateCompatibleDC(hdcScreen);
hbmBitmap := CreateCompatibleBitmap(hdcScreen, Width, Height);
OldObject := SelectObject(hdcBitmap, hbmBitmap);
@ -1099,6 +1129,25 @@ End;
Retrieves the coordinates of a window's client area.
------------------------------------------------------------------------------}
function TWin32Object.GetClientBounds(Handle: HWND; Var Rect: TRect): Boolean;
var
LeftOffset, TopOffset: integer;
begin
Result := GetClientRect(Handle, Rect);
if not Result then exit;
if not GetLCLClientOriginOffset(Handle,LeftOffset,TopOffset) then exit;
OffsetRect(Rect,LeftOffset,TopOffset);
end;
{------------------------------------------------------------------------------
Method: GetClientRect
Params: Handle - handle of window
Rect - record for client coordinates
Returns: If the function succeeds
Retrieves the dimension of a window's client area.
Left and Top are always 0,0
------------------------------------------------------------------------------}
Function TWin32Object.GetClientRect(Handle: HWND; Var Rect: TRect): Boolean;
var
OwnerObject: TObject;
@ -1107,6 +1156,7 @@ var
DC: HDC;
Begin
Result := Windows.GetClientRect(Handle, @Rect);
if not Result then exit;
OwnerObject := TObject(GetProp(Handle, 'Lazarus'));
if OwnerObject is TWinControl then begin
TheWinControl:=TWinControl(OwnerObject);
@ -1114,7 +1164,7 @@ Begin
// The client area of a groupbox under win32 is the whole size, including
// the frame. The LCL defines the client area without the frame.
// -> Adjust the client size
DC := GetDC(Handle);
DC := Windows.GetDC(Handle);
GetTextMetrics(DC, TM);
dec(Rect.Bottom,TM.TMHeight+2); // subtract the top frame with the caption
// and subtract the bottom frame
@ -1190,9 +1240,15 @@ End;
the specified window.
------------------------------------------------------------------------------}
Function TWin32Object.GetDC(HWnd: HWND): HDC;
var
LeftOffset, TopOffset: integer;
Begin
Assert(False, Format('Trace:> [TWin32Object.GetDC] HWND: 0x%x', [HWnd]));
Result := Windows.GetDC(HWnd);
if (Result<>0) and (HWnd<>0)
and GetLCLClientOriginOffset(HWnd,LeftOffset,TopOffset) then begin
MoveWindowOrgEx(Result,LeftOffset,TopOffset);
end;
Assert(False, Format('Trace:< [TWin32Object.GetDC] Got 0x%x', [Result]));
End;
@ -1448,36 +1504,24 @@ var
LeftTop:TPoint;
R: TRect;
ParentHandle: THandle;
OwnerObject: TObject;
TheWinControl: TWinControl;
DC: HDC;
TM: TextMetricA;
LeftOffset, TopOffset: integer;
begin
Result:=Windows.GetWindowRect(Handle,@R);
Result:=false;
if not Windows.GetWindowRect(Handle,@R) then exit;
LeftTop.X:=R.Left;
LeftTop.Y:=R.Top;
ParentHandle:=Windows.GetParent(Handle);
if ParentHandle<>0 then
begin
Windows.ScreenToClient(ParentHandle,@LeftTop);
OwnerObject := TObject(GetProp(ParentHandle, 'Lazarus'));
if (OwnerObject<>nil) and (OwnerObject is TWinControl) then begin
TheWinControl:=TWinControl(OwnerObject);
if TheWinControl is TGroupBox then
begin
{$IFDEF VerboseSizeMsg}
writeln('TWin32Object.GetWindowRelativePosition A ',TheWinControl.Name,':',TheWinControl.ClassName,' Win32=',R.Left,',',R.Top,' Moved=',LeftTop.X,',',LeftTop.Y);
{$ENDIF}
DC := GetDC(ParentHandle);
GetTextMetrics(DC, TM);
dec(LeftTop.Y,TM.TMHeight);
dec(LeftTop.X,2);
ReleaseDC(ParentHandle, DC);
end;
end;
if not Windows.ScreenToClient(ParentHandle,@LeftTop) then exit;
if not GetLCLClientOriginOffset(ParentHandle,LeftOffset,TopOffset) then
exit;
dec(LeftTop.X,LeftOffset);
dec(LeftTop.Y,TopOffset);
end;
Left:=LeftTop.X;
Top:=LeftTop.Y;
Result:=true;
end;
{------------------------------------------------------------------------------
@ -2431,6 +2475,9 @@ end;
{ =============================================================================
$Log$
Revision 1.59 2003/08/31 17:30:49 mattias
fixed TControl painting for win32
Revision 1.58 2003/08/27 08:14:37 mattias
fixed system fonts for win32 intf

4
lcl/interfaces/win32/win32winapih.inc
View File

@ -83,6 +83,7 @@ Function GetActiveWindow: HWND; Override;
Function GetCapture: HWND; Override;
Function GetCaretPos(Var LPPoint: TPoint): Boolean; Override;
Function GetCharABCWidths(DC: HDC; P2, P3: UINT; Const ABCStructs): Boolean; Override;
function GetClientBounds(Handle: HWND; Var Rect: TRect): Boolean; Override;
Function GetClientRect(Handle: HWND; Var Rect: TRect): Boolean; Override;
Function GetClipBox(DC : hDC; lpRect : PRect) : Longint; Override;
Function GetClipRGN(DC : hDC; RGN : hRGN) : Longint; override;
@ -178,6 +179,9 @@ Procedure DeleteCriticalSection(var CritSection: TCriticalSection); Override;
{ =============================================================================
$Log$
Revision 1.33 2003/08/31 17:30:49 mattias
fixed TControl painting for win32
Revision 1.32 2003/08/18 19:24:18 mattias
fixed TCanvas.Pie