paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-05-29 16:42:44 +02:00
Code Issues Packages Projects Releases Wiki Activity

MG: reduced paint messages and DC getting/releasing

Browse Source 
git-svn-id: trunk@1870 -
This commit is contained in:
lazarus 2002-08-17 23:39:22 +00:00
parent fc0ba22dac
commit ff3404c47b
1 changed files with 98 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

131
lcl/interfaces/gtk/gtkwinapi.inc
View File

@ -3886,19 +3886,22 @@ end;
function TgtkObject.PeekMessage(var lpMsg: TMsg; Handle : HWND; function TgtkObject.PeekMessage(var lpMsg: TMsg; Handle : HWND;
wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): Boolean; wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): Boolean;
var var
Message: PMsg; AMessage: PMsg;
begin begin
//TODO Filtering //TODO Filtering
Result := FMessageQueue.Count > 0; Result := FMessageQueue.Count > 0;
if Result if Result
then begin then begin
Message := FMessageQueue.First^.Data; AMessage := FMessageQueue.First^.Data;
lpMsg := Message^; lpMsg := AMessage^;
if (wRemoveMsg and PM_REMOVE) = PM_REMOVE if (wRemoveMsg and PM_REMOVE) = PM_REMOVE
then begin then begin
if Message^.Message=LM_PAINT then if (AMessage^.Message=LM_PAINT) or (AMessage^.Message=LM_GtkPAINT) then
begin
FPaintMessages.Remove(FMessageQueue.First); FPaintMessages.Remove(FMessageQueue.First);
// don't free the DC, this is work for the caller
end;
FMessageQueue.Delete(FMessageQueue.First); FMessageQueue.Delete(FMessageQueue.First);
end; end;
end; end;
@ -4081,7 +4084,7 @@ end;
{------------------------------------------------------------------------------ {------------------------------------------------------------------------------
Function: PostMessage Function: PostMessage
Params: hWnd: Params: Handle:
Msg: Msg:
wParam: wParam:
lParam: lParam:
@ -4090,36 +4093,81 @@ end;
The PostMessage function places (posts) a message in the message queue and The PostMessage function places (posts) a message in the message queue and
then returns without waiting. then returns without waiting.
------------------------------------------------------------------------------} ------------------------------------------------------------------------------}
function TGTKObject.PostMessage(hWnd: HWND; Msg: Cardinal; wParam: LongInt; function TGTKObject.PostMessage(Handle: HWND; Msg: Cardinal; wParam: LongInt;
lParam: LongInt): Boolean; lParam: LongInt): Boolean;
var
Message, OldMessage: PMsg; procedure DeletePaintMessageForHandle(hnd: HWnd);
OldPaintMessage: PLazQueueItem; var
begin OldPaintMessage: PLazQueueItem;
New(Message); OldMessage: PMsg;
Message^.HWnd := hWnd; begin
Message^.Message := Msg; if (hnd=0) then exit;
Message^.WParam := WParam; OldPaintMessage:=FindPaintMessage(hnd);
Message^.LParam := LParam;
// Message^.Time :=
if Message^.Message=LM_PAINT then begin
OldPaintMessage:=FindPaintMessage(hWnd);
if OldPaintMessage<>nil then begin if OldPaintMessage<>nil then begin
// delete old message from queue, so that the widget repaints only once // delete paint message from queue
OldMessage:=PMsg(OldPaintMessage^.Data); OldMessage:=PMsg(OldPaintMessage^.Data);
FPaintMessages.Remove(OldPaintMessage); FPaintMessages.Remove(OldPaintMessage);
FMessageQueue.Delete(OldPaintMessage); FMessageQueue.Delete(OldPaintMessage);
ReleaseDC(0,OldMessage^.WParam); if OldMessage^.Message=LM_PAINT then
ReleaseDC(0,OldMessage^.WParam);
Dispose(OldMessage); Dispose(OldMessage);
end; end;
end;
FMessageQueue.AddLast(Message);
function ParentPaintMessageInQueue: boolean;
var
Target: TControl;
Parent: TWinControl;
ParentHandle: hWnd;
begin
Result:=false;
Target:=TControl(GetLCLObject(Pointer(Handle)));
if not (Target is TControl) then exit;
Parent:=Target.Parent;
if (Target is TControl) then begin
Parent:=Target.Parent;
while Parent<>nil do begin
ParentHandle:=Parent.Handle;
if FindPaintMessage(ParentHandle)<>nil then begin
Result:=true;
end;
Parent:=Parent.Parent;
end;
end;
end;
var
AMessage: PMsg;
begin
Result := True;
New(AMessage);
AMessage^.HWnd := Handle; // this is normally a gtk widget
AMessage^.Message := Msg;
AMessage^.WParam := WParam;
AMessage^.LParam := LParam;
// Message^.Time :=
if (AMessage^.Message=LM_PAINT) or (AMessage^.Message=LM_GtkPAINT) then begin
// paint messages are the most expensive messages in the LCL
// A paint message to a control will also repaint all child controls.
// -> check if there is already a paint message for one of its parents
// if yes, then skip this message
if ParentPaintMessageInQueue then begin
if AMessage^.Message=LM_PAINT then
ReleaseDC(0,AMessage^.WParam);
exit;
end;
// delete old paint message to this widget,
// so that the widget repaints only once
DeletePaintMessageForHandle(Handle);
FMessageQueue.AddLast(AMessage);
FPaintMessages.Add(FMessageQueue.Last); FPaintMessages.Add(FMessageQueue.Last);
end else begin end else begin
FMessageQueue.AddLast(Message); FMessageQueue.AddLast(AMessage);
end; end;
Result := True;
end; end;
{------------------------------------------------------------------------------ {------------------------------------------------------------------------------
@ -4721,20 +4769,20 @@ end;
function TGTKObject.SendMessage(HandleWnd: HWND; Msg: Cardinal; wParam: LongInt; function TGTKObject.SendMessage(HandleWnd: HWND; Msg: Cardinal; wParam: LongInt;
lParam: LongInt): Integer; lParam: LongInt): Integer;
var var
Message: TLMessage; AMessage: TLMessage;
Target: TObject; Target: TObject;
ParentControl: TWinControl; ParentControl: TWinControl;
ParentHandle: HWnd; ParentHandle: HWnd;
begin begin
Message.Msg := Msg; AMessage.Msg := Msg;
Message.WParam := WParam; AMessage.WParam := WParam;
Message.LParam := LParam; AMessage.LParam := LParam;
Message.Result := 0; AMessage.Result := 0;
Target := GetLCLObject(Pointer(HandleWnd)); Target := GetLCLObject(Pointer(HandleWnd));
if Target<>nil then begin if Target<>nil then begin
if Msg=LM_PAINT then begin if (Msg=LM_PAINT) or (Msg=LM_GtkPaint) then begin
// The LCL repaints controls in a top-down hierachy. But the gtk sends // The LCL repaints controls in a top-down hierachy. But the gtk sends
// gtkdraw events bottom-up. So, controls at the bottom are repainted // gtkdraw events bottom-up. So, controls at the bottom are repainted
// many times. To avoid this the queue is checked for LM_PAINT messages // many times. To avoid this the queue is checked for LM_PAINT messages
@ -4744,13 +4792,27 @@ begin
ParentControl:=TControl(Target).Parent; ParentControl:=TControl(Target).Parent;
while ParentControl<>nil do begin while ParentControl<>nil do begin
ParentHandle:=TWinControl(ParentControl).Handle; ParentHandle:=TWinControl(ParentControl).Handle;
if FindPaintMessage(ParentHandle)<>nil then if FindPaintMessage(ParentHandle)<>nil then begin
if Msg=LM_PAINT then
ReleaseDC(0,AMessage.WParam);
exit; exit;
end;
ParentControl:=ParentControl.Parent; ParentControl:=ParentControl.Parent;
end; end;
end; end;
if Msg=LM_GtkPAINT then begin
// convert LM_GtkPAINT to LM_PAINT
AMessage.Msg := LM_PAINT;
AMessage.WParam := GetDC(THandle(HandleWnd));
end;
end; end;
Result := DeliverMessage(Target, Message);
// deliver it
Result := DeliverMessage(Target, AMessage);
// free DC
if AMessage.Msg=LM_PAINT then
ReleaseDC(0,AMessage.WParam);
end; end;
end; end;
@ -6134,6 +6196,9 @@ end;
{ ============================================================================= { =============================================================================
$Log$ $Log$
Revision 1.114 2002/08/28 09:40:50 lazarus
MG: reduced paint messages and DC getting/releasing
Revision 1.113 2002/08/27 18:45:15 lazarus Revision 1.113 2002/08/27 18:45:15 lazarus
MG: propedits text improvements from Andrew, uncapturing, improved comobobox MG: propedits text improvements from Andrew, uncapturing, improved comobobox