paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-12-10 00:37:28 +01:00
Code Issues Packages Projects Releases Wiki Activity

MG: fixed setpixel and TCustomForm.OnResize event

Browse Source 
git-svn-id: trunk@338 -
This commit is contained in:
lazarus 2001-10-07 07:28:34 +00:00
parent 4aed2a0ba4
commit d6dced53e4
12 changed files with 154 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
designer/objectinspector.pp
View File

@ -911,6 +911,7 @@ end;
procedure TOIPropertyGrid.SetBounds(aLeft,aTop,aWidth,aHeight:integer);
begin
//writeln('[TOIPropertyGrid.SetBounds] ',aLeft,',',aTop,',',aWidth,',',aHeight);
inherited SetBounds(aLeft,aTop,aWidth,aHeight);
if Visible then begin
SplitterX:=SplitterX;

2
ide/wordcompletion.pp
View File

@ -79,7 +79,7 @@ var i, j, Line, x, PrefixLen, MaxHash, LineLen: integer;
begin
ALowWord:=lowercase(AWord);
Hash:=0;
a:=0;
a:=1;
while (a<=length(ALowWord)) and (a<20) do begin
inc(Hash,ord(ALowWord[a]) and $3f);
inc(a);

7
lcl/controls.pp
View File

@ -502,7 +502,7 @@ TCMDialogKey = TLMKEY;
public
FCompStyle : LongInt;
Isresizing : Boolean;
IsResizing : Boolean;
// use overload to simulate default
procedure BeginDrag(Immediate: Boolean; Threshold: Integer); //overload;
procedure BeginDrag(Immediate: Boolean); //overload;
@ -1127,7 +1127,7 @@ end;
{$I dragobject.inc}
initialization
writeln('controls.pp - initialization');
//writeln('controls.pp - initialization');
Mouse := TMouse.create;
DragControl := nil;
CaptureControl := nil;
@ -1140,6 +1140,9 @@ end.
{ =============================================================================
$Log$
Revision 1.22 2001/10/07 07:28:32 lazarus
MG: fixed setpixel and TCustomForm.OnResize event
Revision 1.21 2001/09/30 08:34:49 lazarus
MG: fixed mem leaks and fixed range check errors

18
lcl/forms.pp
View File

@ -128,7 +128,6 @@ type
procedure DoShow; dynamic;
procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
Function GetClientRect : TRect ; Override;
property Icon: TIcon read FIcon write SetIcon stored IsIconStored;
Procedure Notification(AComponent: TComponent; Operation : TOperation);override;
procedure Paint; dynamic;
Procedure PaintWindow(dc : Hdc); override;
@ -137,19 +136,21 @@ type
procedure UpdateWindowState;
procedure ValidateRename(AComponent: TComponent; const CurName, NewName: shortstring);
procedure WndProc(var Message : TLMessage); override;
property ActiveControl : TWinControl read FActiveControl write SetActiveControl;
property FormStyle : TFormStyle read FFormStyle write SetFormStyle default fsNormal;
property Position : TPosition read FPosition write SetPosition default poDesigned;
{events}
property ActiveControl : TWinControl read FActiveControl write SetActiveControl;
property Icon: TIcon read FIcon write SetIcon stored IsIconStored;
property FormStyle : TFormStyle read FFormStyle write SetFormStyle default fsNormal;
property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;
property OnClose: TCloseEvent read FOnClose write FOnClose stored IsForm;
property OnCloseQuery : TCloseQueryEvent read FOnCloseQuery write FOnCloseQuery stored IsForm;
property OnCreate: TNotifyEvent read FOnCreate write FOnCreate;
property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;
property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy;
property OnHide: TNotifyEvent read FOnHide write FOnHide;
property OnShow: TNotifyEvent read FOnShow write FOnShow;
property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
property OnClose: TCloseEvent read FOnClose write FOnClose stored IsForm;
property OnCloseQuery : TCloseQueryEvent read FOnCloseQuery write FOnCloseQuery stored IsForm;
property OnResize stored IsForm;
property Position : TPosition read FPosition write SetPosition default poDesigned;
public
constructor Create(AOwner: TComponent); override;
constructor CreateNew(AOwner: TComponent; Num : Integer); virtual;
@ -200,13 +201,14 @@ type
// property WindowState;
property OnActivate;
property OnCreate;
property OnClose;
property OnCloseQuery;
property OnDeactivate;
property OnDestroy;
property OnShow;
property OnHide;
property OnPaint;
property OnClose;
property OnCloseQuery;
property OnResize;
end;
TFormClass = class of TForm;

7
lcl/include/canvas.inc
View File

@ -86,7 +86,7 @@ var
Begin
Msg.X := X;
msg.Y := Y;
MSg.PixColor := Value;
MSg.PixColor := ColorToRGB(Value);
CNSendMessage(LM_SetPixel, Self, @msg);
end;
@ -441,6 +441,7 @@ end;
------------------------------------------------------------------------------}
function TCanvas.GetHandle : HDC;
begin
//writeln('[TCanvas.GetHandle] ',ClassName);
RequiredState(csAllValid);
Result := FHandle;
end;
@ -524,6 +525,7 @@ procedure TCanvas.RequiredState(ReqState: TCanvasState);
var
Needed: TCanvasState;
begin
//writeln('[TCanvas.RequiredState] ',csHandleValid in ReqState,' ',csHandleValid in FState);
Needed := ReqState - FState;
if Needed <> [] then
begin
@ -596,6 +598,9 @@ end;
{ =============================================================================
$Log$
Revision 1.10 2001/10/07 07:28:33 lazarus
MG: fixed setpixel and TCustomForm.OnResize event
Revision 1.9 2001/09/30 08:34:49 lazarus
MG: fixed mem leaks and fixed range check errors

18
lcl/include/control.inc
View File

@ -664,17 +664,17 @@ begin
end;
{------------------------------------------------------------------------------}
{ TControl SetAutoSize }
{ TControl SetAutoSize }
{------------------------------------------------------------------------------}
Procedure TControl.SetAutoSize(value : Boolean);
Begin
if FAutoSize <> value then
FAutosize := Value;
if FAutoSize <> value then
FAutosize := Value;
//TODO: Finish this by calling gtk and telling it to resize...?
end;
{------------------------------------------------------------------------------}
{ TControl SetBoundsRect }
{ TControl SetBoundsRect }
{------------------------------------------------------------------------------}
Procedure TControl.SetBoundsRect(const Rect : TRect);
Begin
@ -684,7 +684,7 @@ Begin
end;
{------------------------------------------------------------------------------}
{ TControl SetCursor }
{ TControl SetCursor }
{------------------------------------------------------------------------------}
procedure TControl.SetCursor(Value: TCursor);
begin
@ -700,7 +700,7 @@ begin
end;
{------------------------------------------------------------------------------}
{ TControl SetEnabled }
{ TControl SetEnabled }
{------------------------------------------------------------------------------}
procedure TControl.SetEnabled(Value: Boolean);
begin
@ -713,7 +713,7 @@ begin
end;
{------------------------------------------------------------------------------}
{ TControl SetMouseCapture }
{ TControl SetMouseCapture }
{------------------------------------------------------------------------------}
procedure TControl.SetMouseCapture(Value : Boolean);
begin
@ -847,6 +847,7 @@ end;
{------------------------------------------------------------------------------}
procedure TControl.Resize;
begin
//writeln('[TControl.Resize] ',ClassName);
if Assigned(FOnResize) then FOnResize(Self);
end;
@ -1325,6 +1326,9 @@ end;
{ =============================================================================
$Log$
Revision 1.25 2001/10/07 07:28:33 lazarus
MG: fixed setpixel and TCustomForm.OnResize event
Revision 1.24 2001/09/30 08:34:49 lazarus
MG: fixed mem leaks and fixed range check errors

4
lcl/include/controlcanvas.inc
View File

@ -55,6 +55,7 @@ end;
------------------------------------------------------------------------------}
procedure TControlCanvas.CreateHandle;
begin
//writeln('[TControlCanvas.CreateHandle] ',FControl<>nil,' DC=',HexStr(FDeviceContext,8),' WinHandle=',HexStr(FWindowHandle,8));
if FControl = nil
then inherited CreateHandle
else begin
@ -88,6 +89,9 @@ end;
{ =============================================================================
$Log$
Revision 1.3 2001/10/07 07:28:33 lazarus
MG: fixed setpixel and TCustomForm.OnResize event
Revision 1.2 2001/03/19 14:00:50 lazarus
MG: fixed many unreleased DC and GDIObj bugs

4
lcl/include/customform.inc
View File

@ -280,6 +280,7 @@ Begin
SIZEFULLSCREEN : FWindowstate := wsMaximized;
end;
RequestAlign;
Resize;
End;
{------------------------------------------------------------------------------
@ -940,6 +941,9 @@ end;
{ =============================================================================
$Log$
Revision 1.27 2001/10/07 07:28:33 lazarus
MG: fixed setpixel and TCustomForm.OnResize event
Revision 1.26 2001/10/03 17:34:26 lazarus
MG: activated TCustomForm.OnCreate event

51
lcl/include/wincontrol.inc
View File

@ -18,7 +18,7 @@ begin
end;
{------------------------------------------------------------------------------}
{ TWinControl AdjustClientRect }
{ TWinControl AdjustClientRect }
{------------------------------------------------------------------------------}
Procedure TWinControl.AdjustClientRect(var Rect: TRect);
Begin
@ -26,7 +26,7 @@ Begin
end;
{------------------------------------------------------------------------------}
{ TWinControl AlignControls }
{ TWinControl AlignControls }
{------------------------------------------------------------------------------}
procedure TWinControl.AlignControls(AControl : TControl; var Rect : TRect);
var
@ -204,7 +204,7 @@ begin
end;
{------------------------------------------------------------------------------}
{ TWinControl BroadCast }
{ TWinControl BroadCast }
{------------------------------------------------------------------------------}
Procedure TWinControl.BroadCast(var Message);
var
@ -242,7 +242,7 @@ begin
end;
{------------------------------------------------------------------------------}
{ TWinControl CMDrag }
{ TWinControl CMDrag }
{------------------------------------------------------------------------------}
Procedure TWinControl.CMDrag(var MEssage: TCMDrag);
Begin
@ -250,23 +250,22 @@ Begin
Begin
case DragMessage of
dmDragEnter, dmDragLEave,dmDragMOve, dmDragDrop :
if target <> nil then TControl(target).DoDragMsg(Message);
dmFindTarget:begin
Writeln('dmFindTarget');
result := longint(ControlatPos(ScreentoClient(pos),False));
if Result = 0 then Result := longint(Self);
end;
if target <> nil then TControl(target).DoDragMsg(Message);
dmFindTarget:
begin
Writeln('dmFindTarget');
Result := longint(ControlatPos(ScreentoClient(pos),False));
if Result = 0 then Result := longint(Self);
end;
end;//case
end;
end;
{------------------------------------------------------------------------------}
{ TWinControl CreateSubClass }
{------------------------------------------------------------------------------}
procedure TWinControl.CreateSubClass(var Params: TCreateParams; ControlClassName: PChar);
procedure TWinControl.CreateSubClass(var Params: TCreateParams;
ControlClassName: PChar);
(*
const
CS_OFF = CS_OWNDC or CS_CLASSDC or CS_PARENTDC or CS_GLOBALCLASS;
@ -292,7 +291,7 @@ end;
{------------------------------------------------------------------------------}
{ TWinControl DisableAlign}
{ TWinControl DisableAlign }
{------------------------------------------------------------------------------}
procedure TWinControl.DisableAlign;
begin
@ -300,7 +299,7 @@ begin
End;
{------------------------------------------------------------------------------}
{ TWinControl EnableAlign}
{ TWinControl EnableAlign }
{------------------------------------------------------------------------------}
procedure TWinControl.EnableAlign;
begin
@ -381,7 +380,7 @@ begin
end;
{------------------------------------------------------------------------------}
{ TWinControl GetTabOrder }
{ TWinControl GetTabOrder }
{------------------------------------------------------------------------------}
Function TWinControl.GetTabOrder : TTabOrder;
Begin
@ -391,7 +390,7 @@ Begin
end;
{------------------------------------------------------------------------------}
{ TWinControl UpdateShowing }
{ TWinControl UpdateShowing }
{------------------------------------------------------------------------------}
procedure TWinControl.UpdateShowing;
var
@ -428,7 +427,7 @@ begin
end;
{------------------------------------------------------------------------------}
{ TWinControl UpdateTabOrder }
{ TWinControl UpdateTabOrder }
{------------------------------------------------------------------------------}
Procedure TWinControl.UpdateTabOrder(Value : TTabOrder);
Begin
@ -436,7 +435,7 @@ Begin
end;
{------------------------------------------------------------------------------}
{ TWinControl Focused }
{ TWinControl Focused }
{------------------------------------------------------------------------------}
Function TWinControl.Focused : Boolean;
Begin
@ -444,7 +443,7 @@ Result := (FHandle <> 0) and (GetFocus = FHandle);
end;
{------------------------------------------------------------------------------}
{ TWinControl FindChildControl }
{ TWinControl FindChildControl }
{------------------------------------------------------------------------------}
function TWinControl.FindChildControl(ControlName: string): TControl;
var
@ -1411,6 +1410,8 @@ end;
------------------------------------------------------------------------------}
procedure TWinControl.WMSize(Var Message : TLMSize);
begin
//writeln('[TWinControl.WMSize] ',ClassName);
if (FWidth=Message.Width) and (FHeight=Message.Height) then exit;
Assert(False, Format('Trace:[TWinControl.WMSize] %s', [ClassName]));
{ Just coordinate the bounds }
FWidth := Message.Width;
@ -1428,14 +1429,15 @@ end;
------------------------------------------------------------------------------}
procedure TWinControl.WMMove(var Message: TLMMove);
begin
//if (FLeft=Message.XPos) and (FTop=Message.YPos) then exit;
{ Just sync the coordinates }
//Writeln('[TWINCONTROL].WMMOVE');
//Writeln(Format('MOVE is LEft=%d Top= %d',[Message.XPos,MEssage.YPos]));
FLeft := Message.XPos;
FTop := Message.YPos;
{ TODO : When anchors are implemented, update its rules instead }
RequestAlign;
if not (csLoading in ComponentState) then Resize;
end;
{------------------------------------------------------------------------------
@ -1463,7 +1465,6 @@ procedure TWinControl.WMKillFocus(var Message: TLMKillFocus);
begin
Assert(False, Format('Trace: TODO: [TWinControl.LMKillFocus] %s', [ClassName]));
DoExit;
end;
{------------------------------------------------------------------------------
@ -1879,6 +1880,7 @@ begin
WindowHandle := FHandle;
(*)
Result := GetDC(Handle);
//writeln('[TWinControl.GetDeviceContext] ',ClassName,' DC=',HexStr(Cardinal(Result),8),' Handle=',HexStr(Cardinal(FHandle),8));
if Result = 0
then raise EOutOfResources.Create('Error creating device context');
@ -1949,6 +1951,9 @@ end;
{ =============================================================================
$Log$
Revision 1.38 2001/10/07 07:28:33 lazarus
MG: fixed setpixel and TCustomForm.OnResize event
Revision 1.37 2001/10/03 17:34:27 lazarus
MG: activated TCustomForm.OnCreate event

5
lcl/interfaces/gtk/gtkint.pp
View File

@ -267,7 +267,7 @@ end;
initialization
writeln('gtkint.pp - initialization');
//writeln('gtkint.pp - initialization');
InternalInit;
finalization
@ -278,6 +278,9 @@ end.
{ =============================================================================
$Log$
Revision 1.20 2001/10/07 07:28:33 lazarus
MG: fixed setpixel and TCustomForm.OnResize event
Revision 1.19 2001/09/30 08:34:51 lazarus
MG: fixed mem leaks and fixed range check errors

81
lcl/interfaces/gtk/gtkobject.inc
View File

@ -2437,7 +2437,7 @@ end;
{------------------------------------------------------------------------------
Method: TGtkObject.SetPixel
Params: Sender : the lcl object which called this func via SenMessage
Params: Sender : the lcl object which called this func via SendMessage
Data : pointer to a TLMSetGetPixel record
Returns: nothing
@ -2445,31 +2445,38 @@ end;
------------------------------------------------------------------------------}
procedure TgtkObject.SetPixel(Sender : TObject; Data : Pointer);
var
fWindow : pGdkWindow;
//gc : pgdkGC;
Image : pGDKImage;
widget : PgtkWidget;
PDC : PDeviceContext;
Image : pGDKImage;
Widget : PgtkWidget;
GDKColor: TGDKColor;
pFixed : PGTKFixed;
fWindow : pGdkWindow;
begin
Widget := PgtkWidget(TCanvas(sender).Handle);
PDC := PDeviceContext(TCanvas(Sender).Handle);
if PDC = nil then exit;
Widget := PgtkWidget(PDC^.HWnd);
Image := gtk_Object_get_data(pgtkobject(widget),'Image');
if Image = nil
then Image := gdk_image_get(pgtkWidget(widget)^.window,0,0,
Image := gtk_Object_get_data(pgtkobject(widget),'Image');
if Image = nil then begin
Image := gdk_image_get(pgtkWidget(widget)^.window,0,0,
widget^.allocation.width,widget^.allocation.height);
if Image = nil then exit;
gtk_Object_set_data(pgtkobject(Widget),'Image',Image);
end;
gdk_image_put_pixel(Image,TLMSetGetPixel(data^).X,TLMSetGetPixel(data^).Y,
TLMSetGetPixel(data^).PixColor);
GDKColor:=AllocGDKColor(TLMSetGetPixel(data^).PixColor);
//writeln('SetPixel: Color=',HexStr(TLMSetGetPixel(data^).PixColor,8),' GDKColor=',HexStr(GDKColor.Pixel,8));
gdk_image_put_pixel(Image,TLMSetGetPixel(data^).X,TLMSetGetPixel(data^).Y,
GDKColor.Pixel);
gtk_Object_set_data(pgtkobject(Widget),'Image',Image);
widget := GetFixedWidget(Widget);
fWindow := pGtkWidget(widget)^.window;
//gc := gdk_gc_new(PgdkWindow(fWindow));
gdk_draw_image(fwindow,
PGtkStyle(widget^.TheStyle)^.fg_gc[GTK_WIDGET_STATE (widget)],
pFixed := GetFixedWidget(Widget);
if pFixed <> nil then Widget:=PgtkWidget(pFixed);
fWindow := pGtkWidget(Widget)^.window;
gdk_draw_image(fwindow,
PGtkStyle(widget^.TheStyle)^.fg_gc[GTK_WIDGET_STATE (Widget)],
Image,
TLMSetGetPixel(data^).X,TLMSetGetPixel(data^).Y,
TLMSetGetPixel(data^).X,TLMSetGetPixel(data^).Y,
TLMSetGetPixel(Data^).X,TLMSetGetPixel(data^).Y,
TLMSetGetPixel(Data^).X,TLMSetGetPixel(data^).Y,
1,1);
end;
@ -2483,22 +2490,27 @@ end;
------------------------------------------------------------------------------}
procedure TgtkObject.GetPixel(Sender : TObject; Data : Pointer);
var
Image : pGDKImage;
widget : PgtkWidget;
WasNil : Boolean;
PDC : PDeviceContext;
Image : pGDKImage;
Widget : PgtkWidget;
GDKColorIndex: Cardinal;
begin
Widget := PgtkWidget(TCanvas(sender).Handle);
PDC := PDeviceContext(TCanvas(Sender).Handle);
if PDC = nil then exit;
Widget := PgtkWidget(PDC^.HWnd);
Image := gtk_Object_get_data(pgtkobject(widget),'Image');
if Image = nil then
begin
WasNil := True;
Image := gdk_image_get(pgtkWidget(widget)^.window,0,0,widget^.allocation.width,widget^.allocation.height);
end;
Image := gtk_Object_get_data(pgtkobject(Widget),'Image');
if Image = nil then begin
Image := gdk_image_get(pgtkWidget(widget)^.window,0,0,
widget^.allocation.width,widget^.allocation.height);
if Image = nil then exit;
gtk_Object_set_data(pgtkobject(Widget),'Image',Image);
end;
TLMSetGetPixel(data^).PixColor := gdk_image_get_pixel(Image,TLMSetGetPixel(data^).X,TLMSetGetPixel(data^).Y);
If WasNil then gtk_Object_set_data(pgtkobject(Widget),'Image',Image);
GDKColorIndex := gdk_image_get_pixel(Image,
TLMSetGetPixel(data^).X,TLMSetGetPixel(data^).Y);
TLMSetGetPixel(data^).PixColor := GDKColorIDToRGB(GDKColorIndex);
end;
{------------------------------------------------------------------------------
@ -3038,6 +3050,9 @@ end;
{ =============================================================================
$Log$
Revision 1.57 2001/10/07 07:28:34 lazarus
MG: fixed setpixel and TCustomForm.OnResize event
Revision 1.56 2001/09/30 08:34:52 lazarus
MG: fixed mem leaks and fixed range check errors

35
lcl/interfaces/gtk/gtkproc.inc
View File

@ -34,8 +34,8 @@ begin
end;
{------------------------------------------------------------------------------
Function: CreateGDKColor
Params: AColor: A RGB color
Function: AllocGDKColor
Params: AColor: A RGB color (TColor)
Returns: an Allocated GDKColor
Allocated a GDKColor from a winapi color
@ -51,6 +51,30 @@ begin
gdk_colormap_alloc_color(gdk_colormap_get_system, @Result, False, True);
end;
{------------------------------------------------------------------------------
Function: GDKColorIDToRGB
Params: AGDKColorID: A GDK color index
Returns: a RGB color (TColor)
------------------------------------------------------------------------------}
function GDKColorIDToRGB(AGDKColorID: cardinal): LongInt;
//var AColor: TGDKColor;
begin
//writeln('[GDKColorIDToRGB] ID=',HexStr(AGDKColorID,8),' ',gdk_colormap_get_system_size);
Result:=AGDKColorID;
exit;
{ MG: I don't know what the AGDKColorID from gdk_image_get_pixel is.
if AGDKColorID >= cardinal(gdk_colormap_get_system_size) then
Result:=0
else begin
AColor:=gdk_colormap_get_system^.Colors[AGDKColorID];
Result := (AColor.Red shr 8) or (AColor.Green and $ff00)
or ((AColor.Blue and $ff00) shl 8);
end;
}
end;
{------------------------------------------------------------------------------
Function: CopyDCData
Params: DestinationDC: a dc to copy data to
@ -625,8 +649,10 @@ end;
procedure SetFixedWidget(const ParentWidget, FixedWidget: Pointer);
begin
//writeln('[gtkproc: SetFixedWidget] Parent=',HexStr(Cardinal(ParentWidget),8),
//' Fixed=',HexStr(Cardinal(FixedWidget),8));
if (ParentWidget <> nil) and (FixedWidget <> nil) then
gtk_object_set_data(ParentWidget, 'Fixed', FixedWidget);
gtk_object_set_data(ParentWidget, 'Fixed', FixedWidget);
end;
// ----------------------------------------------------------------------
@ -745,6 +771,9 @@ end;
{ =============================================================================
$Log$
Revision 1.21 2001/10/07 07:28:34 lazarus
MG: fixed setpixel and TCustomForm.OnResize event
Revision 1.20 2001/09/30 08:34:52 lazarus
MG: fixed mem leaks and fixed range check errors