paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-05-23 17:45:04 +02:00
Code Issues Packages Projects Releases Wiki Activity
41ff3efef6
lazarus/lcl/interfaces/gtk/gtkwinapi.inc
lazarus 41ff3efef6 MG: improved TScreen and ShowModal 
git-svn-id: trunk@1882 -
2002-08-17 23:39:34 +00:00

7195 lines
228 KiB
PHP
Raw Blame History

{******************************************************************************
All GTK Winapi implementations.
Initial Revision : Sat Nov 13 12:53:53 1999
!! Keep alphabetical !!
Support routines go to gtkproc.pp
******************************************************************************
Implementation
******************************************************************************
*****************************************************************************
* *
* This file is part of the Lazarus Component Library (LCL) *
* *
* See the file COPYING.LCL, included in this distribution, *
* for details about the copyright. *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
* *
*****************************************************************************
}
{$IFOPT C-}
// Uncomment for local trace
// {$C+}
// {$DEFINE ASSERT_IS_ON}
{$EndIf}
const
SYes = 'Yes';
SNo = 'No';
SOK = 'OK';
SCancel = 'Cancel';
SAbort = 'Abort';
SRetry = 'Retry';
SIgnore = 'Ignore';
const
BOOL_TEXT: array[Boolean] of string = ('False', 'True');
//##apiwiz##sps## // Do not remove
{------------------------------------------------------------------------------
Method: Arc
Params: x,y,width,height,angle1,angle2
Returns: Nothing
Use Arc to draw an elliptically curved line with the current Pen.
The angles angle1 and angle2 are 1/16th of a degree. For example, a full
circle equals 5760 (16*360). Positive values of Angle and AngleLength mean
counter-clockwise while negative values mean clockwise direction.
Zero degrees is at the 3'o clock position.
------------------------------------------------------------------------------}
function TgtkObject.Arc(DC: HDC;
x,y,width,height,angle1,angle2 : Integer): Boolean;
var
DCOrigin: TPoint;
begin
Result := IsValidDC(DC);
if Result
then with PDeviceContext(DC)^ do
begin
if GC = nil
then begin
WriteLn('WARNING: [TgtkObject.Arc] Uninitialized GC');
Result := False;
end
else begin
// Draw outline
SelectGDKPenProps(DC);
DCOrigin:=GetDCOffset(PDeviceContext(DC));
inc(X,DCOrigin.X);
inc(Y,DCOrigin.Y);
gdk_draw_arc(Drawable, GC, 0, X, Y, Width, Height,
Angle1 shl 2, Angle2 shl 2);
Result := True;
end;
end;
end;
{------------------------------------------------------------------------------
Method: AngleChord
Params: DC,x,y,width,height,angle1,angle2
Returns: Nothing
Use AngleChord to draw a filled Chord-shape on the canvas. The angles angle1
and angle2 are 1/16th of a degree. For example, a full circle equals 5760
16*360). Positive values of Angle and AngleLength mean counter-clockwise while
negative values mean clockwise direction. Zero degrees is at the 3'o clock
position.
------------------------------------------------------------------------------}
function TgtkObject.AngleChord(DC: HDC;
x,y,width,height,angle1,angle2 : Integer): Boolean;
begin
Result := IsValidDC(DC);
if Result
then with PDeviceContext(DC)^ do
begin
if GC = nil
then begin
WriteLn('WARNING: [TgtkObject.AngleChord] Uninitialized GC');
Result := False;
end
else
Result := Inherited AngleChord(DC, x, y, width, height, angle1, angle2);
end;
end;
{------------------------------------------------------------------------------
Function: BitBlt
Params: DestDC: The destination devicecontext
X, Y: The left/top corner of the destination rectangle
Width, Height: The size of the destination rectangle
SrcDC: The source devicecontext
XSrc, YSrc: The left/top corner of the source rectangle
Rop: The raster operation to be performed
Returns: True if succesful
The BitBlt function copies a bitmap from a source context into a destination
context using the specified raster operation.
------------------------------------------------------------------------------}
function TgtkObject.BitBlt(DestDC: HDC; X, Y, Width, Height: Integer;
SrcDC: HDC; XSrc, YSrc: Integer; Rop: DWORD): Boolean;
begin
Result := StretchBlt(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, Width,
Height, ROP);
end;
{------------------------------------------------------------------------------
Function: BringWindowToTop
Params: hWnd:
Returns:
------------------------------------------------------------------------------}
Function TGTKObject.BringWindowToTop(hWnd : HWND): Boolean;
begin
//hwnd should be a PgtkWidget.
Result := True;
try
gdk_window_raise(PgtkWidget(hwnd)^.window);
except
on E: Exception do begin
writeln('TGTKObject.BringWindowToTop: ',E.Message);
Result := False;
end;
end;
end;
{------------------------------------------------------------------------------
Function: CallNextHookEx
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.CallNextHookEx(hhk : HHOOK; ncode : Integer; wParam, lParam : Longint) : Integer;
begin
Result := 0;
//TODO: Does anything need to be done here?
Assert(False, 'Trace:!!!!!!!!!!!!!!!!!!');
Assert(False, 'Trace:!!!!!!!!!!!!!!!!!!');
Assert(False, 'Trace:TODO: CALLNEXTHOOKEX in gtkwinapi.inc');
Assert(False, 'Trace:!!!!!!!!!!!!!!!!!!');
Assert(False, 'Trace:!!!!!!!!!!!!!!!!!!');
end;
{------------------------------------------------------------------------------
Function: CallWindowProc
Params: lpPrevWndFunc:
Handle:
Msg:
wParam:
lParam:
Returns:
------------------------------------------------------------------------------}
Function TGTKObject.CallWindowProc(lpPrevWndFunc : TFarProc; Handle : HWND;
Msg : UINT; wParam ,lParam : LongInt) : Integer;
var
Proc : TWndMethod;
Mess : TLMessage;
P : Pointer;
begin
Result := -1;
if Handle = 0 then Exit;
Result := -1;
P := nil;
P := gtk_object_get_data(pgtkobject(Handle),'WNDPROC');
if P <> nil then
Proc := TWndMethod(P^)
else
Exit;
Mess.msg := msg;
Mess.LParam := LParam;
Mess.WParam := WParam;
Proc(Mess);
Result := Mess.Result;
end;
{------------------------------------------------------------------------------
Function: CheckMenuItem
Params: hndMenu: HMENU; uIDEnableItem: Integer; bChecked: Boolean
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.CheckMenuItem(hndMenu: HMENU; uIDEnableItem: Integer;
bChecked: Boolean): Boolean;
var
LCLMenuItem: TMenuItem;
begin
if GTK_IS_CHECK_MENU_ITEM(Pointer(hndMenu)) then begin
gtk_check_menu_item_set_active(PGtkCheckMenuItem(hndMenu),bChecked);
Result:=true;
end else begin
LCLMenuItem:=TMenuItem(GetLCLObject(Pointer(hndMenu)));
if LCLMenuItem<>nil then begin
LCLMenuItem.RecreateHandle;
Result := true;
end else
Result := false;
end;
end;
{------------------------------------------------------------------------------
Function: ClientToScreen
Params: Handle : HWND; var P : TPoint
Returns: Nothing
------------------------------------------------------------------------------}
Function TgtkObject.ClientToScreen(Handle : HWND; var P : TPoint) : Boolean;
var
Position: TPoint;
Begin
if Handle = 0
then begin
Position.X := 0;
Position.Y := 0;
end
else begin
Position:=GetWidgetClientOrigin(PGtkWidget(Handle));
end;
// Todo: calculate offset, since platform specific
Inc(P.X, Position.X);
Inc(P.Y, Position.Y);
Assert(False, Format('Trace: [GTKObject.ClientToScreen] Handle: 0x%x --> (%d, %d)', [Integer(Handle), P.X, P.y]));
Result := True;
end;
{------------------------------------------------------------------------------
Function: ClipboardFormatToMimeType
Params: FormatID - a registered format identifier (0 is invalid)
Returns: the corresponding mime type as string
------------------------------------------------------------------------------}
function TgtkObject.ClipboardFormatToMimeType(
FormatID: TClipboardFormat): string;
var p: PChar;
begin
if FormatID<>0 then begin
p:=gdk_atom_name(FormatID);
Result:=StrPas(p);
g_free(p);
end else
Result:='';
end;
{------------------------------------------------------------------------------
Function: ClipboardGetData
Params: ClipboardType
FormatID - a registered format identifier (0 is invalid)
Stream - If format is available, it will be appended to this stream
Returns: true on success
------------------------------------------------------------------------------}
function TgtkObject.ClipboardGetData(ClipboardType: TClipboardType;
FormatID: TClipboardFormat; Stream: TStream): boolean;
type
PGdkAtom = ^TGdkAtom;
var FormatAtom, FormatTry: Cardinal;
SupportedCnt, i: integer;
SupportedFormats: PGdkAtom;
SelData: TGtkSelectionData;
CompoundTextList: PPGChar;
CompoundTextCount: integer;
function IsFormatSupported(Format: cardinal): boolean;
var a: integer;
AllID: cardinal;
begin
if Format=0 then begin
Result:=false;
exit;
end;
if SupportedCnt<0 then begin
Result:=false;
AllID:=gdk_atom_intern('TARGETS',0);
SelData:=RequestSelectionData(ClipboardWidget,ClipboardType,AllID);
{writeln('BBB2.2 ',HexStr(Cardinal(SelData.Selection),8),
' ',HexStr(Cardinal(ClipboardTypeAtoms[ClipboardType]),8),
' SelData.Target=',SelData.Target,' AllID=',AllID,
' SelData.TheType=',SelData.TheType,' ',gdk_atom_intern('ATOM',0),
' SelData.Length=',SelData.Length,
' SelData.Format=',SelData.Format
);}
if (SelData.Selection<>ClipboardTypeAtoms[ClipboardType])
or (SelData.Target<>AllID)
or (SelData.TheType<>gdk_atom_intern('ATOM',0)) then begin
SupportedCnt:=0;
exit;
end;
SupportedCnt:=SelData.Length div (SelData.Format shr 3);
SupportedFormats:=PGdkAtom(SelData.Data);
end;
a:=SupportedCnt-1;
while (a>=0) and (SupportedFormats[a]<>Format) do dec(a);
Result:=(a>=0);
end;
begin
{$IfDef DEBUG_CLIPBOARD}
writeln('[TgtkObject.ClipboardGetData] A ClipboardWidget=',HexStr(Cardinal(ClipboardWidget),8),' Format=',ClipboardFormatToMimeType(FormatID));
{$EndIf}
Result:=false;
if (FormatID=0) or (Stream=nil) then exit;
if not (ClipboardType in [ctPrimarySelection,ctSecondarySelection,ctClipboard])
then exit;
// request the data from the selection owner
SupportedCnt:=-1;
SupportedFormats:=nil;
try
FormatAtom:=FormatID;
if (FormatAtom=gdk_atom_intern('text/plain',1)) then begin
// text/plain is supported in various formats in gtk
// The COMPOUND_TEXT format supports internationalization and is therefore
// preferred even before 'text/plain'
FormatAtom:=0;
FormatTry:=gdk_atom_intern('COMPOUND_TEXT',1);
if IsFormatSupported(FormatTry) then
FormatAtom:=FormatTry;
if (SupportedCnt=0) then
FormatAtom:=gdk_atom_intern('COMPOUND_TEXT',1);
// then check for simple text format 'text/plain'
FormatTry:=gdk_atom_intern('text/plain',1);
if (FormatAtom=0) and IsFormatSupported(FormatTry) then
FormatAtom:=FormatTry;
// then check for simple text format STRING
FormatTry:=gdk_atom_intern('STRING',1);
if (FormatAtom=0) and IsFormatSupported(FormatTry) then
FormatAtom:=FormatTry;
// check for some other formats that can be interpreted as text
FormatTry:=gdk_atom_intern('FILE_NAME',1);
if (FormatAtom=0) and IsFormatSupported(FormatTry) then
FormatAtom:=FormatTry;
FormatTry:=gdk_atom_intern('HOST_NAME',1);
if (FormatAtom=0) and IsFormatSupported(FormatTry) then
FormatAtom:=FormatTry;
FormatTry:=gdk_atom_intern('USER',1);
if (FormatAtom=0) and IsFormatSupported(FormatTry) then
FormatAtom:=FormatTry;
// the TEXT format is not reliable, but it should be supported
FormatTry:=gdk_atom_intern('TEXT',1);
if (FormatAtom=0) and IsFormatSupported(FormatTry) then
FormatAtom:=FormatTry;
end;
{$IfDef DEBUG_CLIPBOARD}
writeln('[TgtkObject.ClipboardGetData] B Format=',ClipboardFormatToMimeType(FormatAtom));
{$EndIf}
if FormatAtom=0 then exit;
// request data from owner
SelData:=RequestSelectionData(ClipboardWidget,ClipboardType,FormatAtom);
try
{$IfDef DEBUG_CLIPBOARD}
writeln('[TgtkObject.ClipboardGetData] C Length=',SelData.Length);
{$EndIf}
if (SelData.Selection<>ClipboardTypeAtoms[ClipboardType])
or (SelData.Target<>FormatAtom) then
exit;
// write data to stream
if (SelData.Data<>nil) and (SelData.Length>0) then begin
if (FormatID=gdk_atom_intern('text/plain',1)) then begin
// the lcl expects the return format as simple text
// transform if necessary
if FormatAtom=gdk_atom_intern('COMPOUND_TEXT',1) then begin
CompoundTextCount:=gdk_text_property_to_text_list(SelData.theType,
SelData.Format,SelData.Data,SelData.Length,@CompoundTextList);
{$IfDef DEBUG_CLIPBOARD}
writeln('[TgtkObject.ClipboardGetData] D CompoundTextCount=',CompoundTextCount);
{$EndIf}
for i:=0 to CompoundTextCount-1 do
if (CompoundTextList[i]<>nil) then
Stream.Write(CompoundTextList[i]^,StrLen(CompoundTextList[i]));
gdk_free_text_list(CompoundTextList);
end else
Stream.Write(SelData.Data^,SelData.Length);
end else begin
Stream.Write(SelData.Data^,SelData.Length);
end;
end;
{$IfDef DEBUG_CLIPBOARD}
writeln('[TgtkObject.ClipboardGetData] END');
{$EndIf}
finally
if SelData.Data<>nil then FreeMem(SelData.Data);
end;
Result:=true;
finally
if SupportedFormats<>nil then FreeMem(SupportedFormats);
end;
end;
{------------------------------------------------------------------------------
Function: ClipboardGetFormats
Params: ClipboardType
Returns: true on success
Count contains the number of supported formats
List is an array of TClipboardType
! List will be created. You must free it yourself with FreeMem(List) !
------------------------------------------------------------------------------}
function TGtkObject.ClipboardGetFormats(ClipboardType: TClipboardType;
var Count: integer; var List: PClipboardFormat): boolean;
type
PGdkAtom = ^TGdkAtom;
var AllID: cardinal;
FormatAtoms: PGdkAtom;
Cnt, i: integer;
AddTextPlain: boolean;
SelData: TGtkSelectionData;
function IsFormatSupported(Format: cardinal): boolean;
var a: integer;
begin
if Format<>0 then begin
for a:=0 to Cnt-1 do begin
{$IfDef DEBUG_CLIPBOARD}
writeln(' IsFormatSupported ',Format,' ',FormatAtoms[a]);
{$EndIf}
if FormatAtoms[a]=Format then begin
Result:=true;
exit;
end;
end;
end;
Result:=false;
end;
function IsFormatSupported(Formats: TGtkClipboardFormats): boolean;
var Format: TGtkClipboardFormat;
begin
for Format:=Low(TGtkClipboardFormat) to High(TGtkClipboardFormat) do
if (Format in Formats)
and (IsFormatSupported(
gdk_atom_intern(PGChar(GtkClipboardFormatName[Format]),1)))
then begin
Result:=true;
exit;
end;
Result:=false;
end;
begin
{$IfDef DEBUG_CLIPBOARD}
writeln('[TgtkObject.ClipboardGetFormats] A ClipboardWidget=',HexStr(Cardinal(ClipboardWidget),8));
{$EndIf}
Result:=false;
Count:=0;
List:=nil;
if not (ClipboardType in [ctPrimarySelection,ctSecondarySelection,ctClipboard])
then exit;
// request the list of supported formats from the selection owner
AllID:=gdk_atom_intern('TARGETS',0);
SelData:=RequestSelectionData(ClipboardWidget,ClipboardType,AllID);
try
{$IfDef DEBUG_CLIPBOARD}
writeln('[TgtkObject.ClipboardGetFormats] A2 ',AllID);
{$EndIf}
if (SelData.Selection<>ClipboardTypeAtoms[ClipboardType])
or (SelData.Target<>AllID)
or (SelData.TheType<>gdk_atom_intern('ATOM',0)) then
exit;
Cnt:=SelData.Length div (SelData.Format shr 3);
if (SelData.Data<>nil) and (Cnt>0) then begin
Count:=Cnt;
FormatAtoms:=PGdkAtom(SelData.Data);
// add transformable lcl formats
// for example: the lcl expects text as 'text/plain', but gtk applications
// also knows 'TEXT' and 'STRING'. These formats can automagically
// transformed into the lcl format, so the lcl format is also supported
// and will be added to the list
AddTextPlain:=false;
if (not IsFormatSupported(gdk_atom_intern('text/plain',1)))
and (IsFormatSupported([gfCOMPOUND_TEXT,gfTEXT,gfSTRING,gfFILE_NAME,
gfHOST_NAME,gfUSER]))
then begin
AddTextPlain:=true;
inc(Count);
end;
// copy normal supported formats
GetMem(List,SizeOf(TClipboardFormat)*Count);
i:=0;
while (i<Cnt) do begin
{$IfDef DEBUG_CLIPBOARD}
writeln(' ',i,': ',FormatAtoms[i]);
writeln(' "',ClipboardFormatToMimeType(FormatAtoms[i]),'"');
{$EndIf}
List[i]:=FormatAtoms[i];
inc(i);
end;
// add all lcl formats that the gtk-interface can transform from the
// supported formats
if AddTextPlain then begin
List[i]:=gdk_atom_intern('text/plain',0);
inc(i);
end;
end;
finally
if SelData.Data<>nil then FreeMem(SelData.Data);
end;
Result:=true;
end;
{------------------------------------------------------------------------------
Function: ClipboardGetOwnerShip
Params: ClipboardType
OnRequestProc - TClipboardRequestEvent is defined in LCLLinux.pp
If OnRequestProc is nil the onwership will end.
FormatCount - number of formats
Formats - array of TClipboardFormat. The supported formats the owner
provides.
Returns: true on success
Sets the supported formats and requests ownership for the clipboard.
Each time the clipboard is read the OnRequestProc will be executed.
If someone else requests the ownership, the OnRequestProc will be executed
with the invalid FormatID 0 to notify the old owner of the lost of ownership.
------------------------------------------------------------------------------}
function TgtkObject.ClipboardGetOwnerShip(ClipboardType: TClipboardType;
OnRequestProc: TClipboardRequestEvent; FormatCount: integer;
Formats: PClipboardFormat): boolean;
var TargetEntries: PGtkTargetEntry;
function IsFormatSupported(FormatID: integer): boolean;
var i: integer;
begin
if FormatID=0 then begin
Result:=false;
exit;
end;
i:=FormatCount-1;
while (i>=0) and (Formats[i]<>FormatID) do dec(i);
Result:=(i>=0);
end;
procedure AddTargetEntry(var Index: integer; const FormatName: string);
begin
{$IfDef DEBUG_CLIPBOARD}
writeln(' AddTargetEntry ',FormatName);
{$EndIf}
TargetEntries[Index].Target := StrAlloc(Length(FormatName) + 1);
StrPCopy(TargetEntries[Index].Target, FormatName);
TargetEntries[Index].Info:=Index;
inc(Index);
end;
type
TAddedFormats = array[TGtkClipboardFormat] of boolean;
{function TgtkObject.ClipboardGetOwnerShip(ClipboardType: TClipboardType;
OnRequestProc: TClipboardRequestEvent; FormatCount: integer;
Formats: PClipboardFormat): boolean;}
var
TargetEntriesSize, i: integer;
gtkFormat: TGtkClipboardFormat;
ExpFormatCnt: integer;
OldClipboardWidget: PGtkWidget;
begin
if ClipboardType in [ctPrimarySelection, ctSecondarySelection, ctClipboard] then
begin
{$IfDef DEBUG_CLIPBOARD}
writeln('[TgtkObject.ClipboardGetOwnerShip] A');
{$EndIf}
ClipboardHandler[ClipboardType]:=nil;
Result:=false;
if (ClipboardWidget=nil) or (FormatCount=0) or (Formats=nil) then
begin
// end ownership
if (ClipBoardWidget <> nil) and
(gdk_selection_owner_get(ClipboardTypeAtoms[ClipboardType]) = ClipboardWidget^.window) then
begin
gtk_selection_owner_set(nil,ClipboardTypeAtoms[ClipboardType],0);
end;
Result:=true;
exit;
end;
// registering targets
FreeClipboardTargetEntries(ClipboardType);
// the gtk-interface adds automatically some gtk formats the lcl does not
// know
ExpFormatCnt:=FormatCount;
for gtkFormat:=Low(TGtkClipboardFormat) to High(TGtkClipboardFormat) do
ClipboardExtraGtkFormats[ClipboardType][gtkFormat]:=false;
{$IfDef DEBUG_CLIPBOARD}
writeln('[TgtkObject.ClipboardGetOwnerShip] B');
{$EndIf}
if IsFormatSupported(gdk_atom_intern('text/plain',1)) then
begin
// lcl provides 'text/plain' and the gtk-interface will automatically
// provide some more text formats
ClipboardExtraGtkFormats[ClipboardType][gfCOMPOUND_TEXT]:=
not IsFormatSupported(
gdk_atom_intern(PGChar(GtkClipboardFormatName[gfCOMPOUND_TEXT]),0));
ClipboardExtraGtkFormats[ClipboardType][gfSTRING]:=not IsFormatSupported(
gdk_atom_intern(PGChar(GtkClipboardFormatName[gfSTRING]),0));
ClipboardExtraGtkFormats[ClipboardType][gfTEXT]:=not IsFormatSupported(
gdk_atom_intern(PGChar(GtkClipboardFormatName[gfTEXT]),0));
end;
for gtkFormat:=Low(TGtkClipboardFormat) to High(TGtkClipboardFormat) do
if ClipboardExtraGtkFormats[ClipboardType][gtkFormat] then
inc(ExpFormatCnt);
// build TargetEntries
TargetEntriesSize:=SizeOf(TGtkTargetEntry) * ExpFormatCnt;
GetMem(TargetEntries,TargetEntriesSize);
FillChar(TargetEntries^,TargetEntriesSize,0);
i:=0;
while i<FormatCount do
AddTargetEntry(i,ClipboardFormatToMimeType(Formats[i]));
for gtkFormat:=Low(TGtkClipboardFormat) to High(TGtkClipboardFormat) do
if ClipboardExtraGtkFormats[ClipboardType][gtkFormat] then
AddTargetEntry(i,GtkClipboardFormatName[gtkFormat]);
// set the supported formats
ClipboardTargetEntries[ClipboardType]:=TargetEntries;
ClipboardTargetEntryCnt[ClipboardType]:=ExpFormatCnt;
// reset the clipboard widget (this will set the new target list)
OldClipboardWidget:=ClipboardWidget;
SetClipboardWidget(nil);
SetClipboardWidget(OldClipboardWidget);
// taking the ownership
{$IfDef DEBUG_CLIPBOARD}
writeln('[TgtkObject.ClipboardGetOwnerShip] C');
{$EndIf}
if gtk_selection_owner_set(ClipboardWidget, ClipboardTypeAtoms[ClipboardType],0)=0 then
begin
{$IfDef DEBUG_CLIPBOARD}
writeln('[TgtkObject.ClipboardGetOwnerShip] D FAILED');
{$EndIf}
exit;
end;
{$IfDef DEBUG_CLIPBOARD}
writeln('[TgtkObject.ClipboardGetOwnerShip] YEAH, got it!');
{$EndIf}
ClipboardHandler[ClipboardType]:=OnRequestProc;
Result:=true;
end else
{ the gtk does not support this kind of clipboard, so the application can
have the ownership at any time. The TClipboard in clipbrd.pp has an
internal cache system, so that an application can use all types of
clipboards even if the underlying platform does not support it.
Of course this will only be a local clipboard, invisible to other
applications. }
Result:=true;
end;
{------------------------------------------------------------------------------
Function: ClipboardRegisterFormat
Params: AMimeType
Returns: the registered Format identifier (TClipboardFormat)
------------------------------------------------------------------------------}
function TgtkObject.ClipboardRegisterFormat(
const AMimeType:String): TClipboardFormat;
var AtomName: PChar;
begin
if Assigned(Application) then begin
AtomName:=PChar(AMimeType);
Result:=gdk_atom_intern(AtomName,0);
end else
raise Exception.Create(
'ERROR: TgtkObject.ClipboardRegisterFormat gdk not initialized');
end;
{------------------------------------------------------------------------------
Function: CreateBitmap
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.CreateBitmap(Width, Height: Integer;
Planes, BitCount: Longint; BitmapBits: Pointer): HBITMAP;
var
GdiObject: PGdiObject;
//RawImage: PGDIRawImage;
begin
Assert(False, Format('Trace:> [TgtkObject.CreateBitmap] Width: %d, Height: %d, Planes: %d, BitCount: %d, BitmapBits: 0x%x', [Width, Height, Planes, BitCount, Longint(BitmapBits)]));
if (BitCount < 1) or (Bitcount > 32)
then begin
Result := 0;
WriteLn(Format('ERROR: [TgtkObject.CreateBitmap] Illegal depth %d', [BitCount]));
Exit;
end;
//write('TgtkObject.CreateBitmap->');
GdiObject := NewGDIObject(gdiBitmap);
// if the bitcount is the system depth create a Pixmap
// if depth is 1 then a Bitmap
// else an image
if BitCount = gdk_visual_get_system^.Depth
then begin
Assert(False, Format('Trace: [TgtkObject.CreateBitmap] gbPixmap', []));
GdiObject^.GDIBitmapType := gbPixmap;
GdiObject^.GDIPixmapObject := gdk_pixmap_new(nil, Width, Height, BitCount);
end
else if Bitcount = 1
then begin
Assert(False, Format('Trace: [TgtkObject.CreateBitmap] gbBitmap', []));
GdiObject^.GDIBitmapType := gbBitmap;
GdiObject^.GDIBitmapObject := gdk_pixmap_new(nil, Width, Height, BitCount);
end
else begin
Assert(False, Format('Trace: [TgtkObject.CreateBitmap] gbImage', []));
GdiObject^.GDIBitmapType := gbImage;
GdiObject^.GDIRawImageObject := NewGDIRawImage(Width, Height, BitCount);
end;
Result := HBITMAP(GdiObject);
//writeln('[TgtkObject.CreateBitmap] ',HexStr(Result,8));
Assert(False, Format('Trace:< [TgtkObject.CreateBitmap] --> 0x%x', [Integer(Result)]));
end;
{------------------------------------------------------------------------------
Function: CreateBrushIndirect
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.CreateBrushIndirect(const LogBrush: TLogBrush): HBRUSH;
const
HATCH_NULL : array[0..7] of Byte = ($00, $00, $00, $00, $00, $00, $00, $00);
HATCH_BDIAGONAL : array[0..7] of Byte = ($80, $40, $20, $10, $08, $04, $02, $01);
HATCH_CROSS : array[0..7] of Byte = ($22, $22, $FF, $22, $22, $22, $FF, $22);
HATCH_DIAGCROSS : array[0..7] of Byte = ($81, $42, $24, $18, $18, $24, $42, $81);
HATCH_FDIAGONAL : array[0..7] of Byte = ($01, $02, $04, $08, $10, $20, $40, $80);
HATCH_HORIZONTAL: array[0..7] of Byte = ($00, $00, $00, $00, $FF, $00, $00, $00);
HATCH_VERTICAL : array[0..7] of Byte = ($08, $08, $08, $08, $08, $08, $08, $08);
var
GObject: PGdiObject;
sError: String;
begin
Assert(False, Format('Trace:> [TgtkObject.CreateBrushIndirect] Style: %d, Color: %8x', [LogBrush.lbStyle, LogBrush.lbColor]));
sError := '';
//write('CreateBrushIndirect->');
GObject := NewGDIObject(gdiBrush);
//writeln('[TgtkObject.CreateBrushIndirect] ',HexStr(Cardinal(GObject),8));
with LogBrush do
begin
case lbStyle of
// BS_HOLLOW, // Hollow brush.
BS_NULL: // Same as BS_HOLLOW.
begin
GObject^.GDIBrushFill := GDK_STIPPLED;
GObject^.GDIBrushPixmap :=
gdk_bitmap_create_from_data(nil, @HATCH_NULL, 8, 8);
end;
BS_SOLID: // Solid brush.
begin
GObject^.GDIBrushFill := GDK_SOLID;
end;
BS_HATCHED: // Hatched brush.
begin
GObject^.GDIBrushFill := GDK_STIPPLED;
case lbHatch of
HS_BDIAGONAL:
GObject^.GDIBrushPixmap := gdk_bitmap_create_from_data(
nil, @HATCH_BDIAGONAL, 8, 8);
HS_CROSS:
GObject^.GDIBrushPixmap := gdk_bitmap_create_from_data(
nil, @HATCH_CROSS, 8, 8);
HS_DIAGCROSS:
GObject^.GDIBrushPixmap := gdk_bitmap_create_from_data(
nil, @HATCH_DIAGCROSS, 8, 8);
HS_FDIAGONAL:
GObject^.GDIBrushPixmap := gdk_bitmap_create_from_data(
nil, @HATCH_FDIAGONAL, 8, 8);
HS_HORIZONTAL:
GObject^.GDIBrushPixmap := gdk_bitmap_create_from_data(
nil, @HATCH_HORIZONTAL, 8, 8);
HS_VERTICAL:
GObject^.GDIBrushPixmap := gdk_bitmap_create_from_data(
nil, @HATCH_VERTICAL, 8, 8);
else
sError := Format('WARNING: [TgtkObject.CreateBrushIndirect] Got unsupported Hatch %d', [lbHatch]);
end;
end;
BS_DIBPATTERN, // A pattern brush defined by a device-independent
// bitmap (DIB) specification. If lbStyle is BS_DIBPATTERN, the
// lbHatch member contains a handle to a packed DIB.Windows 95:
// Creating brushes from bitmaps or DIBs larger than 8x8 pixels
// is not supported. If a larger bitmap is given, only a portion
// of the bitmap is used.
BS_DIBPATTERN8X8, // Same as BS_DIBPATTERN.
BS_DIBPATTERNPT, // A pattern brush defined by a device-independent
// bitmap (DIB) specification. If lbStyle is BS_DIBPATTERNPT, the
// lbHatch member contains a pointer to a packed DIB.
BS_PATTERN, // Pattern brush defined by a memory bitmap.
BS_PATTERN8X8: // Same as BS_PATTERN.
begin
GObject^.GDIBrushFill := GDK_TILED;
if IsValidGDIObject(lbHatch) and (PGdiObject(lbHatch)^.GDIType = gdiBitmap)
then GObject^.GDIBrushPixmap := PGdiObject(lbHatch)^.GDIBitmapObject
else sError := 'WARNING: [TgtkObject.CreateBrushIndirect] Got unsupported bitmap';
end;
else
sError := Format('WARNING: [TgtkObject.CreateBrushIndirect] Got unsupported Style %d'
, [lbStyle]);
end;
with GObject^.GDIBrushColor do
begin
Red := ((lbColor shl 8) and $00FF00) or ((lbColor ) and $0000FF);
Green := ((lbColor ) and $00FF00) or ((lbColor shr 8 ) and $0000FF);
Blue := ((lbColor shr 8) and $00FF00) or ((lbColor shr 16) and $0000FF);
end;
gdk_colormap_alloc_color(gdk_colormap_get_system, @GObject^.GDIBrushColor, False, True);
with GObject^.GDIBrushColor do
Assert(False, Format('Trace: [TgtkObject.CreateBrushIndirect] Allocated R: %2x, G: %2x, B: %2x', [Red, Green, Blue]));
end;
if sError = '' then
Result := HBRUSH(GObject)
else begin
Assert(False, 'Trace:' + sError);
Result := 0;
DisposeGDIObject(GObject)
end;
Assert(False, Format('Trace:< [TgtkObject.CreateBrushIndirect] Got --> %x', [Result]));
end;
{------------------------------------------------------------------------------
Function: CreateCaret
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.CreateCaret(Handle: HWND; Bitmap: hBitmap;
Width, Height: Integer): Boolean;
var
GTKObject: PGTKObject;
BMP: PGDKPixmap;
begin
Assert(False, 'Trace:TODO: [TgtkObject.CreateCaret] Finish');
GTKObject := PGTKObject(Handle);
Result := GTKObject <> nil;
if Result then begin
if gtk_type_is_a(gtk_object_type(GTKObject), GTKAPIWidget_GetType)
then begin
if IsValidGDIObjectType(Bitmap, gdiBitmap) then
BMP := PGdiObject(Bitmap)^.GDIBitmapObject
else
BMP := nil;
GTKAPIWidget_CreateCaret(PGTKAPIWidget(GTKObject), Width, Height, BMP);
end
// else if // TODO: other widgettypes
else begin
Result := False;
end;
end
else Assert(False, 'Trace:WARNING: [TgtkObject.CreateCaret] Got null HWND');
end;
{------------------------------------------------------------------------------
Function: CreateCompatibleBitmap
Params: DC:
Width:
Height:
Returns:
Creates a bitmap compatible with the specified device context.
------------------------------------------------------------------------------}
function TGTKObject.CreateCompatibleBitmap(DC: HDC; Width, Height: Integer): HBITMAP;
var
Depth : Longint;
begin
Assert(False, Format('Trace:> [TgtkObject.CreateCompatibleBitmap] DC: 0x%x, W: %d, H: %d', [DC, Width, Height]));
Depth := -1;
if (IsValidDC(DC) and (PDeviceContext(DC)^.Drawable <> nil))
then begin
gdk_window_get_geometry(PDeviceContext(DC)^.Drawable, nil, nil, nil,
nil, @Depth);
If Depth = -1 then
Depth := gdk_visual_get_system^.Depth;
end
else Depth := gdk_visual_get_system^.Depth;
if Depth <> -1
then Result := CreateBitmap(Width, Height, 1, Depth, nil)
else Result := 0;
Assert(False, Format('Trace:< [TgtkObject.CreateCompatibleBitmap] DC: 0x%x --> 0x%x', [DC, Result]));
end;
{------------------------------------------------------------------------------
Function: CreateCompatibleDC
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.CreateCompatibleDC(DC: HDC): HDC;
var
pNewDC: PDeviceContext;
begin
Result := 0;
pNewDC := NewDC;
// dont copy
// In a compatible DC you have to select a bitmap into it
(*
if IsValidDC(DC) then
with PDeviceContext(DC)^ do
begin
pNewDC^.hWnd := hWnd;
pNewDC^.Drawable := Drawable;
pNewDC^.GC := gdk_gc_new(Drawable);
end
else begin
// We can't do anything yet
// Wait till a bitmap get selected
end;
*)
pNewDC^.CurrentFont := CreateDefaultFont;
pNewDC^.CurrentBrush := CreateDefaultBrush;
pNewDC^.CurrentPen := CreateDefaultPen;
Result := HDC(pNewDC);
Assert(False,Format('trace: [TgtkObject.CreateCompatibleDC] DC: 0x%x --> 0x%x', [Integer(DC), Integer(Result)]));
end;
{------------------------------------------------------------------------------
Function: CreateFontIndirect
Params: const LogFont: TLogFont
Returns: HFONT
Creates a font GDIObject.
------------------------------------------------------------------------------}
function TgtkObject.CreateFontIndirect(const LogFont: TLogFont): HFONT;
begin
Result:=CreateFontIndirectEx(LogFont,'');
end;
{------------------------------------------------------------------------------
Function: CreateFontIndirectEx
Params: const LogFont: TLogFont; const LongFontName: string
Returns: HFONT
Creates a font GDIObject.
------------------------------------------------------------------------------}
function TgtkObject.CreateFontIndirectEx(const LogFont: TLogFont;
const LongFontName: string): HFONT;
var
GdiObject: PGdiObject;
S: String;
FontNameRegistry, Foundry, FamilyName, WeightName,
Slant, SetwidthName, AddStyleName, PixelSize,
PointSize, ResolutionX, ResolutionY, Spacing, AverageWidth,
CharSetRegistry, CharSetCoding: string;
n: Integer;
procedure LoadFont;
begin
S := Format('%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s',
[FontNameRegistry, Foundry, FamilyName, WeightName,
Slant, SetwidthName, AddStyleName, PixelSize,
PointSize, ResolutionX, ResolutionY, Spacing, AverageWidth,
CharSetRegistry, CharSetCoding
]);
GdiObject^.GDIFontObject := gdk_font_load(PChar(s));
//writeln(' Trying "',S,'" Success=',GdiObject^.GDIFontObject<>nil);
end;
procedure LoadDefaultFont;
begin
DisposeGDIObject(GdiObject);
GdiObject:=CreateDefaultFont;
end;
begin
// For info about xlfd see:
// http://wwwinfo.cern.ch/umtf/working-groups/X11/fonts/hp_xlfd.html
// Lets fill in all the xlfd parts. Assume we have scalable fonts
Result := 0;
GDIObject := NewGDIObject(gdiFont);
try
GdiObject^.LogFont := LogFont;
// set default values
FontNameRegistry := '*';
Foundry := '*';
FamilyName := '*';
WeightName := '*';
Slant := '*';
SetwidthName := '*';
AddStyleName := '*';
PixelSize := '*';
PointSize := '*';
ResolutionX := '*';
ResolutionY := '*';
Spacing := '*';
AverageWidth := '*';
CharSetRegistry := '*';
CharSetCoding := '*';
// check if LongFontName is in XLFD format and get nicer defaults
// This way, the user can set X fonts that are not supported by TFont.
//writeln('TgtkObject.CreateFontIndirectEx Name="',LogFont.lfFaceName,'"',
//' Long="',LongFontName,'" ',IsFontNameXLogicalFontDesc(LongFontName)
//,' ',ord(LogFont.lfFaceName[0]));
S:=LongFontName;
if IsFontNameXLogicalFontDesc(LongFontName) then begin
FontNameRegistry := ExtractXLFDItem(LongFontName,0);
Foundry := ExtractXLFDItem(LongFontName,1);
FamilyName := ExtractXLFDItem(LongFontName,2);
WeightName := ExtractXLFDItem(LongFontName,3);
Slant := ExtractXLFDItem(LongFontName,4);
SetwidthName := ExtractXLFDItem(LongFontName,5);
AddStyleName := ExtractXLFDItem(LongFontName,6);
PixelSize := ExtractXLFDItem(LongFontName,7);
PointSize := ExtractXLFDItem(LongFontName,8);
ResolutionX := ExtractXLFDItem(LongFontName,9);
ResolutionY := ExtractXLFDItem(LongFontName,10);
Spacing := ExtractXLFDItem(LongFontName,11);
AverageWidth := ExtractXLFDItem(LongFontName,12);
CharSetRegistry := ExtractXLFDItem(LongFontName,13);
CharSetCoding := ExtractXLFDItem(LongFontName,14);
end;
with LogFont do
begin
if lfFaceName[0] = #0
then begin
Assert(false,'ERROR: [TgtkObject.CreateFontIndirectEx] No fontname');
Exit;
end;
FamilyName := StrPas(lfFaceName); //StringReplace(FaceName, ' ', '*');
if AnsiCompareText(FamilyName,'default')=0 then begin
LoadDefaultFont;
exit;
end;
Assert(False, Format('trace: [TgtkObject.CreateFontIndirectEx] Name: %s, Height: %d', [FamilyName, lfHeight]));
// calculate weight offset.
// API XLFD
// --------------------- --------------
// Weight=400 --> normal normal
// Weight=700 --> bold normal+4000 (or bold in non scalable fonts)
//
// So in API the offset for normal = 400 and an increase of 300 equals to
// an offset of 4000
if WeightName='*' then begin
case lfWeight of
FW_DONTCARE : WeightName := '*';
FW_LIGHT : WeightName := 'light';
FW_NORMAL : WeightName := 'normal';
FW_MEDIUM : WeightName := 'medium';
FW_SEMIBOLD : WeightName := 'demi bold';
FW_BOLD : WeightName := 'bold';
else begin
n := ((lfWeight - FW_NORMAL) * 4000) div (FW_BOLD - FW_NORMAL);
if n = 0
then WeightName := 'normal'
else if n > 0
then WeightName := Format('normal+%d', [n])
else WeightName := Format('normal%d', [n]);
end;
end;
end;
if Slant='*' then begin
// TODO: find out if escapement has something to do with slant
if lfItalic = 0 then Slant := 'r' else Slant := 'i';
end;
// SetwidthName := '*';
if AddStyleName='*' then begin
// calculate Style name extentions (=rotation)
// API XLFD
// --------------------- --------------
// Orientation 1/10 deg 1/64 deg
if lfOrientation = 0
then AddStyleName := '*'
else begin
n := (lfOrientation * 64) div 10;
if n >= 0
then AddStyleName := Format('+%d', [n])
else AddStyleName := Format('+%d', [n]);
end;
end;
if (PixelSize='*') and (PointSize='*') then begin
// TODO: make more accurate (implement the meaning of
// positive and negative heigtht values.
PixelSize := IntToStr(Abs(lfHeight));
// Since we use pixelsize, it isn't allowed to give a value here
PointSize := '*';
// Use the default
ResolutionX := '*';
ResolutionY := '*';
end;
if Spacing='*' then begin
// spacing
if (FIXED_PITCH and lfPitchAndFamily)>0 then
Spacing := 'm' // mono spaced
else if (VARIABLE_PITCH and lfPitchAndFamily)>0 then
Spacing := 'p' // proportional spaced
else
Spacing := '*';
end;
if AverageWidth='*' then begin
// calculate AverageWidth
// API XLFD
// --------------------- --------------
// Width pixel 1/10 pixel
if lfWidth = 0
then AverageWidth := '*'
else AverageWidth := InttoStr(lfWidth * 10);
end;
// CharSetRegistry := '*';
// TODO: Match charset.
// CharSetCoding := '*';
end;
//write('CreateFontIndirect->');
LoadFont;
if GdiObject^.GDIFontObject = nil
then begin
if (WeightName='normal') then begin
WeightName:='medium';
LoadFont;
end else if (WeightName='bold') then begin
WeightName:='black';
LoadFont;
end;
end;
if GdiObject^.GDIFontObject = nil
then begin
if (WeightName='medium') then begin
WeightName:='regular';
LoadFont;
end else if (WeightName='black') then begin
WeightName:='demi bold';
LoadFont;
end;
end;
if GdiObject^.GDIFontObject = nil
then begin
// try instead of mono spaced, character cell spaced
if (Spacing='m') then begin
Spacing:='c';
LoadFont;
end;
end;
if GdiObject^.GDIFontObject = nil
then begin
// try instead of italic oblique
if (Slant='i') then begin
Slant := 'o';
LoadFont;
end;
end;
if GdiObject^.GDIFontObject = nil
then begin
// try all weights
WeightName := '*';
LoadFont;
end;
if GdiObject^.GDIFontObject = nil
then begin
// try all slants
Slant := '*';
LoadFont;
end;
if GdiObject^.GDIFontObject = nil
then begin
// try all spacings
Spacing := '*';
LoadFont;
end;
if GdiObject^.GDIFontObject = nil
then begin
// try one height lower
PixelSize := IntToStr(Abs(LogFont.lfHeight)-1);
LoadFont;
end;
if GdiObject^.GDIFontObject = nil
then begin
// try one height higher
PixelSize := IntToStr(Abs(LogFont.lfHeight)+1);
LoadFont;
end;
if GdiObject^.GDIFontObject = nil
then begin
// try all Familys
PixelSize := IntToStr(Abs(LogFont.lfHeight));
FamilyName := '*';
LoadFont;
end;
if GdiObject^.GDIFontObject = nil
then begin
// try all Foundrys
Foundry := '*';
LoadFont;
end;
finally
if GdiObject^.GDIFontObject = nil
then begin
//writeln('[TgtkObject.CreateFontIndirect] ',HexStr(Cardinal(GdiObject),8),' ',FGDIObjects.Count);
DisposeGDIObject(GdiObject);
Result := 0;
end
else begin
Result := HFONT(GdiObject);
end;
if Result = 0
then WriteLn(Format('WARNING: [TgtkObject.CreateFontIndirectEx] NOT found XLFD: <%s>', [S]))
else Assert(False, Format('Trace: [TgtkObject.CreateFontIndirectEx] found XLFD: <%s>', [S]));
end;
end;
{------------------------------------------------------------------------------
Function: CreatePenIndirect
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.CreatePenIndirect(const LogPen: TLogPen): HPEN;
var
GObject: PGdiObject;
begin
Assert(False, 'trace:[TgtkObject.CreatePenIndirect]');
//write('CreatePenIndirect->');
GObject := NewGDIObject(gdiPen);
with LogPen do
begin
GObject^.GDIPenStyle := lopnStyle;
GObject^.GDIPenWidth := lopnWidth.X;
// with GObject^.GDIPenColor do
// begin
// Red := ((lopnColor shl 8) and $00FF00) or ((lopnColor ) and $0000FF);
// Green := ((lopnColor ) and $00FF00) or ((lopnColor shr 8 ) and $0000FF);
// Blue := ((lopnColor shr 8) and $00FF00) or ((lopnColor shr 16) and $0000FF);
// end;
// gdk_colormap_alloc_color(gdk_colormap_get_system, @GObject^.GDIPenColor, False, True);
GObject^.GDIPenColor := AllocGDKColor(lopnColor);
end;
Result := HPEN(GObject);
end;
{------------------------------------------------------------------------------
Function: CreatePixmapIndirect
Params: Data: Raw pixmap data (PPGChar fo xpm file)
Returns: Handle to LCL bitmap
Creates a bitmap from raw pixmap data.
If TransColor < 0 the transparency mask will be automatically gnerated.
------------------------------------------------------------------------------}
function TgtkObject.CreatePixmapIndirect(const Data: Pointer;
const TransColor: Longint): HBITMAP;
var
GdiObject: PGdiObject;
GDKColor: TGDKColor;
Window: PGdkWindow;
ColorMap: PGdkColormap;
P: Pointer;
begin
GdiObject := NewGDIObject(gdiBitmap);
if TransColor >= 0 then begin
GDKColor := AllocGDKColor(TransColor);
p := @GDKColor;
end else
p:=nil; // automatically create transparency mask
Window:=nil; // use the X root window for colormap
if Window<>nil then
ColorMap:=gdk_window_get_colormap(Window)
else
ColorMap:=gdk_colormap_get_system;
GdiObject^.GDIPixmapObject :=
gdk_pixmap_colormap_create_from_xpm_d(Window,Colormap,
@(GdiObject^.GDIBitmapMaskObject), p, Data);
GdiObject^.GDIBitmapType:=gbPixmap;
Result := HBITMAP(GdiObject);
end;
Function RegionType(RGN : PGDKRegion) : Longint;
var
aRect : TGDKRectangle;
rRGN : hRGN;
begin
If RGN = nil then
Result := ERROR
else
If gdk_region_empty(RGN) then
Result := NULLREGION
else begin
gdk_region_get_clipbox(RGN,@aRect);
With aRect do
rRGN := CreateRectRgn(X, Y, X + Width, Y + Height);
if gdk_region_equal(PGDIObject(rRGN)^.GDIRegionObject, RGN) then
Result := SIMPLEREGION
else
Result := COMPLEXREGION;
DeleteObject(rRGN);
end;
end;
{------------------------------------------------------------------------------
Method: CreatePolygonRgn
Params: Points, NumPts, Winding
Returns: the handle to the region
Creates a Polygon, a closed many-sided shaped region. The Points parameter is
an array of points that give the vertices of the polygon. Winding determines
what points are going to be included in the region. When Winding is True,
points are selected by using the Winding fill algorithm. When Winding is
False, points are selected by using using the even-odd (alternative) fill
algorithm. NumPts indicates the number of points to use.
The first point is always connected to the last point.
------------------------------------------------------------------------------}
Function TgtkObject.CreatePolygonRgn(Points: PPoint; NumPts: Integer;
Winding : Boolean): HRGN;
var
i: integer;
PointArray: PGDKPoint;
GObject: PGdiObject;
fr : TGDKFillRule;
begin
Result := 0;
if NumPts<=0 then exit;
GObject := NewGDIObject(gdiRegion);
GetMem(PointArray,SizeOf(TGdkPoint)*NumPts);
for i:=0 to NumPts-1 do begin
PointArray[i].x:=Points[i].x;
PointArray[i].y:=Points[i].y;
end;
If Winding then
fr := GDK_WINDING_RULE
else
fr := GDK_EVEN_ODD_RULE;
GObject^.GDIRegionObject := gdk_region_polygon(PointArray, NumPts, fr);
FreeMem(PointArray);
Result := HRGN(GObject);
end;
{------------------------------------------------------------------------------
Function: CreateRectRgn
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.CreateRectRgn(X1,Y1,X2,Y2 : Integer): HRGN;
var
R : TGDKRectangle;
RRGN : PGDKRegion;
GObject: PGdiObject;
begin
GObject := NewGDIObject(gdiRegion);
R.X := X1;
R.Y := Y1;
R.Width := X2 - X1;
R.Height := Y2 - Y1;
RRGN := GDK_Region_New;
GObject^.GDIRegionObject := gdk_region_union_with_rect(RRGN,@R);
gdk_region_destroy(RRGN);
Result := HRGN(GObject);
end;
{------------------------------------------------------------------------------
Function: CombineRgn
Params: Dest, Src1, Src2, fnCombineMode
Returns: longint
Combine the 2 Source Regions into the Destination Region using the specified
Combine Mode. The Destination must already be initialized. The Return value
is the Destination's Region type, or ERROR.
The Combine Mode can be one of the following:
RGN_AND : Gets a region of all points which are in both source regions
RGN_COPY : Gets an exact copy of the first source region
RGN_DIFF : Gets a region of all points which are in the first source
region but not in the second.(Source1 - Source2)
RGN_OR : Gets a region of all points which are in either the first
source region or in the second.(Source1 + Source2)
RGN_XOR : Gets all points which are in either the first Source Region
or in the second, but not in both.
The result can be one of the following constants
Error
NullRegion
SimpleRegion
ComplexRegion
------------------------------------------------------------------------------}
Function TgtkObject.CombineRgn(Dest, Src1, Src2 : HRGN;
fnCombineMode : Longint) : Longint;
var
Continue : Boolean;
D, S1, S2 : PGDKRegion;
Tmp1 : PGDKRegion;
DObj, S1Obj, S2Obj : PGDIObject;
begin
Result := SIMPLEREGION;
DObj := PGdiObject(Dest);
S1Obj := PGdiObject(Src1);
S2Obj := PGdiObject(Src2);
Continue := IsValidGDIObject(Dest) and IsValidGDIObject(Src1)
and IsValidGDIObject(Src2);
If Not Continue then begin
WriteLn('WARNING: [TgtkObject.CombineRgn] Invalid HRGN');
Result := Error;
end
else begin
If DObj^.GDIRegionObject <> nil then begin
GDK_Region_Destroy(DObj^.GDIRegionObject);
DObj^.GDIRegionObject:=nil;
end;
S1 := S1Obj^.GDIRegionObject;
S2 := S2Obj^.GDIRegionObject;
Case fnCombineMode of
RGN_AND :
D := gdk_regions_intersect(S1, S2);
RGN_COPY :
begin
Tmp1 := gdk_region_new;
D := gdk_regions_union(S1, Tmp1);
gdk_region_destroy(Tmp1);
end;
RGN_DIFF :
D := gdk_regions_subtract(S1, S2);
RGN_OR :
D := gdk_regions_union(S1, S2);
RGN_XOR :
D := gdk_regions_xor(S1, S2);
else begin
Result:= ERROR;
D := nil;
end;
end;
DObj^.GDIRegionObject := D;
Result := RegionType(D);
end;
end;
{------------------------------------------------------------------------------
Function: ExtSelectClipRGN
Params: dc, RGN, Mode
Returns: integer
Combines the passed Region with the current clipping region in the device
context (dc), using the specified mode.
The Combine Mode can be one of the following:
RGN_AND : all points which are in both regions
RGN_COPY : an exact copy of the source region, same as SelectClipRGN
RGN_DIFF : all points which are in the Clipping Region but
but not in the Source.(Clip - RGN)
RGN_OR : all points which are in either the Clip Region or
in the Source.(Clip + RGN)
RGN_XOR : all points which are in either the Clip Region
or in the Source, but not in both.
The result can be one of the following constants
Error
NullRegion
SimpleRegion
ComplexRegion
------------------------------------------------------------------------------}
function TgtkObject.ExtSelectClipRGN(dc: hdc; rgn : hrgn;
Mode : Longint) : Integer;
var
OldC, Clip,
Tmp : hRGN;
X, Y : Longint;
begin
If not IsValidDC(DC) then
Result := ERROR;
if Result <> ERROR
then with PDeviceContext(DC)^ do
begin
if GC = nil
then begin
WriteLn('WARNING: [TgtkObject.ExtSelectClipRGN] Uninitialized GC');
Result := ERROR;
end
else begin
OldC := CreateRectRGN(0,0,1,1);
If GetClipRGN(DC, OldC) <= 0 then begin
Case Mode of
RGN_COPY:
begin
Clip := CreateRectRGN(0,0,1,1);
Result := CombineRGN(Clip, RGN, RGN, Mode);
If Result <> ERROR then
Result := SelectClipRGN(DC, Clip);
DeleteObject(Clip);
end;
RGN_OR,
RGN_XOR,
RGN_AND,
RGN_DIFF:
begin
GDK_Window_Get_Size(Drawable, @X, @Y);
Clip := CreateRectRGN(0,0,X,Y);
Tmp := CreateRectRGN(0,0,1,1);
Result := CombineRGN(Tmp, Clip, RGN, mode);
DeleteObject(Clip);
SelectClipRGN(DC, Tmp);
DeleteObject(Tmp);
end;
end;
end
else
Result := Inherited ExtSelectClipRGN(dc, rgn, mode);
DeleteObject(OldC);
end;
end;
end;
{------------------------------------------------------------------------------
Function: DeleteDC
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.DeleteDC(hDC: HDC): Boolean;
begin
// TODO:
// for now it's just the same, however CreateDC/FreeDC
// and GetDC/ReleaseDC are couples
// we should use gdk_new_gc for create and gtk_new_gc for Get
Result:= (ReleaseDC(0, hDC) = 1);
end;
{------------------------------------------------------------------------------
Function: DeleteObject
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.DeleteObject(GDIObject: HGDIOBJ): Boolean;
var
GDIObjectExists: boolean;
begin
// Find out if we want to release internal GDI object
GDIObjectExists:=FGDIObjects.Contains(PGDIObject(GDIObject));
Result:= IsValidGDIObject(GDIObject);
if Result or GDIObjectExists
then
with PGdiObject(GDIObject)^ do
begin
case GDIType of
gdiFont:
begin
if Result then gdk_font_unref(GDIFontObject);
end;
gdiBrush:
begin
if Result and (GDIBrushPixmap <> nil)
then gdk_bitmap_unref(GDIBrushPixmap);
gdk_colormap_free_colors(gdk_colormap_get_system, @GDIBrushColor, 1);
end;
gdiBitmap:
begin
if Result and (GDIBitmapObject <> nil)
then gdk_bitmap_unref(GDIBitmapObject);
end;
gdiPen:
begin
gdk_colormap_free_colors(gdk_colormap_get_system, @GDIPenColor, 1);
end;
gdiRegion:
begin
if Result and (GDIRegionObject <> nil) then
gdk_region_destroy(GDIRegionObject);
end;
else begin
Result:= false;
writeln('[TgtkObject.DeleteObject] TODO : Unimplemented GDI type');
Assert(False, 'Trace:TODO : Unimplemented GDI object in delete object');
end;
end;
end;
{ Dispose of the GDI object }
//writeln('[TgtkObject.DeleteObject] ',Result,' ',HexStr(GDIObject,8),' ',FGDIObjects.Count);
if GDIObjectExists then begin
DisposeGDIObject(PGDIObject(GDIObject));
end;
end;
{------------------------------------------------------------------------------
Function: DestroyCaret
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.DestroyCaret(Handle: HWND): Boolean;
var
GTKObject: PGTKObject;
begin
GTKObject := PGTKObject(Handle);
Result := true;
if GTKObject<>nil then begin
if gtk_type_is_a(gtk_object_type(GTKObject), GTKAPIWidget_GetType)
then begin
GTKAPIWidget_DestroyCaret(PGTKAPIWidget(GTKObject));
end
// else if // TODO: other widgettypes
else begin
Result := False;
end;
end
else Assert(False, 'Trace:WARNING: [TgtkObject.DestroyCaret] Got null HWND');
end;
{------------------------------------------------------------------------------
Function: DrawFrameControl
Params:
Returns:
------------------------------------------------------------------------------}
function TgtkObject.DrawFrameControl(DC: HDC; var Rect : TRect;
uType, uState : Cardinal) : Boolean;
const
ADJUST_FLAG: array[Boolean] of Integer = (0, BF_ADJUST);
PUSH_EDGE_FLAG: array[Boolean] of Integer = (EDGE_RAISED, EDGE_SUNKEN);
PUSH_EDGE_FLAG2: array[Boolean] of Integer = (0, BF_FLAT);
var
Widget: PGtkWidget;
procedure DrawButtonPush;
var
State: TGtkStateType;
Shadow: TGtkShadowType;
aStyle : PGTKStyle;
pDC: PDeviceContext;
DCOrigin: TPoint;
begin
if Widget<>nil then begin
// use the gtk paint functions to draw a widget style dependent button
// set State (the interior filling style)
if (DFCS_INACTIVE and uState)<>0 then begin
// button disabled
State:=GTK_STATE_INSENSITIVE;
end else begin
if (DFCS_PUSHED and uState)<>0 then begin
// button enabled, down
if (DFCS_CHECKED and uState)<>0 then begin
// button enabled, down, special (e.g. mouse over)
State:=GTK_STATE_ACTIVE;
end else begin
// button enabled, down, normal
State:=GTK_STATE_SELECTED;
end;
end else begin
// button enabled, up
if (DFCS_CHECKED and uState)<>0 then begin
// button enabled, up, special (e.g. mouse over)
State:=GTK_STATE_PRELIGHT;
end else begin
// button enabled, up, normal
State:=GTK_STATE_NORMAL;
end;
end;
end;
// set Shadow (the border style)
if (DFCS_PUSHED and uState)<>0 then begin
// button down
Shadow:=GTK_SHADOW_IN;
end else begin
if (((DFCS_FLAT+DFCS_CHECKED) and uState)=DFCS_FLAT) then begin
// button up, flat, no special
Shadow:=GTK_SHADOW_NONE;
end else begin
// button up
Shadow:=GTK_SHADOW_OUT;
end;
end;
aStyle := GetStyle('button');
If aStyle = nil then
aStyle := Widget^.theStyle
else
If State = GTK_STATE_SELECTED then
State := GTK_STATE_ACTIVE;
pDC:=PDeviceContext(DC);
DCOrigin:=GetDCOffset(pDC);
Case Shadow of
GTK_SHADOW_NONE:
gtk_paint_flat_box(aStyle,Widget^.Window,
State,
Shadow,
nil,
Widget,
'button',
Rect.Left+DCOrigin.X,Rect.Top+DCOrigin.Y,
Rect.Right-Rect.Left,Rect.Bottom-Rect.Top);
else
gtk_paint_box(aStyle,Widget^.Window,
State,
Shadow,
nil,
Widget,
'button',
Rect.Left+DCOrigin.X,Rect.Top+DCOrigin.Y,
Rect.Right-Rect.Left,Rect.Bottom-Rect.Top);
end;
{gtk_draw_box(Widget^.TheStyle,Widget^.Window,
State,
Shadow,
Rect.Left,Rect.Top,
Rect.Right-Rect.Left,Rect.Bottom-Rect.Top);}
end else begin
// draw without widget style
Result := DrawEdge(DC, Rect,
PUSH_EDGE_FLAG[(uState and DFCS_PUSHED) <> 0],
BF_RECT or ADJUST_FLAG[
(uState and DFCS_ADJUSTRECT) <> 0]
);
end;
end;
var ClientWidget: PGtkWidget;
begin
if IsValidDC(DC) then begin
Widget:=PGtkWidget(PDeviceContext(DC)^.hWnd);
ClientWidget:=GetFixedWidget(Widget);
if ClientWidget<>nil then
Widget:=ClientWidget;
end else
Widget:=nil;
case uType of
DFC_CAPTION:
begin //all draw CAPTION commands here
end;
DFC_MENU:
begin
end;
DFC_SCROLL:
begin
end;
DFC_BUTTON:
begin
Assert(False, Format('Trace: [TgtkObject.DrawFrameControl] DFC_BUTTON --> draw rect = %d,%d,%d,%d',[Rect.Left,Rect.Top,REct.Right,REct.Bottom]));
//figure out the style first
case uState and $1F of
DFCS_BUTTONRADIOIMAGE:
begin
Assert(False, 'Trace:State ButtonRadioImage');
end;
DFCS_BUTTONRADIOMASK:
begin
Assert(False, 'Trace:State ButtonRadioMask');
end;
DFCS_BUTTONRADIO:
begin
Assert(False, 'Trace:State ButtonRadio');
end;
DFCS_BUTTON3STATE:
begin
Assert(False, 'Trace:State Button3State');
end;
DFCS_BUTTONPUSH:
begin
Assert(False, 'Trace:DFCS_BUTTONPUSH in uState');
DrawButtonPush;
end;
DFCS_BUTTONCHECK:
begin
Assert(False, 'Trace:State ButtonCheck');
Result := DrawEdge(DC, Rect,
PUSH_EDGE_FLAG2[(uState and DFCS_FLAT) <> 0],
BF_RECT or ADJUST_FLAG[
(uState and DFCS_ADJUSTRECT) <> 0]
);
if (uState and DFCS_CHECKED) <> 0 then
Begin
//TODO:write the code to draw a check inside the box defined by Rect
end;
end;
else
WriteLn(Format('ERROR: [TgtkObject.DrawFrameControl] Unknown State 0x%x', [uState]));
end;
end;
else
WriteLn(Format('ERROR: [TgtkObject.DrawFrameControl] Unknown type %d', [uType]));
end;
end;
{------------------------------------------------------------------------------
Function: DrawEdge
Params: DC: HDC; var Rect: TRect; edge: Cardinal; grfFlags: Cardinal
Returns: Boolean
Draws one or more edges of a rectangle. The rectangle is the area
Left to Right-1 and Top to Bottom-1.
------------------------------------------------------------------------------}
function TgtkObject.DrawEdge(DC: HDC; var Rect: TRect; edge: Cardinal;
grfFlags: Cardinal): Boolean;
Var
InnerTL, OuterTL,
InnerBR, OuterBR: TGDKColor;
BInner, BOuter: Boolean;
Width, Height: Integer;
R: TRect;
DCOrigin: TPoint;
begin
Assert(False, Format('trace:> [TgtkObject.DrawEdge] DC:0x%x, Rect = %d,%d,%d,%d', [DC, Rect.Left, Rect.Top,Rect.Right, Rect.Bottom]));
Result := IsValidDC(DC);
if Result
then with PDeviceContext(DC)^ do
begin
if GC = nil
then begin
Assert(False, 'Trace:[TgtkObject.DrawEdge] Uninitialized GC');
Result := False;
end
else begin
R := Rect;
Dec(R.Right);
Dec(R.Bottom);
// try to use the gdk functions, so that the current theme is used
BInner := False;
BOuter := False;
// TODO: changeThis to real colors
if (edge and BDR_RAISEDINNER) = BDR_RAISEDINNER
then begin
InnerTL := AllocGDKColor(GetSysColor(COLOR_BTNHIGHLIGHT));
InnerBR := AllocGDKColor(GetSysColor(COLOR_BTNSHADOW));
// gdk_color_white(gdk_colormap_get_system, @InnerTL);
// gdk_color_black(gdk_colormap_get_system, @InnerBR);
BInner := True;
end;
if (edge and BDR_SUNKENINNER) = BDR_SUNKENINNER
then begin
InnerTL := AllocGDKColor(GetSysColor(COLOR_BTNSHADOW));
InnerBR := AllocGDKColor(GetSysColor(COLOR_BTNHIGHLIGHT));
// gdk_color_black(gdk_colormap_get_system, @InnerTL);
// gdk_color_white(gdk_colormap_get_system, @InnerBR);
BInner := True;
end;
if (edge and BDR_RAISEDOUTER) = BDR_RAISEDOUTER
then begin
OuterTL := AllocGDKColor(GetSysColor(COLOR_BTNFACE));
OuterBR := AllocGDKColor(GetSysColor(COLOR_WINDOWFRAME));
// gdk_color_white(gdk_colormap_get_system, @OuterTL);
// gdk_color_black(gdk_colormap_get_system, @OuterBR);
BOuter := True;
end;
if (edge and BDR_SUNKENOUTER) = BDR_SUNKENOUTER
then begin
OuterTL := AllocGDKColor(GetSysColor(COLOR_WINDOWFRAME));
OuterBR := AllocGDKColor(GetSysColor(COLOR_BTNFACE));
// gdk_color_black(gdk_colormap_get_system, @OuterTL);
// gdk_color_white(gdk_colormap_get_system, @OuterBR);
BOuter := True;
end;
gdk_gc_set_fill(GC, GDK_SOLID);
// Draw outer rect
if Bouter
then with R do
begin
gdk_gc_set_foreground(GC, @OuterTL);
if (grfFlags and BF_TOP) = BF_TOP
then gdk_draw_line(Drawable, GC, Left, Top, Right, Top);
if (grfFlags and BF_LEFT) = BF_LEFT
then gdk_draw_line(Drawable, GC, Left, Top, Left, Bottom);
gdk_gc_set_foreground(GC, @OuterBR);
if (grfFlags and BF_BOTTOM) = BF_BOTTOM
then gdk_draw_line(Drawable, GC, Left, Bottom, Right + 1, Bottom);
if (grfFlags and BF_RIGHT) = BF_RIGHT
then gdk_draw_line(Drawable, GC, Right, Top, Right, Bottom + 1);
InflateRect(R, -1, -1);
end;
// Draw inner rect
if BInner
then with R do
begin
gdk_gc_set_foreground(GC, @InnerTL);
if (grfFlags and BF_TOP) = BF_TOP
then gdk_draw_line(Drawable, GC, Left, Top, Right, Top);
if (grfFlags and BF_LEFT) = BF_LEFT
then gdk_draw_line(Drawable, GC, Left, Top, Left, Bottom);
gdk_gc_set_foreground(GC, @InnerBR);
if (grfFlags and BF_BOTTOM) = BF_BOTTOM
then gdk_draw_line(Drawable, GC, Left, Bottom, Right + 1, Bottom);
if (grfFlags and BF_RIGHT) = BF_RIGHT
then gdk_draw_line(Drawable, GC, Right, Top, Right, Bottom + 1);
InflateRect(R, -1, -1);
end;
// gdk_colormap_free_colors(gdk_colormap_get_system, @OuterTL, 1);
// gdk_colormap_free_colors(gdk_colormap_get_system, @OuterBR, 1);
// gdk_colormap_free_colors(gdk_colormap_get_system, @InnerTL, 1);
// gdk_colormap_free_colors(gdk_colormap_get_system, @InnerBR, 1);
//Draw interiour
if (grfFlags and BF_MIDDLE) = BF_MIDDLE
then begin
Width := R.Right - R.Left + 1;
Height := R.Bottom - R.Top + 1;
SelectGDKBrushProps(DC);
DCOrigin:=GetDCOffset(PDeviceContext(DC));
gdk_draw_rectangle(Drawable, GC, 1, R.Left+DCOrigin.X, R.Top+DCOrigin.Y,
Width, Height);
end;
// adjust rect if needed
if (grfFlags and BF_ADJUST) = BF_ADJUST
then Rect := R;
Result := True;
end;
end;
Assert(False, Format('trace:< [TgtkObject.DrawEdge] DC:0x%x, Rect = %d,%d,%d,%d', [DC, Rect.Left, Rect.Top,Rect.Right, Rect.Bottom]));
end;
{------------------------------------------------------------------------------
Method: DrawText
Params: DC, Str, Count, Rect, Flags
Returns: If the string was drawn, or CalcRect run
------------------------------------------------------------------------------}
function TgtkObject.DrawText(DC : hDC; Str: PChar; Count : Integer; var Rect: TRect; Flags : Cardinal): Integer;
begin
Assert(False, Format('trace:> [TgtkObject.DrawText] DC:0x%x, Str:''%s'', Count: %d, Rect = %d,%d,%d,%d, Flags:%d',
[DC, Str, Count, Rect.Left, Rect.Top, Rect.Right, Rect.Bottom, Flags]));
Result := Longint(IsValidDC(DC));
if Boolean(Result)
then with PDeviceContext(DC)^ do
begin
If (FLAGS and DT_CalcRect) = DT_CalcRect then
Result := Inherited DrawText(DC, Str, Count, Rect, Flags)
else
if GC = nil
then begin
WriteLn('WARNING: [TgtkObject.DrawText] Uninitialized GC');
Result := 0;
end
else
If not IsValidGDIObject(hFont(CurrentFont)) then begin
WriteLn('WARNING: [TgtkObject.DrawText] Invalid Font');
Result := 0;
end
else
If CurrentFont^.GDIFontObject = nil then begin
WriteLn('WARNING: [TgtkObject.DrawText] Uninitialized Font');
Result := 0;
end
else
Result := Inherited DrawText(DC, Str, Count, Rect, Flags);
end;
Assert(False, Format('trace:> [TgtkObject.DrawText] DC:0x%x, Str:''%s'', Count: %d, Rect = %d,%d,%d,%d, Flags:%d',
[DC, Str, Count, Rect.Left, Rect.Top, Rect.Right, Rect.Bottom, Flags]));
end;
{------------------------------------------------------------------------------
Function: EnableMenuItem
Params: hndMenu:
uIDEnableItem:
Returns:
------------------------------------------------------------------------------}
function TGTKObject.EnableMenuItem(hndMenu: HMENU; uIDEnableItem: Integer;
bEnable: Boolean): Boolean;
begin
if hndMenu <> 0
then gtk_widget_set_sensitive(pgtkwidget(hndMenu), bEnable);
Result:=true;
end;
{------------------------------------------------------------------------------
Function: EnableScrollBar
Params: Wnd, wSBflags, wArrows
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.EnableScrollBar(Wnd: HWND; wSBflags, wArrows: Cardinal): Boolean;
begin
Assert(False, 'Trace:TODO: [TgtkObject.EnableScrollBar]');
//TODO: Implement this;
Result := False;
end;
{------------------------------------------------------------------------------
Function: EnableWindow
Params: hWnd:
bEnable:
Returns:
------------------------------------------------------------------------------}
function TGTKObject.EnableWindow(hWnd: HWND; bEnable: Boolean): Boolean;
begin
Assert(False, Format('Trace: [TGTKObject.EnableWindow] hWnd: 0x%x, Enable: %s', [hwnd, BOOL_TEXT[bEnable]]));
if hWnd <> 0 then
gtk_widget_set_sensitive(pgtkwidget(hWnd), bEnable);
Result:=true;
end;
{------------------------------------------------------------------------------
Method: Ellipse
Params: X1, Y1, X2, Y2
Returns: Nothing
Use Ellipse to draw a filled circle or ellipse.
------------------------------------------------------------------------------}
function TgtkObject.Ellipse(DC: HDC;
x1,y1,x2,y2: Integer): Boolean;
var
x,y,width,height: integer;
DCOrigin: TPoint;
begin
Result := IsValidDC(DC);
if Result
then with PDeviceContext(DC)^ do
begin
if GC = nil
then begin
WriteLn('WARNING: [TgtkObject.Ellipse] Uninitialized GC');
Result := False;
end
else begin
x:=(x1+x2) shr 1;
y:=(y1+y2) shr 1;
width:=(x2-x1);
if width<0 then width:=-width;
width:=width shr 1;
height:=(y2-y1);
if height<0 then height:=-height;
height:=height shr 1;
// first draw interior in brush color
SelectGDKBrushProps(DC);
DCOrigin:=GetDCOffset(PDeviceContext(DC));
gdk_draw_arc(Drawable, GC, 1, x+DCOrigin.X, y+DCOrigin.Y, Width, Height,
0, 360 shl 6);
// Draw outline
SelectGDKPenProps(DC);
gdk_draw_arc(Drawable, GC, 0, x+DCOrigin.X, y+DCOrigin.Y, Width, Height,
0, 360 shl 6);
Result := True;
end;
end;
end;
{------------------------------------------------------------------------------
Function: ExcludeClipRect
Params: dc: hdc; Left, Top, Right, Bottom : Integer
Returns: integer
Subtracts all intersecting points of the passed bounding rectangle
(Left, Top, Right, Bottom) from the Current clipping region in the
device context (dc).
The result can be one of the following constants
Error
NullRegion
SimpleRegion
ComplexRegion
------------------------------------------------------------------------------}
function TgtkObject.ExcludeClipRect(dc: hdc;
Left, Top, Right, Bottom : Integer) : Integer;
begin
If not IsValidDC(DC) then
Result := ERROR;
if Result <> ERROR
then with PDeviceContext(DC)^ do
begin
if GC = nil
then begin
WriteLn('WARNING: [TgtkObject.ExcludeClipRect] Uninitialized GC');
Result := ERROR;
end
else
Result := Inherited ExcludeClipRect(DC, Left, Top, Right, Bottom);
end;
end;
{------------------------------------------------------------------------------
Function: ExtTextOut
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.ExtTextOut(DC: HDC; X, Y: Integer; Options: Longint;
Rect: PRect; Str: PChar; Count: Longint; Dx: PInteger): Boolean;
var
LineStart, LineEnd, StrEnd: PChar;
Width, Height: Integer;
AY, Num : Integer;
TXTPt : TPoint;
TM : TTextMetric;
//ADC : hDC;
UseFont : PGDKFont;
UnRef : Boolean;
DCOrigin: TPoint;
begin
Assert(False, Format('trace:> [TgtkObject.ExtTextOut] DC:0x%x, X:%d, Y:%d, Options:%d, Str:''%s'', Count: %d', [DC, X, Y, Options, Str, Count]));
Result := IsValidDC(DC);
if Result
then with PDeviceContext(DC)^ do
begin
if (CurrentFont = nil) or (CurrentFont^.GDIFontObject = nil)
then begin
UseFont := GetDefaultFont;
UnRef := True;
end
else begin
UseFont := CurrentFont^.GDIFontObject;
UnRef := False;
end;
if GC = nil
then begin
WriteLn('WARNING: [TgtkObject.ExtTextOut] Uninitialized GC');
Result := False;
end
else begin
If UseFont = nil then begin
WriteLn('WARNING: [TgtkObject.ExtTextOut] Missing Font');
Result := False;
end
else begin
// TODO: implement other parameters.
//ADC := SaveDC(DC);
DCOrigin:=GetDCOffset(PDeviceContext(DC));
if (Options and ETO_OPAQUE) <> 0 then
begin
Width := Rect^.Right - Rect^.Left;
Height := Rect^.Bottom - Rect^.Top;
gdk_gc_set_fill(GC, GDK_SOLID);
gdk_gc_set_foreground(GC, @CurrentBackColor);
gdk_draw_rectangle(Drawable, GC, 1,
Rect^.Left+DCOrigin.X, Rect^.Top+DCOrigin.Y,
Width, Height);
end;
if (Options and ETO_CLIPPED) <> 0 then
begin
X := Rect^.Left;
Y := Rect^.Top;
IntersectClipRect(DC, Rect^.Left, Rect^.Top, Rect^.Right,
Rect^.Bottom);
end;
Num := FindChar(#10,Str,Count);
AY := Y;
GetTextMetrics(DC, TM);
TxtPt.X := X;
{$IfDef Win32}
TxtPt.Y := AY + TM.tmHeight div 2;
{$Else}
TxtPt.Y := AY + TM.tmAscent;
{$EndIf}
SelectGDKTextProps(DC);
if Num < 0 then begin
if Count> 0 then
gdk_draw_text(Drawable, UseFont, GC,
TxtPt.X+DCOrigin.X, TxtPt.Y+DCOrigin.Y, Str, Count);
end else
Begin //write multiple lines
LineStart:=Str;
StrEnd:=Str+Count;
while LineStart < StrEnd do begin
LineEnd:=LineStart+Num;
if Num>0 then
gdk_draw_text(Drawable, UseFont, GC,
TxtPt.X+DCOrigin.X, TxtPt.Y+DCOrigin.Y, LineStart, Num);
AY := TxtPt.Y;
{$IfDef Win32}
TxtPt.Y := AY + TM.tmHeight div 2;
{$Else}
TxtPt.Y := AY + TM.tmAscent;
{$EndIf}
LineStart:=LineEnd+1; // skip #10
if (LineStart<StrEnd) and (LineStart^=#13) then
inc(LineStart); // skip #10
Count:=StrEnd-LineStart;
Num:=FindChar(#10,LineStart,Count);
if Num<0 then
Num:=Count;
end;
end;
//RestoreDC(DC, ADC);
If UnRef then
GDK_Font_UnRef(UseFont);
end;
end;
end;
Assert(False, Format('trace:< [TgtkObject.ExtTextOut] DC:0x%x, X:%d, Y:%d, Options:%d, Str:''%s'', Count: %d', [DC, X, Y, Options, Str, Count]));
end;
{------------------------------------------------------------------------------
Function: FillRect
Params: none
Returns: Nothing
The FillRect function fills a rectangle by using the specified brush.
This function includes the left and top borders, but excludes the right and
bottom borders of the rectangle.
------------------------------------------------------------------------------}
function TgtkObject.FillRect(DC: HDC; const Rect: TRect; Brush: HBRUSH): Boolean;
var
Width, Height: Integer;
OldCurrentBrush: PGdiObject;
DCOrigin: TPoint;
begin
Assert(False, Format('trace:> [TgtkObject.FillRect] DC:0x%x; Rect: ((%d,%d)(%d,%d)); brush: %x', [Integer(DC), Rect.left, rect.top, rect.right, rect.bottom, brush]));
Result := IsValidDC(DC) and IsValidGDIObject(Brush);
if Result
then with PDeviceContext(DC)^ do
begin
if GC = nil
then begin
WriteLn('WARNING: [TgtkObject.FillRect] Uninitialized GC');
Result := False;
end
else begin
Width := Rect.Right - Rect.Left;
Height := Rect.Bottom - Rect.Top;
// Temporary hold the old brush to
// replace it with the given brush
OldCurrentBrush := CurrentBrush;
CurrentBrush := PGdiObject(Brush);
SelectGDKBrushProps(DC);
DCOrigin:=GetDCOffset(PDeviceContext(DC));
gdk_draw_rectangle(Drawable, GC, 1,
Rect.Left+DCOrigin.X, Rect.Top+DCOrigin.Y,
Width, Height);
// Restore current brush
CurrentBrush := OldCurrentBrush;
Result := True;
end;
end;
Assert(False, Format('trace:< [TgtkObject.FillRect] DC:0x%x; Rect: ((%d,%d)(%d,%d)); brush: %x', [Integer(DC), Rect.left, rect.top, rect.right, rect.bottom, brush]));
end;
{------------------------------------------------------------------------------
Function: Frame3d
Params: -
Returns: Nothing
Draws a 3d border in GTK native style.
------------------------------------------------------------------------------}
function TGtkObject.Frame3d(DC : HDC; var Rect : TRect;
const FrameWidth : integer; const Style : TBevelCut) : boolean;
const GTKShadowType: array[TBevelCut] of integer =
(GTK_SHADOW_NONE, GTK_SHADOW_IN, GTK_SHADOW_OUT);
var
Widget, ClientWidget: PGtkWidget;
i : integer;
DCOrigin: TPoint;
begin
Result := IsValidDC(DC);
if Result then
with PDeviceContext(DC)^ do
begin
if GC = nil then begin
Result:= False;
end
else begin
Widget:=PGtkWidget(PDeviceContext(DC)^.hWnd);
ClientWidget:=GetFixedWidget(Widget);
if ClientWidget=nil then
ClientWidget:=Widget;
DCOrigin:=GetDCOffset(PDeviceContext(DC));
for i:= 1 to FrameWidth do begin
gtk_draw_shadow(ClientWidget^.thestyle,
ClientWidget^.window, GTK_STATE_NORMAL,
GtkShadowType[Style],
Rect.Left+DCOrigin.X, Rect.Top+DCOrigin.Y,
Rect.Right - Rect.Left-1, Rect.Bottom - Rect.Top-1);
InflateRect(Rect, -1, -1);
end;
end;
end;
end;
{------------------------------------------------------------------------------
Function: GetActiveWindow
Params: none
Returns:
------------------------------------------------------------------------------}
Function TGTKObject.GetActiveWindow : HWND;
var
List: PGList;
Widget: PGTKWidget;
Window: PGTKWindow;
begin
List := gdk_window_get_toplevels;
while List <> nil do
begin
if (List^.Data <> nil)
then begin
gdk_window_get_user_data(PGDKWindow(List^.Data), @Window);
if gtk_is_window(Window)
then begin
Widget := Window^.focus_widget;
if (Widget <> nil) and gtk_widget_has_focus(Widget)
then begin
Result := HWND(GetMainWidget(PGtkWidget(Window)));
Exit;
end;
end;
end;
list := g_list_next(list);
end;
// If we are here we didn't find anything
Result := 0;
end;
{------------------------------------------------------------------------------
Function: GetCapture
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.GetCapture: HWND;
begin
Result := MCaptureHandle;
end;
{------------------------------------------------------------------------------
Function: GetCaretPos
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.GetCaretPos(var lpPoint: TPoint): Boolean;
var
//FocusObject: PGTKObject;
modmask : TGDKModifierType;
begin
{ Assert(False, 'Trace:TODO: [TgtkObject.GetCaretPos] finish');
FocusObject := PGTKObject(GetFocus);
Result := FocusObject <> nil;
if Result
then begin
// Assert(False, Format('Trace:[TgtkObject.GetCaretPos] Got focusObject 0x%x --> %s', [Integer(FocusObject), gtk_type_name(FocusObject^.Klass^.theType)]));
if gtk_type_is_a(gtk_object_type(FocusObject), GTKAPIWidget_GetType)
then begin
GTKAPIWidget_GetCaretPos(PGTKAPIWidget(FocusObject), lpPoint.X, lpPoint.Y);
end
// else if // TODO: other widgettypes
else begin
Result := False;
end;
end
else WriteLn('[TgtkObject.GetCaretPos] got focusObject nil');
}
Assert(False, 'Trace:GetCaretPos');
gdk_window_get_pointer(nil,@lpPoint.X,@lpPoint.y,@modmask);
Assert(False, 'Trace:GetCaretPos');
Result := True;
end;
{------------------------------------------------------------------------------
Function: GetCharABCWidths pbd
Params: Don't care yet
Returns: False so that the font cache in the newest mwEdit will use
TextMetrics info which is working already
------------------------------------------------------------------------------}
function TgtkObject.GetCharABCWidths(DC: HDC; p2, p3: UINT;
const ABCStructs): Boolean;
begin
Result := False;
end;
{------------------------------------------------------------------------------
Function: GetClientBounds
Params: handle:
Result:
Returns: true on success
Returns the client bounds of a control. The client bounds is the rectangle of
the inner area of a control, where the child controls are visible. The
coordinates are relative to the control's left and top.
------------------------------------------------------------------------------}
Function TGTKObject.GetClientBounds(handle : HWND; var ARect : TRect) : Boolean;
var
Widget, ClientWidget: PGtkWidget;
MainOrigin, ClientOrigin: TPoint;
ClientWindow, MainWindow: PGdkWindow;
begin
Result := False;
if Handle = 0 then Exit;
Widget := pgtkwidget(Handle);
ClientWidget := GetFixedWidget(Widget);
if (ClientWidget <> nil) and (ClientWidget^.Window<>nil) then begin
ClientWindow:=ClientWidget^.Window;
MainWindow:=Widget^.Window;
gdk_window_get_origin(MainWindow,@MainOrigin.X,@MainOrigin.Y);
inc(MainOrigin.X,Widget^.Allocation.X);
inc(MainOrigin.Y,Widget^.Allocation.Y);
gdk_window_get_origin(ClientWindow,@ClientOrigin.X,@ClientOrigin.Y);
ARect.Left:=ClientOrigin.X-MainOrigin.X;
ARect.Top:=ClientOrigin.Y-MainOrigin.Y;
ARect.Right:=ARect.Left+ClientWidget^.Allocation.Width;
ARect.Bottom:=ARect.Top+ClientWidget^.Allocation.Height;
end else begin
with Widget^.Allocation do
ARect := Rect(0,0,Width,Height);
end;
Result:=true;
end;
{------------------------------------------------------------------------------
Function: GetClientRect
Params: handle:
Result:
Returns: true on success
Returns the client rectangle of a control. Left and Top are always 0.
The client rectangle is the size of the inner area of a control, where the
child controls are visible.
------------------------------------------------------------------------------}
Function TGTKObject.GetClientRect(handle : HWND; var ARect : TRect) : Boolean;
var
Widget, ClientWidget: PGtkWidget;
begin
Result := false;
if Handle = 0 then Exit;
ARect.Left := 0;
ARect.Top := 0;
Widget := pgtkwidget(Handle);
ClientWidget := GetFixedWidget(Widget);
if (ClientWidget <> nil) then
Widget := ClientWidget;
if (Widget <> nil) then begin
ARect.Right:=Widget^.Allocation.Width;
ARect.Bottom:=Widget^.Allocation.Height;
end else begin
ARect.Right:=0;
ARect.Bottom:=0;
end;
{$IfDef VerboseGetClientRect}
if ClientWidget<>nil then begin
writeln('GetClientRect Widget=',HexStr(Cardinal(handle),8),
' Client=',HexStr(Cardinal(ClientWidget),8),
' WindowSize=',ARect.Right,',',ARect.Bottom,
' Allocation=',ClientWidget^.Allocation.Width,',',ClientWidget^.Allocation.Height
);
end else begin
writeln('GetClientRect Widget=',HexStr(Cardinal(handle),8),
' Client=',HexStr(Cardinal(ClientWidget),8),
' WindowSize=',ARect.Right,',',ARect.Bottom,
' Allocation=',Widget^.Allocation.Width,',',Widget^.Allocation.Height
);
end;
{$EndIf}
Result:=true;
end;
{------------------------------------------------------------------------------
Function: GetClipBox
Params: dc, lprect
Returns: Integer
Returns the smallest rectangle which includes the entire current
Clipping Region, or if no Clipping Region is set, the current
dimensions of the Drawable.
The result can be one of the following constants
Error
NullRegion
SimpleRegion
ComplexRegion
------------------------------------------------------------------------------}
Function TGTKObject.GetClipBox(DC : hDC; lpRect : PRect) : Longint;
var
CRect : TGDKRectangle;
X, Y : Longint;
DCOrigin: Tpoint;
begin
If not IsValidDC(DC) then
Result := ERROR;
If lpRect <> nil then
lpRect^ := Rect(0,0,0,0);
if Result <> ERROR
then with PDeviceContext(DC)^ do
begin
DCOrigin:=GetDCOffset(PDeviceContext(DC));
If Not IsValidGDIObject(ClipRegion) then begin
gdk_window_get_size(Drawable, @X, @Y);
lpRect^ := Rect(-DCOrigin.X, -DCOrigin.Y, X, Y);
Result := SIMPLEREGION;
end
else begin
Result := RegionType(PGDIObject(ClipRegion)^.GDIRegionObject);
gdk_region_get_clipbox(PGDIObject(ClipRegion)^.GDIRegionObject,
@CRect);
With lpRect^,CRect do begin
Left := X-DCOrigin.X;
Top := Y-DCOrigin.Y;
Right := Left + Width;
Bottom := Top + Height;
end;
end;
end;
end;
{------------------------------------------------------------------------------
Function: GetClipRGN
Params: dc, rgn
Returns: Integer
Returns the current Clipping Region.
The result can be one of the following constants
Error
NullRegion
SimpleRegion
ComplexRegion
------------------------------------------------------------------------------}
Function TGTKObject.GetClipRGN(DC : hDC; RGN : hRGN) : longint;
begin
If not IsValidDC(DC) then
Result := ERROR;
if Result <> ERROR
then with PDeviceContext(DC)^ do
begin
If Not IsValidGDIObject(RGN) then begin
Result := ERROR;
WriteLn('WARNING: [TgtkObject.CombineRgn] Invalid HRGN');
end
else begin
If Not IsValidGDIObject(ClipRegion) then begin
Result := 0;
end
else begin
Result := CombineRGN(RGN, ClipRegion, ClipRegion, RGN_COPY);
If Result = NULLREGION then
Result := 0
else
If Result <> ERROR then
Result := 1;
end;
end;
end;
If Result = ERROR then
Result := -1;
end;
{------------------------------------------------------------------------------
Function: GetCmdLineParamDescForInterface
Params: none
Returns: ansistring
Returns a description of the command line parameters, that are understood by
the interface.
------------------------------------------------------------------------------}
Function TGTKObject.GetCmdLineParamDescForInterface: string;
const
e = {$IfDef win32}#13+{$EndIf}#10;
begin
Result:=
'--gtk-module module Load the specified module at startup.'+e+
e+
'--g-fatal-warnings Warnings and errors generated by Gtk+/GDK will'+e+
' halt the application.'+e+
e+
'--gtk-debug flags Turn on specific Gtk+ trace/debug messages.'+e+
e+
'--gtk-no-debug flags Turn off specific Gtk+ trace/debug messages.'+e+
e+
'--gdk-debug flags Turn on specific GDK trace/debug messages.'+e+
e+
'--gdk-no-debug flags Turn off specific GDK trace/debug messages.'+e+
e+
'--display h:s:d Connect to the specified X server, where "h" is'+e+
' the hostname, "s" is the server number (usually'+e+
' 0), and "d" is the display number (typically'+e+
' omitted). If --display is not specified, the'+e+
' DISPLAY environment variable is used.'+e+
e+
'--sync Call XSynchronize (display, True) after the X'+e+
' server connection has been established. This'+e+
' makes debugging X protocol erros easier,'+e+
' because X request buffering will be disabled and'+e+
' X errors will be received immediatey after the'+e+
' protocol request that generated the error has'+e+
' been processed by the X server.'+e+
e+
'--no-xshm Disable use of the X Shared Memory Extension.'+e+
e+
'--name programe Set program name to "progname". If not'+e+
' specified, program name will be set to'+e+
' ParamStr(0).'+e+
e+
'--class classname Following Xt conventions, the class of a'+e+
' program is the program name with the initial'+e+
' character capitalized. For example, the class'+e+
' name for gimp is "Gimp". If --class is'+e+
' specified, the class of the program will be'+e+
' set to "classname".'+e;
end;
{------------------------------------------------------------------------------
Function: GetDC
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.GetDC(hWnd: HWND): HDC;
var
p: PDeviceContext;
ClientWidget: PGtkWidget;
GdiObject: PGdiObject;
Values: TGdkGCValues;
X,Y : Longint;
begin
Assert(False, Format('trace:> [TgtkObject.GetDC] hWND: 0x%x', [hWnd]));
p := nil;
if hWnd = 0
then begin
P := NewDC;
p^.hWnd := hWnd;
FillChar(Values, SizeOf(Values), #0);
end
else begin
ClientWidget := GetFixedWidget(Pointer(hWnd));
if ClientWidget = nil
then begin
Assert(False, 'trace:WARNING: [TgtkObject.GetDC] Widget has no fixed, using widget itself');
ClientWidget := Pointer(hWnd);
end;
// create a new devicecontext for this window
P := NewDC;
p^.hWnd := hWnd;
p^.SpecialOrigin:=GtkWidgetIsA(PGtkWidget(p^.hWnd),GTK_LAYOUT_GET_TYPE);
if ClientWidget^.Window = nil
then begin
Assert(False, 'Trace:[TgtkObject.GetDC] Force widget creation');
//force creation
gtk_widget_realize(ClientWidget);
end;
p^.Drawable := ClientWidget^.Window;
p^.GC := gdk_gc_new(p^.Drawable);
gdk_window_get_size(P^.Drawable, @X, @Y);
gdk_gc_set_function(p^.GC, GDK_COPY);
gdk_gc_get_values(p^.GC, @Values);
end;
if p <> nil
then begin
if Values.Font <> nil
then begin
GdiObject:=NewGDIObject(gdiFont);
GdiObject^.GDIFontObject := Values.Font;
gdk_font_ref(Values.Font);
end
else GdiObject := CreateDefaultFont;
p^.CurrentFont := GdiObject;
p^.CurrentBrush := CreateDefaultBrush;
p^.CurrentPen := CreateDefaultPen;
end;
Result := HDC(p);
Assert(False, Format('trace:< [TgtkObject.GetDC] Got 0x%x', [Result]));
end;
{------------------------------------------------------------------------------
Function: GetFocus
Params: none
Returns: The handle of the window with focus
The GetFocus function retrieves the handle of the window that has the focus.
------------------------------------------------------------------------------}
function TgtkObject.GetFocus: HWND;
var
List: PGList;
Widget: PGTKWidget;
Window: PGTKWindow;
begin
List := gdk_window_get_toplevels;
while List <> nil do
begin
if (List^.Data <> nil)
then begin
gdk_window_get_user_data(PGDKWindow(List^.Data), @Window);
if gtk_is_window(Window)
then begin
Widget := Window^.focus_widget;
if (Widget <> nil) and gtk_widget_has_focus(Widget)
then begin
Result := HWND(GetMainWidget(Widget));
Exit;
end;
end;
end;
list := g_list_next(list);
end;
// If we are here we didn't find anything
Result := 0;
end;
{------------------------------------------------------------------------------
Function: GetKeyState
Params: nVirtKey: The requested key
Returns: If the function succeeds, the return value specifies the status of
the given virtual key. If the high-order bit is 1, the key is down;
otherwise, it is up. If the low-order bit is 1, the key is toggled.
The GetKeyState function retrieves the status of the specified virtual key.
------------------------------------------------------------------------------}
function TgtkObject.GetKeyState(nVirtKey: Integer): Smallint;
const
KEYSTATE: array[Boolean] of Smallint = (0, -32768 { $8000});
TOGGLESTATE: array[Boolean] of Smallint = (0, 1);
begin
case nVirtKey of
VK_LSHIFT: nVirtKey := VK_SHIFT;
VK_LCONTROL: nVirtKey := VK_CONTROL;
VK_LMENU: nVirtKey := VK_MENU;
end;
Result := KEYSTATE[FKeyStateList.IndexOf(Pointer(nVirtKey)) <> -1];
// try extended keys
if Result = 0
then begin
nVirtKey := nVirtKey or KEYMAP_EXTENDED;
Result := KEYSTATE[FKeyStateList.IndexOf(Pointer(nVirtKey)) <> -1];
end;
// add toggle
if Result <> 0 then
Result := Result or TOGGLESTATE[FKeyStateList.IndexOf(Pointer(
nVirtKey or KEYMAP_TOGGLE)) <> -1];
//Assert(False, Format('Trace:[TgtkObject.GetKeyState] %d -> 0x%x', [nVirtKey, Result]));
end;
{------------------------------------------------------------------------------
Function: GetObject
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.GetObject(GDIObj: HGDIOBJ; BufSize: Integer; Buf: Pointer): Integer;
var
BitmapSection : TDIBSECTION;
begin
Assert(False, 'trace:[TgtkObject.GetObject]');
Result := 0;
if IsValidGDIObject(GDIObj)
then begin
case PGDIObject(GDIObj)^.GDIType of
gdiBitmap:
begin
Assert(False, 'Trace:FINISH: [TgtkObject.GetObject] gdiBitmap');
if Buf = nil then
Result := SizeOf(TDIBSECTION)
else begin
With PGDIObject(GDIObj)^, BitmapSection,
BitmapSection.dsBm, BitmapSection.dsBmih
do begin
{dsBM - BITMAP}
//bmType := ???;
bmWidth := 0 ;
bmHeight := 0;
{bmWidthBytes: Longint;
bmPlanes: Word;
bmBitsPixel: Word;
bmBits: Pointer; }
{dsBmih - BITMAPINFOHEADER}
biSize := 0;
biWidth := 0;
biHeight := 0;
biPlanes := 0;
biBitCount := 1;
{biCompression : DWORD;
biSizeImage : DWORD;
biXPelsPerMeter : Longint;
biYPelsPerMeter : Longint;
biClrUsed : DWORD;
biClrImportant : DWORD;}
{dsBitfields: array[0..2] of DWORD;
dshSection: THandle;
dsOffset: DWORD;}
case GDIBitmapType of
gbBitmap:
If GDIBitmapObject <> nil then begin
GDK_WINDOW_GET_SIZE(GDIBitmapObject, @bmWidth, @bmHeight);
biSize := 0;
end;
gbPixmap:
If GDIPixmapObject <> nil then begin
gdk_window_get_geometry(GDIPixmapObject, nil, nil,
@bmWidth, @bmHeight, @biBitCount);
biSize := 0;
end;
gbImage :
If GDIRawImageObject <> nil then
With GDIRawImageObject^ do begin
bmHeight := Height;
bmWidth := Width;
biBitCount := Depth;
end;
end;
biWidth := bmWidth;
biHeight := bmHeight;
end;
if BufSize >= SizeOf(BitmapSection)
then begin
PDIBSECTION(Buf)^ := BitmapSection;
Result:= SizeOf(TDIBSECTION);
end else
if BufSize>0 then begin
Move(BitmapSection,Buf^,BufSize);
Result:=BufSize;
end;
end;
end;
gdiBrush:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetObject] gdiBrush');
end;
gdiFont:
begin
if Buf = nil then
Result := SizeOf(PGDIObject(GDIObj)^.LogFont)
else begin
if BufSize >= SizeOf(PGDIObject(GDIObj)^.LogFont)
then begin
PLogfont(Buf)^ := PGDIObject(GDIObj)^.LogFont;
Result:= SizeOf(TLogFont);
end else if BufSize>0 then begin
Move(PGDIObject(GDIObj)^.LogFont,Buf^,BufSize);
Result:=BufSize;
end;
end;
end;
gdiPen:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetObject] gdiPen');
end;
gdiRegion:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetObject] gdiRegion');
end;
else
WriteLn(Format('WARNING: [TgtkObject.GetObject] Unknown type %d', [Integer(PGDIObject(GDIObj)^.GDIType)]));
end;
end;
end;
{------------------------------------------------------------------------------
Function: GetParent
Params: Handle:
Returns:
------------------------------------------------------------------------------}
Function TGTKObject.GetParent(Handle : HWND): HWND;
begin
//writeln('TGTKObject.GetParent ',HexStr(Cardinal(Handle),8));
Result:=0;
if Handle<>0 then
Result:=HWnd(PGtkWidget(Handle)^.Parent);
end;
{------------------------------------------------------------------------------
Function: GetProp
Params: Handle: Str
Returns: Pointer
------------------------------------------------------------------------------}
Function TgtkObject.GetProp(Handle : hwnd; Str : PChar): Pointer;
Begin
result := gtk_object_get_data(pgtkobject(Handle),Str);
end;
{------------------------------------------------------------------------------
Function: GetScrollInfo
Params: Handle, BarFlag, ScrollInfo
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.GetScrollInfo(Handle: HWND; BarFlag: Integer;
var ScrollInfo: TScrollInfo): Boolean;
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetScrollInfo]');
Result := False;
end;
Function TgtkObject.CreateSystemFont : hFont;
var
GDIObj : PGDIObject;
begin
GDIObj := NewGDIObject(gdiFont);
GDIObj^.GDIFontObject:= GetDefaultFont;
Result := hFont(GDIObj);
end;
{------------------------------------------------------------------------------
Function: GetStockObject
Params:
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.GetStockObject(Value: Integer): LongInt;
begin
Assert(False, Format('Trace:> [TgtkObject.GetStockObject] %d', [Value]));
Result := 0;
case Value of
BLACK_BRUSH: // Black brush.
Result := FStockBlackBrush;
DKGRAY_BRUSH: // Dark gray brush.
Result := FStockDKGrayBrush;
GRAY_BRUSH: // Gray brush.
Result := FStockGrayBrush;
LTGRAY_BRUSH: // Light gray brush.
Result := FStockLtGrayBrush;
NULL_BRUSH: // Null brush (equivalent to HOLLOW_BRUSH).
Result := FStockNullBrush;
WHITE_BRUSH: // White brush.
Result := FStockWhiteBrush;
BLACK_PEN: // Black pen.
Result := FStockBlackPen;
NULL_PEN: // Null pen.
Result := FStockNullPen;
WHITE_PEN: // White pen.
Result := FStockWhitePen;
(* ANSI_FIXED_FONT: // Fixed-pitch (monospace) system font.
begin
{If FStockFixedFont = 0 then
FStockFixedFont := GetStockFixedFont;
Result := FStockFixedFont;}
end;
ANSI_VAR_FONT: // Variable-pitch (proportional space) system font.
begin
end;
DEVICE_DEFAULT_FONT: // Device-dependent font.
begin
end; *)
DEFAULT_GUI_FONT: // Default font for user interface objects such as menus and dialog boxes.
begin
Result := GetStockObject(SYSTEM_FONT);
end;
(* OEM_FIXED_FONT: // Original equipment manufacturer (OEM) dependent fixed-pitch (monospace) font.
begin
end;
*)
SYSTEM_FONT: // System font. By default, Windows uses the system font to draw menus, dialog box controls, and text. In Windows versions 3.0 and later, the system font is a proportionally spaced font; earlier versions of Windows used a monospace system font.
begin
If FStockSystemFont <> 0 then begin //This is a Temporary Hack!!! This
DeleteObject(FStockSystemFont); //should really only be done on
FStockSystemFont := 0; //theme change.
end;
If FStockSystemFont = 0 then
FStockSystemFont := CreateSystemFont;
Result := FStockSystemFont;
end;
(* SYSTEM_FIXED_FONT: // Fixed-pitch (monospace) system font used in Windows versions earlier than 3.0. This stock object is provided for compatibility with earlier versions of Windows.
begin
Result := GetStockObject(ANSI_FIXED_FONT);
end;
DEFAULT_PALETTE: // Default palette. This palette consists of the static colors in the system palette.
begin
end;
*) else
Assert(False, Format('Trace:TODO: [TgtkObject.GetStockObject] Implement value: %d', [Value]));
end;
Assert(False, Format('Trace:< [TgtkObject.GetStockObject] %d --> 0x%x', [Value, Result]));
end;
{------------------------------------------------------------------------------
Function: GetSysColor
Params: index to the syscolors array
Returns: RGB value
------------------------------------------------------------------------------}
function TgtkObject.GetSysColor(nIndex: Integer): DWORD;
begin
if (nIndex < 0) or (nIndex > MAX_SYS_COLORS)
then begin
Result := 0;
// raise an exception
WriteLn(Format('ERROR: [TgtkObject.GetSysColor] Bad Value: %8x Valid Range between 0 and %d', [nIndex, MAX_SYS_COLORS]));
end
else Result := SysColorMap[nIndex];
//Assert(False, Format('Trace:[TgtkObject.GetSysColor] Index %d --> %8x', [nIndex, Result]));
end;
{------------------------------------------------------------------------------
Function: GetSystemMetrics
Params:
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.GetSystemMetrics(nIndex: Integer): Integer;
begin
Assert(False, Format('Trace:> [TgtkObject.GetSystemMetrics] %d', [nIndex]));
case nIndex of
SM_ARRANGE:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_ARRANGE ');
end;
SM_CLEANBOOT:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CLEANBOOT ');
end;
SM_CMOUSEBUTTONS:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CMOUSEBUTTONS ');
end;
SM_CXBORDER:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CXBORDER ');
end;
SM_CYBORDER:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CYBORDER ');
end;
SM_CXCURSOR:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CXCURSOR ');
end;
SM_CYCURSOR:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CYCURSOR ');
end;
SM_CXDOUBLECLK:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CXDOUBLECLK ');
end;
SM_CYDOUBLECLK:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CYDOUBLECLK ');
end;
SM_CXDRAG:
begin
Result := 2;
end;
SM_CYDRAG:
begin
Result := 2;
end;
SM_CXEDGE:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CXEDGE ');
end;
SM_CYEDGE:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CYEDGE ');
end;
SM_CXFIXEDFRAME:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CXFIXEDFRAME ');
end;
SM_CYFIXEDFRAME:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CYFIXEDFRAME ');
end;
SM_CXFULLSCREEN:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CXFULLSCREEN ');
end;
SM_CYFULLSCREEN:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CYFULLSCREEN ');
end;
SM_CXHSCROLL:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CXHSCROLL ');
end;
SM_CYHSCROLL:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CYHSCROLL ');
end;
SM_CXHTHUMB:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CXHTHUMB ');
end;
SM_CXICON:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CXICON ');
end;
SM_CYICON:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CYICON ');
end;
SM_CXICONSPACING:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CXICONSPACING ');
end;
SM_CYICONSPACING:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CYICONSPACING ');
end;
SM_CXMAXIMIZED:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CXMAXIMIZED ');
end;
SM_CYMAXIMIZED:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CYMAXIMIZED ');
end;
SM_CXMAXTRACK:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CXMAXTRACK ');
end;
SM_CYMAXTRACK:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CYMAXTRACK ');
end;
SM_CXMENUCHECK:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CXMENUCHECK ');
end;
SM_CYMENUCHECK:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CYMENUCHECK ');
end;
SM_CXMENUSIZE:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CXMENUSIZE ');
end;
SM_CYMENUSIZE:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CYMENUSIZE ');
end;
SM_CXMIN:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CXMIN ');
end;
SM_CYMIN:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CYMIN ');
end;
SM_CXMINIMIZED:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CXMINIMIZED ');
end;
SM_CYMINIMIZED:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CYMINIMIZED ');
end;
SM_CXMINSPACING:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CXMINSPACING ');
end;
SM_CYMINSPACING:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CYMINSPACING ');
end;
SM_CXMINTRACK:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CXMINTRACK ');
end;
SM_CYMINTRACK:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CYMINTRACK ');
end;
SM_CXSCREEN:
begin
result := gdk_Screen_Width;
end;
SM_CYSCREEN:
begin
result := gdk_Screen_Height;
end;
SM_CXSIZE:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CXSIZE ');
end;
SM_CYSIZE:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CYSIZE ');
end;
SM_CXSIZEFRAME:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CXSIZEFRAME ');
end;
SM_CYSIZEFRAME:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CYSIZEFRAME ');
end;
SM_CXSMICON:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CXSMICON ');
end;
SM_CYSMICON:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CYSMICON ');
end;
SM_CXSMSIZE:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CXSMSIZE ');
end;
SM_CYSMSIZE:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CYSMSIZE ');
end;
SM_CXVSCROLL:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CXVSCROLL ');
end;
SM_CYVSCROLL:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CYVSCROLL ');
end;
SM_CYCAPTION:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CYCAPTION ');
end;
SM_CYKANJIWINDOW:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CYKANJIWINDOW ');
end;
SM_CYMENU:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CYMENU ');
end;
SM_CYSMCAPTION:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CYSMCAPTION ');
end;
SM_CYVTHUMB:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_CYVTHUMB ');
end;
SM_DBCSENABLED:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_DBCSENABLED ');
end;
SM_DEBUG:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_DEBUG ');
end;
SM_MENUDROPALIGNMENT:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_MENUDROPALIGNMENT');
end;
SM_MIDEASTENABLED:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_MIDEASTENABLED ');
end;
SM_MOUSEPRESENT:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_MOUSEPRESENT ');
end;
SM_MOUSEWHEELPRESENT:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_MOUSEWHEELPRESENT');
end;
SM_NETWORK:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_NETWORK ');
end;
SM_PENWINDOWS:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_PENWINDOWS ');
end;
SM_SECURE:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_SECURE ');
end;
SM_SHOWSOUNDS:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_SHOWSOUNDS ');
end;
SM_SLOWMACHINE:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_SLOWMACHINE ');
end;
SM_SWAPBUTTON:
begin
Assert(False, 'Trace:TODO: [TgtkObject.GetSystemMetrics] --> SM_SWAPBUTTON ');
end;
else Result := 0;
end;
Assert(False, Format('Trace:< [TgtkObject.GetSystemMetrics] %d --> 0x%x (%d)', [nIndex, Result, Result]));
end;
{------------------------------------------------------------------------------
Function: GetTextColor
Params: DC
Returns: TColorRef
Gets the Font Color currently assigned to the Device Context
------------------------------------------------------------------------------}
function TgtkObject.GetTextColor(DC: HDC) : TColorRef;
begin
Result := 0;
if IsValidDC(DC) then
with PDeviceContext(DC)^ do
begin
Result := TGDKColorToTColor(CurrentTextColor);
end;
end;
{------------------------------------------------------------------------------
Function: GetTextExtentPoint
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.GetTextExtentPoint(DC: HDC; Str: PChar; Count: Integer;
var Size: TSize): Boolean;
var
lbearing, rbearing, width, ascent,descent: LongInt;
UseFont : PGDKFont;
UnRef : Boolean;
begin
Assert(False, 'trace:> [TgtkObject.GetTextExtentPoint]');
Result := IsValidDC(DC);
if Result
then with PDeviceContext(DC)^ do
begin
if (CurrentFont = nil) or (CurrentFont^.GDIFontObject = nil)
then begin
UseFont := GetDefaultFont;
UnRef := True;
end
else begin
UseFont := CurrentFont^.GDIFontObject;
UnRef := False;
end;
If UseFont = nil then
WriteLn('WARNING: [TgtkObject.GetTextExtentPoint] Missing font')
else begin
gdk_text_extents(UseFont, Str, Count,
@lbearing, @rBearing, @width, @ascent, @descent);
Size.cX := Width;
//I THINK this is accurate...
Size.cY := GDK_String_Height(UseFont, Str)
{$IfNDef Win32} + descent div 2{$EndIf};
If UnRef then
GDK_Font_UnRef(UseFont);
end;
end;
Assert(False, 'trace:< [TgtkObject.GetTextExtentPoint]');
end;
{------------------------------------------------------------------------------
Function: GetTextMetrics
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.GetTextMetrics(DC: HDC; var TM: TTextMetric): Boolean;
const
TestString = '{Am|g_}';
AVGBuffer : Pchar =
'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz1234567890()|_ ';
var
XT : TSize;
lbearing, rbearing, dummy: LongInt;
UseFont : PGDKFont;
UnRef : Boolean;
begin
Assert(False, Format('Trace:> TODO FINISH[TgtkObject.GetTextMetrics] DC: 0x%x', [DC]));
Result := IsValidDC(DC);
if Result then
with PDeviceContext(DC)^ do begin
if (CurrentFont = nil) or (CurrentFont^.GDIFontObject = nil)
then begin
UseFont := GetDefaultFont;
UnRef := True;
end
else begin
UseFont := CurrentFont^.GDIFontObject;
UnRef := False;
end;
If UseFont = nil then
WriteLn('WARNING: [TgtkObject.GetTGextMetrics] Missing font')
else begin
with TM do begin
FillChar(TM, SizeOf(TM), 0);
gdk_text_extents(UseFont, TestString,
length(TestString), @lbearing, @rBearing, @dummy,
@tmAscent, @tmDescent);
GetTextExtentPoint(DC, AVGBuffer, StrLen(AVGBuffer), XT);
XT.cX := XT.cX div StrLen(AVGBuffer);
tmHeight := XT.cY;
tmAscent := tmHeight - tmDescent;
tmAveCharWidth := XT.cX;
if tmAveCharWidth<2 then tmAveCharWidth:=2;
tmMaxCharWidth := gdk_char_width(UseFont, 'W'); // temp hack
if tmMaxCharWidth<2 then tmMaxCharWidth:=2;
If UnRef then
GDK_Font_UnRef(UseFont);
end;
end;
end;
Assert(False, Format('Trace:< TODO FINISH[TgtkObject.GetTextMetrics] DC: 0x%x', [DC]));
end;
{------------------------------------------------------------------------------
Function: GetWindowLong
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
Function TgtkObject.GetWindowLong(Handle : hwnd; int : Integer): Longint;
var
//Data : Tobject;
P : Pointer;
begin
//TODO:Started but not finished
Assert(False, Format('Trace:> [TgtkObject.GETWINDOWLONG] HWND: 0x%x, int: 0x%x (%d)', [Handle, int, int]));
case int of
GWL_WNDPROC :
begin
Result := Longint(gtk_object_get_data(pgtkobject(Handle),'WNDPROC'));
end;
GWL_HINSTANCE :
begin
Result := Longint(gtk_object_get_data(pgtkobject(Handle),'HINSTANCE'));
end;
GWL_HWNDPARENT :
begin
P := gtk_object_get_data(pgtkobject(Handle),'HWNDPARENT');
if P = nil then Result := 0 else Result := LongInt(p);
end;
{ GWL_WNDPROC :
begin
Data := GetLCLObject(Pointer(Handle));
if Data is TControl
then Result := Longint(@(TControl(Data).WindowProc));
// TODO fix this, a method pointer (2 pointers) cant be casted to a longint
end;
}
{ GWL_HWNDPARENT :
begin
Data := GetLCLObject(Pointer(Handle));
if (Data is TWinControl)
then Result := Longint(TWincontrol(Data).Handle)
else Result := 0;
end;
}
GWL_STYLE :
begin
Result := Longint(gtk_object_get_data(pgtkobject(Handle),'Style'));
end;
GWL_EXSTYLE :
begin
Result := Longint(gtk_object_get_data(pgtkobject(Handle),'ExStyle'));
end;
GWL_USERDATA :
begin
Result := Longint(gtk_object_get_data(pgtkobject(Handle),'Userdata'));
end;
GWL_ID :
begin
Result := Longint(gtk_object_get_data(pgtkobject(Handle),'ID'));
end;
else Result := 0;
end; //case
Assert(False, Format('Trace:< [TgtkObject.GETWINDOWLONG] HWND: 0x%x, int: 0x%x (%d) --> 0x%x (%d)', [Handle, int, int, Result, Result]));
end;
{------------------------------------------------------------------------------
Function: GetWindowOrgEx
Params: none
Returns: Nothing
Returns the x-coordinates and y-coordinates of the window origin for the
specified device context.
------------------------------------------------------------------------------}
function TgtkObject.GetWindowOrgEx(dc : hdc; var P : TPoint): Integer;
var
DCOrigin: TPoint;
begin
// gdk_window_get_deskrelative_origin(pgtkwidget(PdeviceContext(dc)^.hwnd)^.window, @P.X, @P.Y);
//write('[TgtkObject.GetWindowOrgEx] ',p.x,' ',p.y);
// gdk_window_get_root_origin(pgtkwidget(PdeviceContext(dc)^.hwnd)^.window, @P.X, @P.Y);
//write(' / ',p.x,' ',p.y);
Result := 0;
P := Point(0,0);
// ToDo: fix this, when Designer is ready
If IsValidDC(DC) then
with PDeviceContext(DC)^ do begin
DCOrigin:=GetDCOffset(PDeviceContext(DC));
if Drawable<>nil then begin
gdk_window_get_origin(PGdkWindow(Drawable), @P.X, @P.Y);
inc(P.X,DCOrigin.X);
inc(P.Y,DCOrigin.Y);
Result := 1;
end else begin
writeln('TgtkObject.GetWindowOrgEx:',
' WARNING: DC ',HexStr(Cardinal(DC),8),' without gdkwindow.',
' Widget=',HexStr(Cardinal(hwnd),8));
end;
end;
//writeln(' / ',p.x,' ',p.y);
end;
{------------------------------------------------------------------------------
Function: GetWindowRect
Params: none
Returns: 0
After the call, Rect will be the control area in screen coordinates.
That means, Left and Top will be the screen coordinate of the TopLeft pixel
of the Handle object and Right and Bottom will be the screen coordinate of
the BottomRight pixel.
------------------------------------------------------------------------------}
function TgtkObject.GetWindowRect(Handle: hwnd; var ARect: TRect): Integer;
var
X, Y, W, H: Integer;
Widget: PGTKWidget;
begin
//Writeln('GetWindowRect');
Result := 0; //default
if Handle <> 0 then
begin
Widget := pgtkwidget(Handle);
if Widget^.Window <> nil then Begin
gdk_window_get_origin(Widget^.Window, @X, @Y);
gdk_window_get_size(Widget^.Window, @W, @H);
end
else
Begin
X := 0;
Y := 0;
W := 100;
Y := 200;
end;
ARect:=Rect(X,Y,X+W,Y+H);
end;
end;
{------------------------------------------------------------------------------
Function: GetWindowSize
Params: Handle : hwnd;
Returns: true on success
returns the current widget Width and Height
------------------------------------------------------------------------------}
Function TgtkObject.GetWindowSize(Handle : hwnd;
var Width, Height: integer): boolean;
begin
if Handle<>0 then begin
Result:=true;
Width:=PGtkWidget(Handle)^.Allocation.Width;
Height:=PGtkWidget(Handle)^.Allocation.Height;
end else
Result:=false;
end;
{------------------------------------------------------------------------------
Function: HideCaret
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.HideCaret(hWnd: HWND): Boolean;
var
GTKObject: PGTKObject;
begin
//writeln('[TgtkObject.HideCaret] A');
Assert(False, Format('Trace: [TgtkObject.HideCaret] HWND: 0x%x', [hWnd]));
//TODO: [TgtkObject.HideCaret] Finish (in gtkwinapi.inc)
GTKObject := PGTKObject(HWND);
Result := GTKObject <> nil;
if Result
then begin
if gtk_type_is_a(gtk_object_type(GTKObject), GTKAPIWidget_GetType)
then begin
GTKAPIWidget_HideCaret(PGTKAPIWidget(GTKObject));
end
// else if // TODO: other widgettypes
else begin
Result := False;
end;
end
else WriteLn('WARNING: [TgtkObject.HideCaret] Got null HWND');
end;
{------------------------------------------------------------------------------
Function: IntersectClipRect
Params: dc: hdc; Left, Top, Right, Bottom: Integer
Returns: Integer
Shrinks the clipping region in the device context dc to a region of all
intersecting points between the boundary defined by Left, Top, Right,
Bottom , and the Current clipping region.
The result can be one of the following constants
Error
NullRegion
SimpleRegion
ComplexRegion
------------------------------------------------------------------------------}
function TGTKObject.IntersectClipRect(dc: hdc;
Left, Top, Right, Bottom: Integer): Integer;
begin
If not IsValidDC(DC) then
Result := ERROR;
if Result <> ERROR
then with PDeviceContext(DC)^ do
begin
if GC = nil
then begin
WriteLn('WARNING: [TgtkObject.IntersectClipRect] Uninitialized GC');
Result := ERROR;
end
else begin
Result := Inherited IntersectClipRect(DC, Left, Top, Right, Bottom);
end;
end;
end;
{------------------------------------------------------------------------------
Function: InvalidateRect
Params: aHandle:
Rect:
bErase:
Returns:
------------------------------------------------------------------------------}
function TGTKObject.InvalidateRect(aHandle : HWND; Rect : pRect;
bErase : Boolean) : Boolean;
var
gdkRect : TGDKRectangle;
Widget: PGtkWidget;
begin
// Writeln(format('Rect = %d,%d,%d,%d',[rect^.left,rect^.top,rect^.Right,rect^.Bottom]));
Result := True;
gdkRect.X := Rect^.Left;
gdkRect.Y := Rect^.Top;
gdkRect.Width := (Rect^.Right - Rect^.Left);
gdkRect.Height := (Rect^.Bottom - Rect^.Top);
Widget:=GetFixedWidget(PGtkWidget(aHandle));
if Widget=nil then Widget:=PgtkWidget(aHandle);
if bErase then
gdk_window_clear_area(Widget^.Window,
gdkRect.X,gdkRect.Y,gdkRect.Width,gdkRect.Height);
gtk_widget_draw(Widget, @gdkRect);
end;
{------------------------------------------------------------------------------
Function: KillTimer
Params: hWnd:
nIDEvent:
Returns:
WARNING: There seems to be a bug in gtk-1.2.x which breaks gtk_timeout_remove
thus we can't dispose PGtkITimerinfo here (s.a. gtkTimerCB).
------------------------------------------------------------------------------}
function TGTKObject.KillTimer (hWnd : HWND; uIDEvent : cardinal) : boolean;
var
n : integer;
p : PGtkITimerinfo;
begin
Assert(False, 'Trace:removing timer!!!');
n := FTimerData.Count;
while (n > 0) do begin
dec (n);
p := PGtkITimerinfo (FTimerData.Items[n]);
if ((pointer (hWnd) <> nil) and (hWnd = p^.Handle)) or
((pointer(hWnd) = nil) and (uIDEvent = p^.IDEvent)) then
begin
gtk_timeout_remove (uIDEvent);
pointer (p^.Handle) := nil; // mark as invalid
p^.TimerFunc := nil;
FTimerData.Delete (n);
FOldTimerData.Add(p);
// Dispose (p); // this will be done in gtkTimerCB!
end;
end;
Result:=true;
end;
{------------------------------------------------------------------------------
Function: LineTo
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.LineTo(DC: HDC; X, Y: Integer): Boolean;
var
DCOrigin: TPoint;
begin
Assert(False, Format('trace:> [TgtkObject.LineTo] DC:0x%x, X:%d, Y:%d', [DC, X, Y]));
Result := IsValidDC(DC);
if Result
then with PDeviceContext(DC)^ do
begin
if GC = nil
then begin
WriteLn('WARNING: [TgtkObject.LineTo] Uninitialized GC');
Result := False;
end
else begin
DCOrigin:=GetDCOffset(PDeviceContext(DC));
SelectGDKPenProps(DC);
gdk_draw_line(Drawable, GC, PenPos.X+DCOrigin.X, PenPos.Y+DCOrigin.Y,
X+DCOrigin.X, Y+DCOrigin.Y);
PenPos:= Point(X, Y);
Result := True;
end;
end;
Assert(False, Format('trace:< [TgtkObject.LineTo] DC:0x%x, X:%d, Y:%d', [DC, X, Y]));
end;
{------------------------------------------------------------------------------
Function: MaskBlt
Params: DestDC: The destination devicecontext
X, Y: The left/top corner of the destination rectangle
Width, Height: The size of the destination rectangle
SrcDC: The source devicecontext
XSrc, YSrc: The left/top corner of the source rectangle
Mask: The handle of a monochrome bitmap
XMask, YMask: The left/top corner of the mask rectangle
Rop: The raster operation to be performed
Returns: True if succesful
The MaskBlt function copies a bitmap from a source context into a destination
context using the specified mask and raster operation.
------------------------------------------------------------------------------}
function TgtkObject.MaskBlt(DestDC: HDC; X, Y, Width, Height: Integer;
SrcDC: HDC; XSrc, YSrc: Integer; Mask: HBITMAP; XMask, YMask: Integer;
Rop: DWORD): Boolean;
begin
Result:=false;
end;
{------------------------------------------------------------------------------
Function: MessageBox
Params: hWnd: The handle of parent window
Returns: 0 if not successful (out of memory), otherwise one of the defined value :
IDABORT, IDCANCEL, IDIGNORE, IDNO, IDOK, IDRETRY, IDYES
The MessageBox function displays a modal dialog, with text and caption defined,
and includes buttons.
------------------------------------------------------------------------------}
function MessageButtonClicked(Widget : PGtkWidget; data: gPointer) : GBoolean; cdecl;
begin
writeln('[MessageButtonClicked] ',Integer(data^),' ',Integer(gtk_object_get_data(PGtkObject(Widget), 'modal_result')));
if Integer(data^) = 0 then
Integer(data^):= Integer(gtk_object_get_data(PGtkObject(Widget), 'modal_result'));
Result:=false;
end;
function MessageBoxClosed(Widget : PGtkWidget; Event : PGdkEvent; data: gPointer) : GBoolean; cdecl;
var ModalResult : integer;
begin
{ We were requested by window manager to close }
if Integer(data^) = 0 then begin
ModalResult:= Integer(gtk_object_get_data(PGtkObject(Widget), 'modal_result'));
{ Don't allow to close if we don't have a default return value }
Result:= (ModalResult = 0);
if not Result then Integer(data^):= ModalResult
else WriteLn('Do not close !!!');
end else Result:= false;
end;
function TgtkObject.MessageBox(hWnd: HWND; lpText, lpCaption: PChar;
uType : Cardinal): integer;
var Dialog, ALabel : PGtkWidget;
ButtonCount, DefButton, ADialogResult : Integer;
DialogType : Cardinal;
procedure CreateButton(const ALabel : PChar; const RetValue : integer);
var AButton : PGtkWidget;
begin
AButton:= gtk_button_new_with_label(ALabel);
Inc(ButtonCount);
if ButtonCount = DefButton then begin
gtk_window_set_focus(PGtkWindow(Dialog), AButton);
end;
{ If there is the Cancel button, allow the dialog to close }
if RetValue = IDCANCEL then begin
gtk_object_set_data(PGtkObject(Dialog), 'modal_result', Pointer(IDCANCEL));
end;
gtk_object_set_data(PGtkObject(AButton), 'modal_result', Pointer(RetValue));
gtk_signal_connect(PGtkObject(AButton), 'clicked', TGtkSignalFunc(@MessageButtonClicked), @ADialogResult);
gtk_container_add (PGtkContainer(PGtkDialog(Dialog)^.action_area), AButton);
end;
begin
ButtonCount:= 0;
{ Determine which is the default button }
DefButton:= ((uType and $00000300) shr 8) + 1;
Assert(False, 'Trace:Default button is ' + IntToStr(DefButton));
ADialogResult:= 0;
Dialog:= gtk_dialog_new;
gtk_signal_connect(PGtkObject(Dialog), 'delete-event', TGtkSignalFunc(@MessageBoxClosed), @ADialogResult);
gtk_window_set_default_size(PGtkWindow(Dialog), 100, 100);
ALabel:= gtk_label_new(lpText);
gtk_container_add (PGtkContainer(PGtkDialog(Dialog)^.vbox), ALabel);
DialogType:= (uType and $0000000F);
if DialogType = MB_OKCANCEL
then begin
CreateButton(SOK, IDOK);
CreateButton(SCancel, IDCANCEL);
end
else begin
if DialogType = MB_ABORTRETRYIGNORE
then begin
CreateButton(SAbort, IDABORT);
CreateButton(SRetry, IDRETRY);
CreateButton(SIgnore, IDIGNORE);
end
else begin
if DialogType = MB_YESNOCANCEL
then begin
CreateButton(SYes, IDYES);
CreateButton(SNo, IDNO);
CreateButton(SCancel, IDCANCEL);
end
else begin
if DialogType = MB_YESNO
then begin
CreateButton(SYes, IDYES);
CreateButton(SNo, IDNO);
end
else begin
if DialogType = MB_RETRYCANCEL
then begin
CreateButton(SRetry, IDRETRY);
CreateButton(SCancel, IDCANCEL);
end
else begin
{ We have no buttons to show. Create the default of OK button }
CreateButton(SOK, IDOK);
end;
end;
end;
end;
end;
gtk_window_set_title(PGtkWindow(Dialog), lpCaption);
gtk_window_set_position(PGtkWindow(Dialog), GTK_WIN_POS_CENTER);
gtk_window_set_modal(PGtkWindow(Dialog), true);
gtk_widget_show_all(Dialog);
while ADialogResult = 0 do begin
Application.HandleMessage;
end;
DestroyWidget(Dialog);
Result:= ADialogResult;
end;
{------------------------------------------------------------------------------
Function: MoveToEx
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.MoveToEx(DC: HDC; X, Y: Integer; OldPoint: PPoint): Boolean;
begin
Assert(False, Format('trace:> [TgtkObject.MoveToEx] DC:0x%x, X:%d, Y:%d', [DC, X, Y]));
Result := IsValidDC(DC);
if Result
then with PDeviceContext(DC)^ do
begin
if OldPoint <> nil then OldPoint^ := PenPos;
PenPos := Point(X, Y);
end;
Assert(False, Format('trace:< [TgtkObject.MoveToEx] DC:0x%x, X:%d, Y:%d', [DC, X, Y]));
end;
{------------------------------------------------------------------------------
function MoveWindowOrgEx(DC: HDC; dX, dY: Integer): Boolean; override;
Move the origin of all operations of a DeviceContext.
For example:
Moving the Origin to 10,20 and drawing a point to 50,50, results in
drawing a point to 60,70.
------------------------------------------------------------------------------}
function TgtkObject.MoveWindowOrgEx(DC: HDC; dX, dY: Integer): Boolean;
begin
Result:=IsValidDC(DC);
if Result then
with PDeviceContext(DC)^ do begin
//writeln('[TgtkObject.MoveWindowOrgEx] B DC=',HexStr(Cardinal(DC),8),
// ' Old=',Origin.X,',',Origin.Y,' d=',dX,',',dY,' ');
inc(Origin.X,dX);
inc(Origin.Y,dY);
end;
end;
{------------------------------------------------------------------------------
Function: PeekMessage
Params: lpMsg - Where it should put the message
Handle - Handle of the window (thread)
wMsgFilterMin- Lowest MSG to grab
wMsgFilterMax- Highest MSG to grab
wRemoveMsg - Should message be pulled out of the queue
Returns: Boolean if an event was there
------------------------------------------------------------------------------}
function TgtkObject.PeekMessage(var lpMsg: TMsg; Handle : HWND;
wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): Boolean;
var
AMessage: PMsg;
begin
//TODO Filtering
Result := FMessageQueue.Count > 0;
if Result
then begin
AMessage := FMessageQueue.First^.Data;
lpMsg := AMessage^;
if (wRemoveMsg and PM_REMOVE) = PM_REMOVE
then begin
if (AMessage^.Message=LM_PAINT) or (AMessage^.Message=LM_GtkPAINT) then
begin
FPaintMessages.Remove(FMessageQueue.First);
// don't free the DC, this is work for the caller
end;
FMessageQueue.Delete(FMessageQueue.First);
end;
end;
end;
{------------------------------------------------------------------------------
Method: Pie
Params: DC,x,y,width,height,angle1,angle2
Returns: Nothing
Use Pie to draw a filled pie-shaped wedge on the canvas.
The angles angle1 and angle2 are 1/16th of a degree. For example, a full
circle equals 5760 (16*360). Positive values of Angle and AngleLength mean
counter-clockwise while negative values mean clockwise direction.
Zero degrees is at the 3'o clock position.
------------------------------------------------------------------------------}
function TgtkObject.Pie(DC: HDC;
x,y,width,height,angle1,angle2 : Integer): Boolean;
begin
Result := IsValidDC(DC);
if Result
then with PDeviceContext(DC)^ do
begin
if GC = nil
then begin
WriteLn('WARNING: [TgtkObject.Pie] Uninitialized GC');
Result := False;
end
else
Result := Inherited Pie(DC, x, y, width, height, angle1, angle2);
end;
end;
{------------------------------------------------------------------------------
Method: PolyBezier
Params: DC, Points, NumPts, Filled, Continous
Returns: Boolean
Use Polybezier to draw cubic B<>zier curves. The first curve is drawn from the
first point to the fourth point with the second and third points being the
control points. If the Continuous flag is TRUE then each subsequent curve
requires three more points, using the end-point of the previous Curve as its
starting point, the first and second points being used as its control points,
and the third point its end-point. If the continous flag is set to FALSE,
then each subsequent Curve requires 4 additional points, which are used
excatly as in the first curve. Any additonal points which do not add up to
a full bezier(4 for Continuous, 3 otherwise) are ingored. There must be at
least 4 points for an drawing to occur. If the Filled Flag is set to TRUE
then the resulting Poly-B<>zier will be drawn as a Polygon.
------------------------------------------------------------------------------}
Function TgtkObject.PolyBezier(DC: HDC; Points: PPoint; NumPts: Integer;
Filled, Continuous: Boolean): Boolean;
Begin
Result := IsValidDC(DC);
if Result
then with PDeviceContext(DC)^ do
begin
if GC = nil
then begin
WriteLn('WARNING: [TgtkObject.Polygon] Uninitialized GC');
Result := False;
end
else
Result := Inherited PolyBezier(DC, Points, NumPts, Filled, Continuous);
end;
End;
{------------------------------------------------------------------------------
Method: TCanvas.Polygon
Params: DC: HDC; Points: ^TPoint; NumPts: integer; Winding: Boolean;
Returns: Nothing
Use Polygon to draw a closed, many-sided shape on the canvas, using the value
of Pen. After drawing the complete shape, Polygon fills the shape using the
value of Brush.
The Points parameter is an array of points that give the vertices of the
polygon.
Winding determines how the polygon is filled. When Winding is True, Polygon
fills the shape using the Winding fill algorithm. When Winding is False,
Polygon uses the even-odd (alternative) fill algorithm.
NumPts indicates the number of points to use.
The first point is always connected to the last point.
To draw a polygon on the canvas, without filling it, use the Polyline method,
specifying the first point a second time at the end.
}
function TgtkObject.Polygon(DC: HDC; Points: PPoint; NumPts: Integer;
Winding: Boolean): boolean;
var
i: integer;
PointArray: PGDKPoint;
Tmp, RGN : hRGN;
ClipRect : TRect;
DCOrigin: Tpoint;
begin
Result := IsValidDC(DC);
if Result
then with PDeviceContext(DC)^ do
begin
if GC = nil
then begin
WriteLn('WARNING: [TgtkObject.Polygon] Uninitialized GC');
Result := False;
end
else begin
DCOrigin:=GetDCOffset(PDeviceContext(DC));
if NumPts<=0 then exit;
GetMem(PointArray,SizeOf(TGdkPoint)*NumPts);
for i:=0 to NumPts-1 do begin
PointArray[i].x:=Points[i].x+DCOrigin.X;
PointArray[i].y:=Points[i].y+DCOrigin.Y;
end;
If (Points[NumPts-1].X <> Points[0].X) or
(Points[NumPts-1].Y <> Points[0].Y)
then begin
Inc(NumPts);
ReallocMem(PointArray,SizeOf(TGdkPoint)*NumPts);
PointArray[NumPts - 1].x:=Points[0].x+DCOrigin.X;
PointArray[NumPts - 1].y:=Points[0].y+DCOrigin.Y;
end;
// first draw interior in brush color
SelectGDKBrushProps(DC);
if Winding then begin
Tmp := CreateRectRGN(0,0,0,0);
GetClipRGN(DC, Tmp);
RGN := CreatePolygonRgn(Points, NumPts, True);
ExtSelectClipRGN(DC, RGN, RGN_AND);
DeleteObject(RGN);
GetClipBox(DC, @ClipRect);
FillRect(DC, ClipRect, HBrush(CurrentBrush));
SelectClipRGN(DC, Tmp);
DeleteObject(Tmp);
end else
gdk_draw_polygon(Drawable, GC, 1, PointArray, NumPts);
// draw outline
SelectGDKPenProps(DC);
gdk_draw_polygon(Drawable, GC, 0, PointArray, NumPts);
FreeMem(PointArray);
Result := True;
end;
end;
end;
function TgtkObject.Polyline(DC: HDC; Points: PPoint; NumPts: Integer): boolean;
var i: integer;
PointArray: PGDKPoint;
DCOrigin: TPoint;
begin
Result := IsValidDC(DC);
if Result
then with PDeviceContext(DC)^ do
begin
if GC = nil
then begin
WriteLn('WARNING: [TgtkObject.Polyline] Uninitialized GC');
Result := False;
end
else begin
if NumPts<=0 then exit;
DCOrigin:=GetDCOffset(PDeviceContext(DC));
GetMem(PointArray,SizeOf(TGdkPoint)*NumPts);
for i:=0 to NumPts-1 do begin
PointArray[i].x:=Points[i].x+DCOrigin.X;
PointArray[i].y:=Points[i].y+DCOrigin.Y;
end;
// draw outline
SelectGDKPenProps(DC);
gdk_draw_lines(Drawable, GC, PointArray, NumPts);
FreeMem(PointArray);
Result := True;
end;
end;
end;
{------------------------------------------------------------------------------
Function: PostMessage
Params: Handle:
Msg:
wParam:
lParam:
Returns: True if succesful
The PostMessage function places (posts) a message in the message queue and
then returns without waiting.
------------------------------------------------------------------------------}
function TGTKObject.PostMessage(Handle: HWND; Msg: Cardinal; wParam: LongInt;
lParam: LongInt): Boolean;
procedure DeletePaintMessageForHandle(hnd: HWnd);
var
OldPaintMessage: PLazQueueItem;
OldMessage: PMsg;
begin
if (hnd=0) then exit;
OldPaintMessage:=FindPaintMessage(hnd);
if OldPaintMessage<>nil then begin
// delete paint message from queue
OldMessage:=PMsg(OldPaintMessage^.Data);
FPaintMessages.Remove(OldPaintMessage);
FMessageQueue.Delete(OldPaintMessage);
if OldMessage^.Message=LM_PAINT then
ReleaseDC(0,OldMessage^.WParam);
Dispose(OldMessage);
end;
end;
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 the main 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);
end else begin
FMessageQueue.AddLast(AMessage);
end;
end;
{------------------------------------------------------------------------------
Method: RadialArc
Params: DC,x,y,width,height,sx,sy,ex,ey
Returns: Nothing
Use RadialArc to draw an elliptically curved line with the current Pen. The
values sx,sy, and ex,ey represent the starting and ending radial-points
between which the Arc is drawn.
------------------------------------------------------------------------------}
function TgtkObject.RadialArc(DC: HDC; x,y,width,height,sx,sy,ex,ey : Integer): Boolean;
Begin
Result := IsValidDC(DC);
if Result
then with PDeviceContext(DC)^ do
begin
if GC = nil
then begin
WriteLn('WARNING: [TgtkObject.RadialArc] Uninitialized GC');
Result := False;
end
else
Result := Inherited RadialArc(DC, x, y, width, height, sx,sy,ex,ey);
end;
End;
{------------------------------------------------------------------------------
Method: RadialChord
Params: DC,x,y,width,height,sx,sy,ex,ey
Returns: Nothing
Use RadialChord to draw a filled Chord-shape on the canvas. The values sx,sy,
and ex,ey represent the starting and ending radial-points between which
the bounding-Arc is drawn.
------------------------------------------------------------------------------}
function TgtkObject.RadialChord(DC: HDC; x,y,width,height,sx,sy,ex,ey : Integer): Boolean;
begin
Result := IsValidDC(DC);
if Result
then with PDeviceContext(DC)^ do
begin
if GC = nil
then begin
WriteLn('WARNING: [TgtkObject.RadialChord] Uninitialized GC');
Result := False;
end
else
Result := Inherited RadialChord(DC, x, y, width, height, sx,sy,ex,ey);
end;
End;
{------------------------------------------------------------------------------
Method: RadialPie
Params: DC,x,y,width,height,sx,sy,ex,ey
Returns: Nothing
Use RadialPie to draw a filled Pie-shaped Wedge on the canvas. The values
sx,sy, and ex,ey represent the starting and ending radial-points between which
the bounding-Arc is drawn.
------------------------------------------------------------------------------}
function TgtkObject.RadialPie(DC: HDC; x,y,width,height,sx,sy,ex,ey : Integer): Boolean;
begin
Result := IsValidDC(DC);
if Result
then with PDeviceContext(DC)^ do
begin
if GC = nil
then begin
WriteLn('WARNING: [TgtkObject.RadialPie] Uninitialized GC');
Result := False;
end
else
Result := Inherited RadialPie(DC, x, y, width, height, sx,sy,ex,ey);
end;
end;
{------------------------------------------------------------------------------
Function: RadioMenuItemGroup
Params: hndMenu: HMENU; bRadio: Boolean
Returns: Nothing
Change the group of menuitems to 'radio' or to 'checked'.
------------------------------------------------------------------------------}
function TgtkObject.RadioMenuItemGroup(hndMenu: HMENU; bRadio: Boolean): Boolean;
var
LCLMenuItem: TMenuItem;
begin
LCLMenuItem:=TMenuItem(GetLCLObject(Pointer(hndMenu)));
if LCLMenuItem<>nil then begin
LCLMenuItem.RecreateHandle;
Result:=true;
end else
Result := false;
end;
{------------------------------------------------------------------------------
Function: RealizePalette
Params: DC: HDC
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.RealizePalette(DC: HDC): Cardinal;
begin
Assert(False, 'Trace:TODO: [TgtkObject.RealizePalette]');
//TODO: Implement this;
Result := 0;
end;
{------------------------------------------------------------------------------
Function: Rectangle
Params: DC: HDC; X1, Y1, X2, Y2: Integer
Returns: Nothing
The Rectangle function draws a rectangle. The rectangle is outlined by using
the current pen and filled by using the current brush.
------------------------------------------------------------------------------}
function TgtkObject.Rectangle(DC: HDC; X1, Y1, X2, Y2: Integer): Boolean;
var
Width, Height: Integer;
DCOrigin: TPoint;
begin
Assert(False, Format('trace:> [TgtkObject.Rectangle] DC:0x%x, X1:%d, Y1:%d, X2:%d, Y2:%d', [DC, X1, Y1, X2, Y2]));
Result := IsValidDC(DC);
if Result
then with PDeviceContext(DC)^ do
begin
if GC = nil
then begin
WriteLn('WARNING: [TgtkObject.Rectangle] Uninitialized GC');
Result := False;
end
else begin
Width := X2 - X1;
Height := Y2 - Y1;
// first draw interior in brush color
SelectGDKBrushProps(DC);
DCOrigin:=GetDCOffset(PDeviceContext(DC));
gdk_draw_rectangle(Drawable, GC, 1, X1+DCOrigin.X, Y1+DCOrigin.Y,
Width, Height);
// Draw outline
SelectGDKPenProps(DC);
gdk_draw_rectangle(Drawable, GC, 0, X1+DCOrigin.X, Y1+DCOrigin.Y,
Width, Height);
Result := True;
end;
end;
Assert(False, Format('trace:< [TgtkObject.Rectangle] DC:0x%x, X1:%d, Y1:%d, X2:%d, Y2:%d', [DC, X1, Y1, X2, Y2]));
end;
{------------------------------------------------------------------------------
Function: RectVisible
Params: dc : hdc; ARect: TRect
Returns: True if ARect is not completely clipped away.
------------------------------------------------------------------------------}
function TgtkObject.RectVisible(dc : hdc; ARect: TRect) : Boolean;
begin
Result:=true;
end;
{------------------------------------------------------------------------------
Function: RegroupMenuItem
Params: hndMenu: HMENU; GroupIndex: integer
Returns: Nothing
Move a menuitem into another group
------------------------------------------------------------------------------}
function TgtkObject.RegroupMenuItem(hndMenu: HMENU;
GroupIndex: Integer): Boolean;
var
RadioGroup: PGSList;
begin
if GTK_IS_RADIO_MENU_ITEM(Pointer(hndMenu)) then begin
// set group
RadioGroup:=GetRadioMenuItemGroup(PGtkRadioMenuItem(hndMenu));
gtk_radio_menu_item_set_group(PGtkRadioMenuItem(hndMenu),RadioGroup);
RadioGroup:=gtk_radio_menu_item_group(PGtkRadioMenuItem(hndMenu));
UpdateRadioGroupChecks(RadioGroup);
Result:=true;
end else
Result:=false;
end;
{------------------------------------------------------------------------------
Function: ReleaseCapture
Params: none
Returns: True if succesful
The ReleaseCapture function releases the mouse capture from a window
and restores normal mouse input processing.
------------------------------------------------------------------------------}
function TgtkObject.ReleaseCapture: Boolean;
begin
SetCapture(0);
Result := True;
end;
{------------------------------------------------------------------------------
Function: ReleaseDC
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.ReleaseDC(hWnd: HWND; DC: HDC): Integer;
var
pDC, pSavedDC: PDeviceContext;
begin
//writeln('[TgtkObject.ReleaseDC] ',HexStr(DC,8),' ',FDeviceContexts.Count);
Assert(False, Format('trace:> [TgtkObject.ReleaseDC] DC:0x%x', [DC]));
Result := 0;
if {(hWnd <> 0) and} (DC <> 0)
then begin
if FDeviceContexts.Contains(Pointer(DC))
then begin
pDC := PDeviceContext(DC);
{ Release all saved device contexts }
pSavedDC:=pDC^.SavedContext;
if pSavedDC<>nil then begin
if pSavedDC^.CurrentBitmap = pDC^.CurrentBitmap
then pDC^.CurrentBitmap := nil;
if pSavedDC^.CurrentFont = pDC^.CurrentFont
then pDC^.CurrentFont := nil;
if pSavedDC^.CurrentPen = pDC^.CurrentPen
then pDC^.CurrentPen := nil;
if pSavedDC^.CurrentBrush = pDC^.CurrentBrush
then pDC^.CurrentBrush := nil;
if pSavedDC^.ClipRegion = pDC^.ClipRegion
then pSavedDC^.ClipRegion := 0;
ReleaseDC(0,HDC(pSavedDC));
pDC^.SavedContext:=nil;
end;
{ Release all graphic objects }
DeleteObject(HGDIObj(pDC^.CurrentBrush));
DeleteObject(HGDIObj(pDC^.CurrentPen));
DeleteObject(HGDIObj(pDC^.CurrentFont));
DeleteObject(HGDIObj(pDC^.CurrentBitmap));
DeleteObject(HGDIObj(pDC^.ClipRegion));
try
{ On root window, we don't allocate a graphics context and so we dont free}
if pDC^.GC <> nil then begin
gdk_gc_unref(pDC^.GC);
pDC^.GC:=nil;
end;
except
on E:Exception do begin
//Nothing, just try to unref it
//(it segfaults if the window doesnt exist anymore :-)
writeln('TgtkObject.ReleaseDC: ',E.Message);
end;
end;
DisposeDC(pDC);
Result := 1;
end;
end;
Assert(False, Format('trace:< [TgtkObject.ReleaseDC] FDeviceContexts DC:0x%x', [DC]));
end;
{------------------------------------------------------------------------------
Function: RestoreDC
Params: none
Returns: Nothing
-------------------------------------------------------------------------------}
function TgtkObject.RestoreDC(DC: HDC; SavedDC: Integer): Boolean;
var
pDC, pSavedDC: PDeviceContext;
Count: Integer;
begin
Assert(False, Format('Trace:> [TgtkObject.RestoreDC] DC:0x%x, SavedDC: %d', [DC, SavedDC]));
Result := IsValidDC(DC) and (SavedDC <> 0);
if Result
then begin
pSavedDC := PDeviceContext(DC);
Count:=Abs(SavedDC);
while (Count>0) and (pSavedDC<>nil) do begin
pDC:=pSavedDC;
pSavedDC:=pDC^.SavedContext;
dec(Count);
end;
// TODO copy bitmap also
if (pDC^.ClipRegion<>0) and (pSavedDC^.ClipRegion <> pDC^.ClipRegion) then
begin
// clipping region has changed
// clipping regions are extraordinary gdiobjects. Users can not set them
// or read them. If a clipping region is changed, it is always created new
// -> destroy the current clipping region
DeleteObject(pDC^.ClipRegion);
pDC^.ClipRegion := 0;
end;
if pDC^.GC<>nil then begin
gdk_gc_unref(pDC^.GC);
pDC^.GC:=nil;
end;
Result := CopyDCData(pDC, pSavedDC);
pDC^.SavedContext := pSavedDC^.SavedContext;
pSavedDC^.SavedContext := nil;
//prevent deleting of copied objects:
if pSavedDC^.CurrentBitmap = pDC^.CurrentBitmap
then pSavedDC^.CurrentBitmap := nil;
if pSavedDC^.CurrentFont = pDC^.CurrentFont
then pSavedDC^.CurrentFont := nil;
if pSavedDC^.CurrentPen = pDC^.CurrentPen
then pSavedDC^.CurrentPen := nil;
if pSavedDC^.CurrentBrush = pDC^.CurrentBrush
then pSavedDC^.CurrentBrush := nil;
if pSavedDC^.CurrentBrush = pDC^.CurrentBrush
then pSavedDC^.CurrentBrush := nil;
if pSavedDC^.ClipRegion = pDC^.ClipRegion
then pSavedDC^.ClipRegion := 0;
DeleteDC(HGDIOBJ(pSavedDC));
end;
Assert(False, Format('Trace:< [TgtkObject.RestoreDC] DC:0x%x, Saved: %d --> %s', [Integer(DC), SavedDC, BOOL_TEXT[Result]]));
end;
{------------------------------------------------------------------------------
Function: RightJustifyMenuItem
Params: HndMenu: HMenu; bRightJustify: boolean
Returns: true on success
Sets left or justification of a menuitem
-------------------------------------------------------------------------------}
function TgtkObject.RightJustifyMenuItem(HndMenu: HMenu;
bRightJustify: boolean): Boolean;
var
MenuItemWidget: PGtkMenuItem;
begin
MenuItemWidget:=PGtkMenuItem(HndMenu);
if bRightJustify then
MenuItemWidget^.flag0:=MenuItemWidget^.flag0 or bm_right_justify
else
MenuItemWidget^.flag0:=MenuItemWidget^.flag0 and (not bm_right_justify);
gtk_widget_queue_resize(GTK_WIDGET(MenuItemWidget));
Result:=false;
end;
{------------------------------------------------------------------------------
Function: SaveDc
Params: DC: a DC to save
Returns: 0 if the functions fails otherwise a positive integer identifing
the saved DC
The SaveDC function saves the current state of the specified device
context (DC) by copying its elements to a context stack.
-------------------------------------------------------------------------------}
function TgtkObject.SaveDC(DC: HDC): Integer;
var
pDC, pSavedDC: PDeviceContext;
begin
Assert(False, Format('Trace:> [TgtkObject.SaveDC] 0x%x', [Integer(DC)]));
Result := 0;
if IsValidDC(DC)
then begin
pDC := PDeviceContext(DC);
pSavedDC := NewDC;
CopyDCData(pSavedDC, pDC);
pSavedDC^.SavedContext:=pDC^.SavedContext;
pDC^.SavedContext:= pSavedDC;
Result:=1;
end;
Assert(False, Format('Trace:< [TgtkObject.SaveDC] 0x%x --> %d', [Integer(DC), Result]));
end;
{------------------------------------------------------------------------------
Function: ScreenToClient
Params: Handle:
P:
Returns:
------------------------------------------------------------------------------}
Function TGTKObject.ScreenToClient(Handle : HWND; var P : TPoint) : Integer;
var
X, Y: Integer;
Widget: PGTKWidget;
Begin
if Handle = 0
then begin
X := 0;
Y := 0;
end
else
begin
Widget := GetFixedWidget(pgtkwidget(Handle));
if Widget = nil then
Widget := pgtkwidget(Handle);
if Widget = nil then
begin
X := 0;
Y := 0;
end
else
gdk_window_get_origin(Widget^.Window, @X, @Y);
end;
//writeln('[TGTKObject.ScreenToClient] ',x,',',y,' P=',P.X,',',P.Y);
dec(P.X, X);
dec(P.Y, Y);
Result := -1;
end;
{------------------------------------------------------------------------------
Function: ScrollWindowEx
Params: hWnd: handle of window to scroll
dx: horizontal amount to scroll
dy: vertical amount to scroll
prcScroll: pointer to scroll rectangle
prcClip: pointer to clip rectangle
hrgnUpdate: handle of update region
prcUpdate: pointer to update rectangle
flags: scrolling flags
Returns: True if succesfull;
The ScrollWindowEx function scrolls the content of the specified window's
client area
------------------------------------------------------------------------------}
function TgtkObject.ScrollWindowEx(hWnd: HWND; dx, dy: Integer; prcScroll, prcClip: PRect; hrgnUpdate: HRGN; prcUpdate: PRect; flags: UINT): Boolean;
begin
Result := False;
end;
{------------------------------------------------------------------------------
Function: SelectClipRGN
Params: DC, RGN
Returns: longint
Sets the DeviceContext's ClipRegion. The Return value
is the new clip regions type, or ERROR.
The result can be one of the following constants
Error
NullRegion
SimpleRegion
ComplexRegion
------------------------------------------------------------------------------}
Function TgtkObject.SelectClipRGN(DC : hDC; RGN : HRGN) : Longint;
begin
If not IsValidDC(DC) then
Result := ERROR;
if Result <> ERROR then
with PDeviceContext(DC)^ do
begin
if (GC = nil) and (RGN <> 0)
then begin
WriteLn('WARNING: [TgtkObject.SelectClipRGN] Uninitialized GC');
Result := ERROR;
end
else begin
If (GC = nil) or (RGN = 0) then begin
DeleteObject(ClipRegion);
ClipRegion := 0;
if GC<>nil then
SelectGDIRegion(DC);
end
else
If IsValidGDIObject(RGN) then begin
DeleteObject(ClipRegion);
ClipRegion := CreateRectRGN(0,0,0,0);
Result := CombineRGN(ClipRegion, RGN, RGN, RGN_COPY);
SelectGDIRegion(DC);
end
else begin
Result := ERROR;
WriteLn('WARNING: [TgtkObject.SelectClipRGN] Invalid RGN');
end;
end;
end;
end;
{------------------------------------------------------------------------------
Function: SelectObject
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.SelectObject(DC: HDC; GDIObj: HGDIOBJ): HGDIOBJ;
//var
// Color: TGdkColor;
begin
//TODO: Finish this;
Assert(False, Format('trace:> [TgtkObject.SelectObject] DC: 0x%x', [DC]));
Result := 0;
if IsValidDC(DC) and IsValidGDIObject(GDIObj)
then begin
case PGdiObject(GDIObj)^.GDIType of
gdiBitmap:
with PDeviceContext(DC)^ do
begin
Assert(False, Format('trace: [TgtkObject.SelectObject] DC: 0x%x, Type: Bitmap', [DC]));
Result := HBITMAP(CurrentBitmap);
CurrentBitmap := PGDIObject(GDIObj);
if GC <> nil then gdk_gc_unref(GC);
with PGdiObject(GDIObj)^ do
case GDIBitmapType of
gbPixmap: Drawable := GDIPixmapObject;
gbBitmap: Drawable := GDIBitmapObject;
gbImage: Drawable := nil;//GDIRawImageObject;
else
Drawable := nil;
end;
GC := gdk_gc_new(Drawable);
gdk_gc_set_function(GC, GDK_COPY);
end;
gdiBrush:
with PDeviceContext(DC)^, PGdiObject(GDIObj)^ do
begin
Assert(False, Format('trace: [TgtkObject.SelectObject] DC: 0x%x, Type: Brush', [DC]));
Result := HBRUSH(CurrentBrush);
CurrentBrush := PGDIObject(GDIObj);
if GC <> nil
then begin
gdk_gc_set_fill(GC, GDIBrushFill);
case GDIBrushFill of
GDK_STIPPLED: gdk_gc_set_stipple(GC, GDIBrushPixMap);
GDK_TILED: gdk_gc_set_tile(GC, GDIBrushPixMap);
end;
end;
end;
gdiFont:
with PDeviceContext(DC)^ do
begin
Assert(False, Format('trace: [TgtkObject.SelectObject] DC: 0x%x, Type: Font', [DC]));
Result := HFONT(CurrentFont);
CurrentFont := PGDIObject(GDIObj);
if GC <> nil
then begin
gdk_gc_set_font(GC, PGdiObject(GDIObj)^.GDIFontObject);
end;
end;
gdiPen:
with PDeviceContext(DC)^ do
begin
Result := HPEN(CurrentPen);
CurrentPen := PGDIObject(GDIObj);
if GC <> nil then SelectGDKPenProps(DC);
end;
gdiRegion:
begin
with PDeviceContext(DC)^ do
begin
Result := ClipRegion;
ClipRegion := 0;
if GC <> nil then SelectClipRGN(DC, GDIObj);
end;
end;
end;
end;
//writeln('[TgtkObject.SelectObject] GDI=',HexStr(Cardinal(GDIObj),8)
// ,' Old=',Hexstr(Cardinal(Result),8));
Assert(False, Format('trace:< [TgtkObject.SelectObject] DC: 0x%x --> 0x%x', [DC, Result]));
end;
{------------------------------------------------------------------------------
Function: SelectPalette
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.SelectPalette(DC: HDC; Palette: HPALETTE; ForceBackground: Boolean): HPALETTE;
begin
Assert(False, 'Trace:TODO: [TgtkObject.SelectPalette]');
//TODO: Implement this;
Result := 0;
end;
{------------------------------------------------------------------------------
Function: SendMessage
Params: hWnd:
Msg:
wParam:
lParam:
Returns:
The SendMessage function sends the specified message to a window or windows.
The function calls the window procedure for the specified window and does
not return until the window procedure has processed the message.
------------------------------------------------------------------------------}
function TGTKObject.SendMessage(HandleWnd: HWND; Msg: Cardinal; wParam: LongInt;
lParam: LongInt): Integer;
var
AMessage: TLMessage;
Target: TObject;
//ParentControl: TWinControl;
//ParentHandle: HWnd;
begin
AMessage.Msg := Msg;
AMessage.WParam := WParam;
AMessage.LParam := LParam;
AMessage.Result := 0;
Target := GetLCLObject(Pointer(HandleWnd));
if Target<>nil 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
// gtkdraw events bottom-up. So, controls at the bottom are repainted
// many times. To avoid this the queue is checked for LM_PAINT messages
// for the parent control. If there is a parent LM_PAINT, this message
// is ignored.
{if (Target is TControl) then begin
ParentControl:=TControl(Target).Parent;
while ParentControl<>nil do begin
ParentHandle:=TWinControl(ParentControl).Handle;
if FindPaintMessage(ParentHandle)<>nil then begin
if Msg=LM_PAINT then
ReleaseDC(0,AMessage.WParam);
exit;
end;
ParentControl:=ParentControl.Parent;
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;
// deliver it
Result := DeliverMessage(Target, AMessage);
// free DC
if AMessage.Msg=LM_PAINT then
ReleaseDC(0,AMessage.WParam);
end;
end;
{------------------------------------------------------------------------------
function SetActiveWindow(Handle: HWND): HWND;
------------------------------------------------------------------------------}
function TgtkObject.SetActiveWindow(Handle: HWND): HWND;
begin
// ToDo
Result:=GetActiveWindow;
end;
{------------------------------------------------------------------------------
Function: SetBkColor pbd
Params: DC: Device context to change the text background color
Color: RGB Tuple
Returns: Old Background color
------------------------------------------------------------------------------}
function TgtkObject.SetBKColor(DC: HDC; Color: TColorRef): TColorRef;
const
HI_MASK = LongWord($FF00);
LO_MASK = LongWord($FF);
begin
Assert(False, Format('trace:> [TgtkObject.SetBKColor] DC: 0x%x Color: %8x', [Integer(DC), Color]));
Result := CLR_INVALID;
if IsValidDC(DC)
then begin
with PDeviceContext(DC)^, CurrentBackColor do
begin
Result := ((Red and HI_MASK) shr 8)
or (Green and HI_MASK)
or ((Blue and HI_MASK) shl 8);
if Result <> Color then
begin
gdk_colormap_free_colors(gdk_colormap_get_system, @CurrentBackColor, 1);
Red := ((Color shl 8) and HI_MASK) or ((Color ) and LO_MASK);
Green := ((Color ) and HI_MASK) or ((Color shr 8 ) and LO_MASK);
Blue := ((Color shr 8) and HI_MASK) or ((Color shr 16) and LO_MASK);
gdk_colormap_alloc_color(gdk_colormap_get_system, @CurrentBackColor,
False, True);
end;
end;
end;
Assert(False, Format('trace:< [TgtkObject.SetBKColor] DC: 0x%x Color: %8x --> %8x', [Integer(DC), Color, Result]));
end;
{------------------------------------------------------------------------------
Function: SetBkMode
Params: DC:
bkMode:
Returns:
------------------------------------------------------------------------------}
Function TGTKObject.SetBkMode(DC: HDC; bkMode : Integer) : Integer;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
Function: SetCapture
Params: Value: Handle of window to capture
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.SetCapture(Value: Longint): Longint;
{$IfDef VerboseMouseCapture}
var
Sender : TObject;
CurMouseCaptureHandle: PGtkWidget;
{$EndIf}
begin
Assert(False, Format('Trace:> [TgtkObject.SetCapture] 0x%x', [Value]));
{$IfDef VerboseMouseCapture}
if Value<>0 then
Sender:=GetLCLObject(Pointer(Value))
else
Sender:=nil;
write('TgtkObject.SetCapture New=',HexStr(Cardinal(Value),8),' ');
if Sender=nil then
writeln('Sender=nil')
else
writeln('Sender=',TControl(Sender).Name,':',Sender.ClassName);
CurMouseCaptureHandle:=gtk_grab_get_current;
writeln(' gtk=',HexStr(Cardinal(CurMouseCaptureHandle),8),
' MCaptureHandle=',HexStr(Cardinal(MCaptureHandle),8));
{$EndIf}
//CaptureHandle is defined in gtkint.pp pivate var definition.
//MWE: there are some problems with grabbing the pointer and tabs
// so back to gtk_grab
if MCaptureHandle <> 0 then
//gdk_pointer_ungrab(0);
gtk_grab_remove(pgtkwidget(MCaptureHandle));
//
Result := MCaptureHandle;
MCaptureHandle := Value;
if MCaptureHandle <> 0 then begin
//WriteLN(Format('[TgtkObject.SetCapture] Current widget 0x%p', [gtk_grab_get_current]));
gtk_grab_add(Pointer(MCaptureHandle));
{$IfDef VerboseMouseCapture}
CurMouseCaptureHandle:=gtk_grab_get_current;
if CurMouseCaptureHandle<>PgtkWidget(MCaptureHandle) then
writeln(' WARNING: SetCapture failed: Tried to set to: ',
HexStr(Cardinal(MCaptureHandle),8),
', but it is: ',HexStr(Cardinal(CurMouseCaptureHandle),8));
{$EndIf}
//WriteLN(Format('[TgtkObject.SetCapture] handle: 0x%p gtk: 0x%p', [Pointer(MCaptureHandle), gtk_grab_get_current]));
// gtk_grab_add(pGTKWidget(FCaptureHandle));
{
if gdk_pointer_grab(PGTKWidget(Value)^.Window, gtk_False,
GDK_POINTER_MOTION_MASK or GDK_POINTER_MOTION_HINT_MASK or
GDK_BUTTON_MOTION_MASK or GDK_BUTTON1_MOTION_MASK or
GDK_BUTTON2_MOTION_MASK or GDK_BUTTON3_MOTION_MASK or
GDK_BUTTON_PRESS_MASK or GDK_BUTTON_RELEASE_MASK,
PGTKWidget(Value)^.Window, nil, 0) <> 0
then begin
FCaptureHandle := 0;
Result := 0;
assert(False, Format('trace:[TgtkObject.SetCapture] 0x%x failed', [Value]));
end;
}
// Writeln('SetCapture result is '+inttostr(result));
if MCaptureHandle <> 0 then
SendMessage(MCaptureHandle, LM_CAPTURECHANGED, 0, Result);
end;
Assert(False, Format('Trace:< [TgtkObject.SetCapture] 0x%x --> 0x%x', [Value, Result]));
end;
{------------------------------------------------------------------------------
Function: SetCaretPos
Params: new position x, y
Returns: true on success
------------------------------------------------------------------------------}
function TgtkObject.SetCaretPos(X, Y: Integer): Boolean;
var
FocusObject: PGTKObject;
begin
FocusObject := PGTKObject(GetFocus);
Result:=SetCaretPosEx(LongInt(FocusObject),X,Y);
end;
{------------------------------------------------------------------------------
Function: SetCaretPos
Params: new position x, y
Returns: true on success
------------------------------------------------------------------------------}
function TgtkObject.SetCaretPosEx(Handle: HWNd; X, Y: Integer): Boolean;
var
GtkObject: PGTKObject;
begin
GtkObject := PGTKObject(Handle);
Result := GtkObject <> nil;
if Result then begin
if gtk_type_is_a(gtk_object_type(GtkObject), GTKAPIWidget_GetType)
then begin
GTKAPIWidget_SetCaretPos(PGTKAPIWidget(GtkObject), X, Y);
end
// else if // TODO: other widgettypes
else begin
Result := False;
end;
end;
end;
{------------------------------------------------------------------------------
Function: SetCaretRespondToFocus
Params: handle : Handle of a TWinControl
ShowHideOnFocus: true = caret is hidden on focus lost
Returns: true on success
------------------------------------------------------------------------------}
function TgtkObject.SetCaretRespondToFocus(handle: HWND;
ShowHideOnFocus: boolean): Boolean;
begin
if handle<>0 then begin
if gtk_type_is_a(gtk_object_type(PGTKObject(handle)), GTKAPIWidget_GetType)
then begin
GTKAPIWidget_SetCaretRespondToFocus(PGTKAPIWidget(handle),
ShowHideOnFocus);
Result:=true;
end
else begin
Result := False;
end;
end else
Result:=false;
end;
{------------------------------------------------------------------------------
Function: SetFocus
Params: hWnd: Handle of new focus window
Returns: The old focus window
The SetFocus function sets the keyboard focus to the specified window
------------------------------------------------------------------------------}
function TgtkObject.SetFocus(hWnd: HWND): HWND;
var
TopLevel: PGTKWidget;
Widget, ImplWidget: PGtkWidget;
{$IfDef VerboseFocus}
LCLObject: TWinControl;
{$EndIf}
begin
if hWnd=0 then exit;
Widget:=PGtkWidget(hWnd);
{$IfDef VerboseFocus}
writeln('[TgtkObject.SetFocus] A hWnd=',HexStr(Cardinal(hWnd),8));
LCLObject:=TWinControl(GetLCLObject(Widget));
if LCLObject<>nil then
writeln('[TgtkObject.SetFocus] A2 LCLObject=',LCLObject.Name,':',LCLObject.ClassName);
{$EndIf}
if hwnd = 0 then
Result := 0
else begin
// return the old focus handle
Result := GetFocus;
TopLevel := gtk_widget_get_toplevel(Widget);
{$IfDef VerboseFocus}
writeln('[TgtkObject.SetFocus] B hWnd=',HexStr(Cardinal(hWnd),8),' Result=',HexStr(Cardinal(Result),8),' TopLevel=',HexStr(Cardinal(TopLevel),8));
{$EndIf}
if gtk_type_is_a(gtk_object_type(PGTKObject(TopLevel)), gtk_window_get_type)
then begin
{$IfDef VerboseFocus}
writeln('[TgtkObject.SetFocus] C TopLevel is a gtkwindow');
{$EndIf}
// TopLevel is a gtkwindow
if GTK_WIDGET_CAN_FOCUS(TOPLEVEL) then begin
// TopLevel window can focus
{$IfDef VerboseFocus}
writeln('[TgtkObject.SetFocus] D TopLevel window can focus');
{$EndIf}
gtk_window_set_focus(PGTKWindow(TopLevel), Widget)
end
else begin
// TopLevel window can not focus
{$IfDef VerboseFocus}
writeln('[TgtkObject.SetFocus] E TopLevel window can NOT focus');
writeln('[TgtkObject.SetFocus] F ',
' Widget can focus=',GTK_WIDGET_CAN_FOCUS(Widget),
', is realized=',GTK_WIDGET_REALIZED(Widget),
', is mapped=',GTK_WIDGET_MAPPED(Widget)
);
{$EndIf}
if gtk_type_is_a(gtk_object_type(PGTKObject(hwnd)), gtk_combo_get_type)
then begin
// handle is a gtk combo
gtk_widget_grab_focus(PgtkWidget(PGtkCombo(hwnd)^.entry));
{$IfDef VerboseFocus}
writeln('[TgtkObject.SetFocus] H Entry=',HexStr(Cardinal(PGtkCombo(hwnd)^.entry),8),
' has focus=',gtk_widget_has_focus(PgtkWidget(PGtkCombo(hwnd)^.entry)));
{$EndIf}
end
else begin
ImplWidget:= GetWidgetInfo(Widget, true)^.ImplementationWidget;
if ImplWidget <> nil then begin
{$IfDef VerboseFocus}
writeln('[TgtkObject.SetFocus] I CoreChild=',HexStr(Cardinal(ImplWidget),8));
{$EndIf}
gtk_widget_grab_focus(ImplWidget)
end else begin
gtk_widget_grab_focus(Widget);
{$IfDef VerboseFocus}
writeln('[TgtkObject.SetFocus] J has focus=',gtk_widget_has_focus(Widget));
{$EndIf}
end;
end;
end;
end
else begin
if GTK_WIDGET_CAN_FOCUS(Widget) then begin
gtk_widget_grab_focus(Widget);
end;
end;
end;
//writeln('[TgtkObject.SetFocus] END hWnd=',HexStr(Cardinal(hWnd),8),' Result=',HexStr(Cardinal(Result),8),' TopLevel=',HexStr(Cardinal(TopLevel),8),' NewFocus=',HexStr(Cardinal(GetFocus),8));
end;
Function TgtkObject.SetProp(Handle: hwnd; Str : PChar; Data : Pointer) : Boolean;
Begin
gtk_object_set_data(pGTKObject(handle),Str,data);
Result:=true;
end;
{------------------------------------------------------------------------------
Function: SetScrollInfo
Params: none
Returns: The old position value
------------------------------------------------------------------------------}
function TgtkObject.SetScrollInfo(Handle : HWND; SBStyle : Integer;
ScrollInfo: TScrollInfo; bRedraw : Boolean): Integer;
const
POLICY: array[BOOLEAN] of TGTKPolicyType = (GTK_POLICY_NEVER, GTK_POLICY_ALWAYS);
var
Adjustment: PGtkAdjustment;
begin
// Assert(False, 'Trace:[TgtkObject.SetScrollInfo]');
with ScrollInfo do Assert(False, Format('Trace:> [TgtkObject.SetScrollInfo] Mask:0x%x, Min:%d, Max:%d, Page:%d, Pos:%d', [fMask, nMin, nMax, nPage, nPos]));
Result := 0;
if (Handle <> 0)
then begin
Adjustment := nil;
case SBStyle of
SB_HORZ:
if gtk_type_is_a(gtk_object_type(PGTKObject(Handle)),
gtk_scrolled_window_get_type)
then
Adjustment := gtk_scrolled_window_get_hadjustment(
PGTKScrolledWindow(Handle))
else
if gtk_type_is_a(gtk_object_type(PGTKObject(Handle)),
gtk_hscrollbar_get_type)
then
Adjustment := PgtkhScrollBar(handle)^.Scrollbar.Range.Adjustment
else //clist
if gtk_type_is_a(gtk_object_type(PGTKObject(Handle)),
gtk_clist_get_type)
then
Adjustment := {$IfDef Win32}nil{$Else}gtk_clist_get_hadjustment(PgtkCList(handle)){$EndIf};
SB_VERT:
if gtk_type_is_a(gtk_object_type(PGTKObject(Handle)),
gtk_scrolled_window_get_type)
then
Adjustment := gtk_scrolled_window_get_vadjustment(
PGTKScrolledWindow(Handle))
else
if gtk_type_is_a(gtk_object_type(PGTKObject(Handle)),
gtk_vscrollbar_get_type)
then
Adjustment := PgtkvScrollBar(handle)^.Scrollbar.Range.Adjustment
else //clist
if gtk_type_is_a(gtk_object_type(PGTKObject(Handle)),
gtk_clist_get_type)
then
Adjustment := {$IfDef Win32}nil{$Else}gtk_clist_get_vadjustment(PgtkCList(handle)){$EndIf};
SB_CTL:
if gtk_type_is_a(gtk_object_type(PGTKObject(Handle)), gtk_range_get_type)
then begin
Adjustment := gtk_range_get_adjustment(PGTKRange(Handle));
end;
end;
if Adjustment <> nil
then with ScrollInfo, Adjustment^ do begin
Result := Round(Value);
if (fMask and SIF_POS) <> 0
then Value := nPos;
if (fMask and SIF_RANGE) <> 0
then begin
Lower := nMin;
Upper := nMax;
end;
if (fMask and SIF_PAGE) <> 0
then begin
Page_Size := nPage;
Page_Increment := nPage;
end;
{writeln('[TgtkObject.SetScrollInfo] Result=',Result,
' Lower=',round(Lower),
' Upper=',round(Upper),
' Page_Size=',round(Page_Size),
' Page_Increment=',round(Page_Increment),
' bRedraw=',bRedraw,
' Handle=',HexStr(Cardinal(Handle),8));}
// do we have to set this allways ?
if bRedraw then
begin
if (Handle <> 0) then
begin
if gtk_type_is_a(gtk_object_type(PGTKObject(Handle)),
gtk_scrolled_window_get_type)
then
begin
if SBStyle in [SB_BOTH, SB_HORZ]
then gtk_object_set(PGTKObject(Handle), 'hscrollbar_policy',
[POLICY[bRedraw], nil]);
if SBStyle in [SB_BOTH, SB_VERT]
then gtk_object_set(PGTKObject(Handle), 'vscrollbar_policy',
[POLICY[bRedraw], nil]);
end
else
begin
if (SBSTYLE = SB_CTL)
and gtk_type_is_a(gtk_object_type(PGTKObject(Handle)),
gtk_widget_get_type)
then
gtk_widget_show(PGTKWidget(Handle))
else
gtk_widget_hide(PGTKWidget(Handle))
end;
end;
{ writeln('TgtkObject.SetScrollInfo: ',
' lower=',lower,'/',nMin,
' upper=',upper,'/',nMax,
' value=',value,'/',nPos,
' step_increment=',step_increment,'/',1,
' page_increment=',page_increment,'/',nPage,
' page_size=',page_size,'/',nPage,
'');}
gtk_adjustment_changed(Adjustment);
end;
end;
end;
with ScrollInfo do Assert(False, Format('Trace:> [TgtkObject.SetScrollInfo] --> %d', [Result]));
end;
{------------------------------------------------------------------------------
Function: SetSysColors
Params: cElements: the number of elements
lpaElements: array with element numbers
lpaRgbValues: array with colors
Returns: 0 if unsuccesful
The SetSysColors function sets the colors for one or more display elements.
------------------------------------------------------------------------------}
function TgtkObject.SetSysColors(cElements: Integer; const lpaElements;
const lpaRgbValues): Boolean;
type
TLongArray = array[0..0] of Longint;
PLongArray = ^TLongArray;
var
n: Integer;
Element: LongInt;
begin
Result := False;
if cElements > MAX_SYS_COLORS then Exit;
for n := 0 to cElements - 1 do
begin
Element := PLongArray(lpaElements)^[n];
if (Element > MAX_SYS_COLORS)
or (Element < 0)
then Exit;
SysColorMap[PLongArray(lpaElements)^[n]] := PLongArray(lpaRgbValues)^[n];
//Assert(False, Format('Trace:[TgtkObject.SetSysColor] Index %d (%8x) --> %8x', [PLongArray(lpaElements)^[n], SysColorMap[PLongArray(lpaElements)^[n]], PLongArray(lpaRgbValues)^[n]]));
end;
//TODO send WM_SYSCOLORCHANGE
Result := True;
end;
{------------------------------------------------------------------------------
Function: SetTextCharacterExtra
Params: _hdc:
nCharExtra:
Returns:
------------------------------------------------------------------------------}
Function TGTKObject.SetTextCharacterExtra(_hdc : hdc; nCharExtra : Integer):Integer;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
Function: SetTextColor
Params: hdc: Identifies the device context.
Color: Specifies the color of the text.
Returns: The previous color if succesful, CLR_INVALID otherwise
The SetTextColor function sets the text color for the specified device
context to the specified color.
------------------------------------------------------------------------------}
function TgtkObject.SetTextColor(DC: HDC; Color: TColorRef): TColorRef;
const
HI_MASK = LongWord($FF00);
LO_MASK = LongWord($FF);
begin
Assert(False, Format('trace:> [TgtkObject.SetTextColor] DC: 0x%x Color: %8x', [Integer(DC), Color]));
Result := CLR_INVALID;
if IsValidDC(DC)
then begin
with PDeviceContext(DC)^, CurrentTextColor do
begin
Result := ((Red and HI_MASK) shr 8)
or (Green and HI_MASK)
or ((Blue and HI_MASK) shl 8);
if Result <> Color
then begin
gdk_colormap_free_colors(gdk_colormap_get_system, @CurrentTextColor, 1);
Red := ((Color shl 8) and HI_MASK) or ((Color ) and LO_MASK);
Green := ((Color ) and HI_MASK) or ((Color shr 8 ) and LO_MASK);
Blue := ((Color shr 8) and HI_MASK) or ((Color shr 16) and LO_MASK);
gdk_colormap_alloc_color(gdk_colormap_get_system, @CurrentTextColor,
False, True);
end;
end;
end;
Assert(False, Format('trace:< [TgtkObject.SetTextColor] DC: 0x%x Color: %8x --> %8x', [Integer(DC), Color, Result]));
end;
{------------------------------------------------------------------------------
Function: SetTimer
Params: hWnd:
nIDEvent:
uElapse:
lpTimerFunc:
Returns: a GTK-timer id
This function will create a GTK timer object and associate a callback to it.
Design: Currently only a callback to the TTimer class is implemented.
------------------------------------------------------------------------------}
function TGTKObject.SetTimer(hWnd: HWND; nIDEvent, uElapse: integer;
lpTimerFunc: TFNTimerProc) : integer;
var
PTimerInfo: PGtkITimerinfo;
begin
if ((hWnd = 0) and (lpTimerFunc = nil))
then Result := 0
else begin
New (PTimerInfo);
PTimerInfo^.Handle := hWND;
PTimerInfo^.IDEvent := nIDEvent;
PTimerInfo^.TimerFunc := lpTimerFunc;
gtk_timeout_add(uElapse, @gtkTimerCB, PTimerInfo);
FTimerData.Add (PTimerInfo);
end;
end;
{------------------------------------------------------------------------------
Procedure: SetWindowLong
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.SetWindowLong(Handle: HWND; Idx: Integer;
NewLong: Longint): LongInt;
begin
//TODO: Finish this;
Assert(False, Format('Trace:> [TgtkObject.SETWINDOWLONG] HWND: 0x%x, idx: 0x%x(%d), Value: 0x%x(%d)', [Handle, idx, idx, newlong, newlong]));
Result:=0;
case idx of
GWL_WNDPROC :
begin
gtk_object_set_data(pgtkobject(Handle),'WNDPROC',pointer(NewLong));
end;
GWL_HINSTANCE :
begin
gtk_object_set_data(pgtkobject(Handle),'HINSTANCE',pointer(NewLong));
end;
GWL_HWNDPARENT :
begin
gtk_object_set_data(pgtkobject(Handle),'HWNDPARENT',pointer(NewLong));
end;
GWL_STYLE :
begin
gtk_object_set_data(pgtkobject(Handle),'Style',pointer(NewLong));
end;
GWL_EXSTYLE :
begin
gtk_object_set_data(pgtkobject(Handle),'ExStyle',pointer(NewLong));
end;
GWL_USERDATA :
begin
gtk_object_set_data(pgtkobject(Handle),'Userdata',pointer(NewLong));
end;
GWL_ID :
begin
gtk_object_set_data(pgtkobject(Handle),'ID',pointer(NewLong));
end;
end; //case
Assert(False, Format('Trace:< [TgtkObject.SETWINDOWLONG] HWND: 0x%x, idx: 0x%x(%d), Value: 0x%x(%d) --> 0x%x(%d)', [Handle, idx, idx, newlong, newlong, Result, Result]));
end;
{------------------------------------------------------------------------------
Function TgtkObject.SetWindowOrgEx(DC : HDC; NewX, NewY : Integer;
var OldPoint: TPoint) : Boolean;
Sets the x-coordinates and y-coordinates of the window origin for the
specified device context.
------------------------------------------------------------------------------}
Function TgtkObject.SetWindowOrgEx(DC : HDC; NewX, NewY : Integer;
var OldPoint: TPoint) : Boolean;
begin
//writeln('[TgtkObject.SetWindowOrgEx] ',NewX,' ',NewY);
GetWindowOrgEx(DC,OldPoint);
Result := MoveWindowOrgEx(DC,NewX-OldPoint.X,NewY-OldPoint.Y);
end;
{------------------------------------------------------------------------------
function TgtkObject.SetWindowPos(hWnd: HWND; hWndInsertAfter: HWND;
X, Y, cx, cy: Integer; uFlags: UINT): Boolean;
------------------------------------------------------------------------------}
function TgtkObject.SetWindowPos(hWnd: HWND; hWndInsertAfter: HWND;
X, Y, cx, cy: Integer; uFlags: UINT): Boolean;
//var Widget: PGTKWidget;
begin
//writeln('[TgtkObject.SetWindowPos] Top=',hWndInsertAfter=HWND_TOP);
{ Widget := GetFixedWidget(pgtkwidget(hWnd));
if Widget = nil then Widget := pgtkwidget(hWnd);
case hWndInsertAfter of
HWND_BOTTOM: ; //gdk_window_lower(Widget^.Window);
HWND_TOP: gtk_window_set_position(PGtkWindow(hWnd),GTK_WIN_POS_CENTER);
//gdk_window_raise(Widget^.Window);
end;
}
Result:=true;
end;
{------------------------------------------------------------------------------
Function: ShowCaret
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.ShowCaret(hWnd: HWND): Boolean;
var
GTKObject: PGTKObject;
begin
Assert(False, Format('Trace:> [TgtkObject.ShowCaret] HWND: 0x%x', [hWnd]));
GTKObject := PGTKObject(HWND);
Result := GTKObject <> nil;
if Result
then begin
if gtk_type_is_a(gtk_object_type(GTKObject), GTKAPIWidget_GetType)
then begin
GTKAPIWidget_ShowCaret(PGTKAPIWidget(GTKObject));
end
else begin
Result := False;
end;
end
else WriteLn('WARNING: [TgtkObject.ShowCaret] Got null HWND');
Assert(False, Format('Trace:< [TgtkObject.ShowCaret] HWND: 0x%x --> %s', [hWnd, BOOL_TEXT[Result]]));
end;
{------------------------------------------------------------------------------
Function: ShowScrollBar
Params: Wnd, wBar, bShow
Returns: Nothing
------------------------------------------------------------------------------}
function TgtkObject.ShowScrollBar(Handle: HWND; wBar: Integer; bShow: Boolean): Boolean;
const
POLICY: array[BOOLEAN] of TGTKPolicyType = (GTK_POLICY_NEVER, GTK_POLICY_ALWAYS);
begin
Assert(False, 'trace:[TgtkObject.ShowScrollBar]');
Result:=false;
{ Result := (Handle <> 0);
if Result
then begin
if gtk_type_is_a(gtk_object_type(PGTKObject(Handle)), gtk_scrolled_window_get_type)
then begin
if wBar in [SB_BOTH, SB_HORZ]
then gtk_object_set(PGTKObject(Handle), 'hscrollbar_policy', [POLICY[bShow], nil]);
if wBar in [SB_BOTH, SB_VERT]
then gtk_object_set(PGTKObject(Handle), 'vscrollbar_policy', [POLICY[bShow], nil]);
end
else begin
if (wBar = SB_CTL) and gtk_type_is_a(gtk_object_type(PGTKObject(Handle)), gtk_widget_get_type)
then begin
if bShow
then gtk_widget_show(PGTKWidget(Handle))
else gtk_widget_hide(PGTKWidget(Handle));
end;
end;
end;
}
end;
{------------------------------------------------------------------------------
Function: StretchBlt
Params: DestDC: The destination devicecontext
X, Y: The left/top corner of the destination rectangle
Width, Height: The size of the destination rectangle
SrcDC: The source devicecontext
XSrc, YSrc: The left/top corner of the source rectangle
SrcWidth, SrcHeight: The size of the source rectangle
Rop: The raster operation to be performed
Returns: True if succesful
The StretchBlt function copies a bitmap from a source rectangle into a
destination rectangle using the specified raster operation. If needed it
resizes the bitmap to fit the dimensions of the destination rectangle.
Sizing is done according to the stretching mode currently set in the
destination device context.
If SrcDC contains a mask the pixmap will be copied with this transparency.
ToDo: Mirroring, extended NonDrawable support (Image, Bitmap, etc)
------------------------------------------------------------------------------}
function TgtkObject.StretchBlt(DestDC: HDC; X, Y, Width, Height: Integer;
SrcDC: HDC; XSrc, YSrc, SrcWidth, SrcHeight: Integer; Rop: Cardinal): Boolean;
type
TBltFunction = function: Boolean;
var
fGC : PGDKGC;
SrcDevContext, DestDevContext: PDeviceContext;
SrcGDIBitmap: PGdiObject;
ScaleBMP : hBITMAP;
Scale : PGdiObject;
{$IfDef Win32}
Procedure gdk_window_copy_area(Dest : PGDKWindow; GC : PGDKGC; X,
Y : Longint; SRC : PGDKWindow; XSRC, YSRC, Width, Height : Longint);
begin
gdk_draw_pixmap(Dest, GC, Src, XSrc, YSrc, X, Y, Width, Height);
End;
{$EndIf}
Procedure SetClipping(DestGC : PGDKGC; GDIBitmap : PGdiObject);
begin
SelectGDIRegion(DestDC);
if (GDIBitmap <> NIL) AND (GDIBitmap^.GDIBitmapMaskObject <> nil) then
begin
gdk_gc_set_clip_mask(DestGC, GDIBitmap^.GDIBitmapMaskObject);
gdk_gc_set_clip_origin(DestGC, X, Y);
end;
end;
Procedure ResetClipping(DestGC : PGDKGC);
begin
gdk_gc_set_clip_mask (DestGC, nil);
gdk_gc_set_clip_origin (DestGC, 0,0);
SelectGDIRegion(DestDC);
end;
Procedure SetRasterOperation(ScaleROPGC : PGDKGC);
begin
Case ROP of
WHITENESS,
BLACKNESS,
SRCCOPY :
GDK_GC_Set_Function(ScaleROPGC, GDK_Copy);
SRCPAINT :
GDK_GC_Set_Function(ScaleROPGC, GDK_NOOP);
SRCAND :
GDK_GC_Set_Function(ScaleROPGC, GDK_Clear);
SRCINVERT :
GDK_GC_Set_Function(ScaleROPGC, GDK_XOR);
SRCERASE :
GDK_GC_Set_Function(ScaleROPGC, GDK_AND);
NOTSRCCOPY :
GDK_GC_Set_Function(ScaleROPGC, GDK_OR_REVERSE);
NOTSRCERASE :
GDK_GC_Set_Function(ScaleROPGC, GDK_AND);
MERGEPAINT :
GDK_GC_Set_Function(ScaleROPGC, GDK_Copy_Invert);
DSTINVERT :
GDK_GC_Set_Function(ScaleROPGC, GDK_INVERT);
else begin
gdk_gc_set_function(ScaleROPGC, GDK_COPY);
WriteLn('WARNING: [TgtkObject.StretchBlt] Got unknown/unsupported CopyMode!!');
end;
end;
end;
function ScaleBuffer(ScaleGC:PGDKGC) : Boolean;
{$Ifndef NoGdkPixbufLib}
var
ScaleSrc, ScaleDest : PGDKPixbuf;
ShrinkWidth,
ShrinkHeight : Boolean;
ScaleMethod : TGDKINTERPTYPE;
begin
Result := False;
ScaleSRC := nil;
ScaleDest := nil;
ShrinkWidth := Width < SrcWidth;
ShrinkHeight := Height < SrcHeight;
//GDKPixbuf Scaling is not done in the same way as Windows
//but by rights ScaleMethod should really be chosen based
//on the destination device's internal flag
{GDK_INTERP_NEAREST,GDK_INTERP_TILES,
GDK_INTERP_BILINEAR,GDK_INTERP_HYPER);}
If ShrinkWidth and ShrinkHeight then
ScaleMethod := GDK_INTERP_TILES
else
If ShrinkWidth or ShrinkHeight then
ScaleMethod := GDK_INTERP_BILINEAR//GDK_INTERP_HYPER
else
ScaleMethod := GDK_INTERP_BILINEAR;
ScaleSRC := gdk_pixbuf_get_from_drawable(nil,Scale^.GDIPixmapObject,
GDK_ColorMap_Get_System,0,0,0,0,SrcWidth,SrcHeight);
If ScaleSRC = nil then
exit;
If (Width > 0) and (Height > 0) then
ScaleDest := gdk_pixbuf_scale_simple(ScaleSRC,Width,Height,ScaleMethod);
GDK_Pixbuf_Unref(ScaleSRC);
If ScaleDest = nil then
exit;
DeleteObject(ScaleBMP);
ScaleBMP := CreateCompatibleBitmap(-1, Width, Height);
Scale := PGdiObject(ScaleBMP);
gdk_pixbuf_render_pixmap_and_mask(ScaleDest,@Scale^.GDIPixmapObject,
@Scale^.GDIBitmapMaskObject,0);
GDK_Pixbuf_Unref(ScaleDest);
Result := True;
{$Else not NoGdkPixbufLib}
begin
WriteLn('WARNING: [TgtkObject.StretchBlt] GDKPixbuf support has been disabled, no stretching is available!');
Result := True;
{$EndIf}
end;
Function ScaleAndROP(ScaleROPGC : PGDKGC; SRC : PGDKDrawable;
SRCBit : PGDIObject) : Boolean;
var
SRCClip : PGDKPixmap;
begin
Result := False;
SRCClip := nil;
If SRCBit <> nil then
If SRCBit^.GDIBitmapMaskObject <> nil then
SRCClip := SRCBit^.GDIBitmapMaskObject;
if ScaleROPGC = nil
then begin
WriteLn('WARNING: [TgtkObject.StretchBlt] Uninitialized GC');
exit;
end;
// create a buffer for raster operations and scaling
Case ROP of
WHITENESS,
BLACKNESS,
DSTINVERT :
begin
ScaleBMP := CreateCompatibleBitmap(-1, Width, Height);
Scale := PGdiObject(ScaleBMP);
Scale^.GDIBitmapMaskObject := SRCClip;
SetRasterOperation(ScaleROPGC);
Result := True;
exit; //skip scaling
end;
else begin
ScaleBMP := CreateCompatibleBitmap(-1, SRCWidth, SRCHeight);
Scale := PGdiObject(ScaleBMP);
Scale^.GDIBitmapMaskObject := SRCClip;
end;
end;
// set raster operation to SRCCOPY, or NOTSRCCOPY
If ROP = NOTSRCERASE then
GDK_GC_Set_Function(ScaleROPGC, GDK_OR_REVERSE)
else
GDK_GC_Set_Function(ScaleROPGC, GDK_Copy);
GDK_GC_COPY(fGC, ScaleROPGC);
gdk_gc_set_clip_region(fgc, nil);
gdk_gc_set_clip_rectangle (fgc, nil);
//copy source into scale buffer
gdk_window_copy_area(Scale^.GDIPixmapObject, fGC,0, 0,
SRC, XSRC, YSRC, SRCWidth, SRCHeight);
// Set raster operation to SRCCOPY
GDK_GC_Set_Function(ScaleROPGC, GDK_Copy);
// Scale Buffer if needed
If (Width <> SrcWidth) or (Height <> SrcHeight) then
Result := ScaleBuffer(ScaleROPGC)
else
Result := True;
//set raster operation
If Result then
SetRasterOperation(ScaleROPGC);
end;
Procedure ROPFILLBUFFER(DC : hDC);
var
OldCurrentBrush: PGdiObject;
Brush : hBrush;
begin
with PDeviceContext(DC)^ do
begin
// Temporarily hold the old brush to
// replace it with the given brush
OldCurrentBrush := CurrentBrush;
If ROP = WHITENESS then
Brush := GetStockObject(WHITE_BRUSH)
else
Brush := GetStockObject(BLACK_BRUSH);
CurrentBrush := PGdiObject(Brush);
SelectGDKBrushProps(DC);
gdk_draw_rectangle(Scale^.GDIPixmapObject, GC, 1, 0, 0, Width, Height);
// Restore current brush
CurrentBrush := OldCurrentBrush;
end;
end;
function DrawableToDrawable: Boolean;
begin
SrcDevContext:=PDeviceContext(SrcDC);
DestDevContext:=PDeviceContext(DestDC);
SrcGDIBitmap:=SrcDevContext^.CurrentBitmap;
fGC := GDK_GC_New(DestDevContext^.Drawable);
// perform raster operation and scaling in a buffer
If not ScaleAndROP(DestDevContext^.GC,
SrcDevContext^.Drawable, SrcGDIBitmap)
then
exit;
GDK_GC_Unref(fGC);
Case ROP of
WHITENESS, BLACKNESS :
ROPFILLBUFFER(DestDC);
end;
// set clipping mask for transparency
SetClipping(DestDevContext^.GC, Scale);
// draw image
gdk_window_copy_area(DestDevContext^.Drawable,
DestDevContext^.GC,X, Y, Scale^.GDIPixmapObject,
0, 0, Width, Height);
// unset clipping mask for transparency
ResetClipping(DestDevContext^.GC);
// restore raster operation to SRCCOPY
GDK_GC_Set_Function(DestDevContext^.GC, GDK_Copy);
// Delete buffer
DeleteObject(ScaleBMP);
Result:=True;
end;
function PixmapToDrawable: Boolean;
begin
SrcDevContext:=PDeviceContext(SrcDC);
DestDevContext:=PDeviceContext(DestDC);
SrcGDIBitmap:=SrcDevContext^.CurrentBitmap;
fGC := GDK_GC_New(SrcDevContext^.Drawable);
// perform raster operation and scaling in a buffer
If not ScaleAndROP(DestDevContext^.GC, SrcDevContext^.Drawable,
SrcGDIBitmap)
then
exit;
GDK_GC_Unref(fGC);
Case ROP of
WHITENESS, BLACKNESS :
ROPFILLBUFFER(DestDC);
end;
// set clipping mask for transparency
SetClipping(DestDevContext^.GC, Scale);
// draw image
gdk_window_copy_area(DestDevContext^.Drawable,
DestDevContext^.GC,X, Y, Scale^.GDIPixmapObject,
0, 0, Width, Height);
// unset clipping mask for transparency
ResetClipping(DestDevContext^.GC);
// restore raster operation to SRCCOPY
GDK_GC_Set_Function(DestDevContext^.GC, GDK_Copy);
// Delete buffer
DeleteObject(ScaleBMP);
Result := True;
end;
function ImageToImage: Boolean;
begin
WriteLn('WARNING: [TgtkObject.StretchBlt] ImageToImage unimplimented!');
Result:=false;
end;
function ImageToDrawable: Boolean;
begin
WriteLn('WARNING: [TgtkObject.StretchBlt] ImageToDrawable unimplimented!');
Result:=false;
end;
function ImageToBitmap: Boolean;
begin
WriteLn('WARNING: [TgtkObject.StretchBlt] ImageToBitmap unimplimented!');
Result:=false;
end;
function PixmapToImage: Boolean;
begin
WriteLn('WARNING: [TgtkObject.StretchBlt] PixmapToImage unimplimented!');
Result:=false;
end;
function PixmapToBitmap: Boolean;
begin
WriteLn('WARNING: [TgtkObject.StretchBlt] PixmapToBitmap unimplimented!');
Result:=false;
end;
function BitmapToImage: Boolean;
begin
WriteLn('WARNING: [TgtkObject.StretchBlt] BitmapToImage unimplimented!');
Result:=false;
end;
function BitmapToPixmap: Boolean;
begin
WriteLn('WARNING: [TgtkObject.StretchBlt] BitmapToPixmap unimplimented!');
Result:=false;
end;
function Unsupported: Boolean;
begin
WriteLn('WARNING: [TgtkObject.StretchBlt] Destination and/or Source '
+ 'unsupported!!');
Result:=false;
end;
//----------
function NoDrawableToNoDrawable: Boolean;
const // FROM TO
BLT_MATRIX: array[TGDIBitmapType, TGDIBitmapType] of TBltFunction = (
(@DrawableToDrawable, @BitmapToPixmap, @BitmapToImage),
(@PixmapToBitmap, @DrawableToDrawable, @PixmapToImage),
(@ImageToBitmap, @ImageToDrawable, @ImageToImage)
);
begin
If (PDeviceContext(SrcDC)^.CurrentBitmap <> nil) and
(PDeviceContext(DestDC)^.CurrentBitmap <> nil)
then
Result := BLT_MATRIX[
PDeviceContext(SrcDC)^.CurrentBitmap^.GDIBitmapType,
PDeviceContext(DestDC)^.CurrentBitmap^.GDIBitmapType
]()
else
Result := Unsupported;
end;
function NoDrawableToDrawable: Boolean;
const
BLT_FUNCTION: array[TGDIBitmapType] of TBltFunction = (
@PixmapToDrawable, @PixmapToDrawable, @ImageToDrawable
);
begin
If PDeviceContext(SrcDC)^.CurrentBitmap <> nil then
Result := BLT_FUNCTION[
PDeviceContext(SrcDC)^.CurrentBitmap^.GDIBitmapType
]()
else
Result := Unsupported;
end;
function DrawableToNoDrawable: Boolean;
const
BLT_FUNCTION: array[TGDIBitmapType] of TBltFunction = (
@Unsupported, @Unsupported, @Unsupported
);
begin
If PDeviceContext(DestDC)^.CurrentBitmap <> nil then
Result := BLT_FUNCTION[
PDeviceContext(DestDC)^.CurrentBitmap^.GDIBitmapType
]()
else
Result := Unsupported;
end;
const // FROM TO
DRAWABLE_MATRIX: array[Boolean, Boolean] of TBltFunction = (
(@NoDrawableToNoDrawable, @NoDrawableToDrawable),
(@DrawableToNoDrawable, @DrawableToDrawable)
);
var DCOrigin: TPoint;
begin
Assert(True, Format('trace:> [TgtkObject.StretchBlt] DestDC:0x%x; X:%d, Y:%d, Width:%d, Height:%d; SrcDC:0x%x; XSrc:%d, YSrc:%d, SrcWidth:%d, SrcHeight:%d; Rop:0x%x', [DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, SrcWidth, SrcHeight, Rop]));
Result := IsValidDC(DestDC) and IsValidDC(SrcDC);
if Result
then begin
with PDeviceContext(DestDC)^ do begin
DCOrigin:=GetDCOffset(PDeviceContext(DestDC));
Inc(X,DCOrigin.X);
Inc(Y,DCOrigin.Y);
end;
with PDeviceContext(SrcDC)^ do begin
DCOrigin:=GetDCOffset(PDeviceContext(SrcDC));
Inc(XSrc,DCOrigin.X);
Inc(YSrc,DCOrigin.Y);
end;
//writeln('TgtkObject.StretchBlt X=',X,' Y=',Y,' Width=',Width,' Height=',Height,
// ' XSrc=',XSrc,' YSrc=',YSrc,' SrcWidth=',SrcWidth,' SrcHeight=',SrcHeight);
If PDeviceContext(SrcDC)^.Drawable = nil then begin
If PDeviceContext(DestDC)^.Drawable = nil then
Result := NoDrawableToNoDrawable
else
Result := NoDrawableToDrawable;
end
else begin
If PDeviceContext(DestDC)^.Drawable = nil then
Result := DrawableToNoDrawable
else
Result := DrawableToDrawable;
end;
end;
Assert(True, Format('trace:< [TgtkObject.StretchBlt] DestDC:0x%x --> %s', [DestDC, BOOL_TEXT[Result]]));
end;
{------------------------------------------------------------------------------
Function: StretchMaskBlt
Params: DestDC: The destination devicecontext
X, Y: The left/top corner of the destination rectangle
Width, Height: The size of the destination rectangle
SrcDC: The source devicecontext
XSrc, YSrc: The left/top corner of the source rectangle
SrcWidth, SrcHeight: The size of the source rectangle
Mask: The handle of a monochrome bitmap
XMask, YMask: The left/top corner of the mask rectangle
Rop: The raster operation to be performed
Returns: True if succesful
The StretchMaskBlt function copies a bitmap from a source rectangle into a
destination rectangle using the specified mask and raster operation. If needed
it resizes the bitmap to fit the dimensions of the destination rectangle.
Sizing is done according to the stretching mode currently set in the
destination device context.
------------------------------------------------------------------------------}
function TgtkObject.StretchMaskBlt(DestDC: HDC; X, Y, Width, Height: Integer;
SrcDC: HDC; XSrc, YSrc, SrcWidth, SrcHeight: Integer; Mask: HBITMAP;
XMask, YMask: Integer; Rop: DWORD): Boolean;
begin
Result:=false;
end;
{------------------------------------------------------------------------------
Function: TextOut
Params: DC:
X:
Y:
Str:
Count:
Returns:
------------------------------------------------------------------------------}
Function TGTKObject.TextOut(DC: HDC; X,Y : Integer; Str : Pchar;
Count: Integer) : Boolean;
var
aRect : TRect;
txtpt : TPoint;
sz : TSize;
TM : TTextMetric;
UseFont : PGDKFont;
UnRef : Boolean;
DCOrigin: TPoint;
begin
Result := IsValidDC(DC);
if Result
then with PDeviceContext(DC)^ do
begin
if GC = nil
then begin
WriteLn('WARNING: [TgtkObject.TextOut] Uninitialized GC');
end
else begin
if (CurrentFont = nil) or (CurrentFont^.GDIFontObject = nil)
then begin
UseFont := GetDefaultFont;
UnRef := True;
end
else begin
UseFont := CurrentFont^.GDIFontObject;
UnRef := False;
end;
If UseFont = nil then
WriteLn('WARNING: [TgtkObject.TextOut] Missing Font')
else begin
DCOrigin:=GetDCOffset(PDeviceContext(DC));
GetTextExtentPoint(DC, Str, Count, Sz);
aRect := Rect(X+DCOrigin.X,Y+DCOrigin.Y,X + Sz.CX, Sz.CY);
FillRect(DC,aRect,hBrush(CurrentBrush));
GetTextMetrics(DC, TM);
TxtPt.X := X;
{$IfDef Win32}
TxtPt.Y := Y + TM.tmHeight div 2;
{$Else}
TxtPt.Y := Y + TM.tmAscent;
{$EndIf}
SelectGDKTextProps(DC);
gdk_draw_text(Drawable, UseFont,
GC, TxtPt.X+DCOrigin.X, TxtPt.Y+DCOrigin.Y, Str, Count);
Result := True;
If UnRef then
GDK_Font_UnRef(UseFont);
end;
end;
end;
end;
{------------------------------------------------------------------------------
Function: WindowFromPoint
Params: Point: Specifies the x and y Coords
Returns: The handle of the gtkwidget. If none exist, then NULL is returned.
------------------------------------------------------------------------------}
Function TGTKObject.WindowFromPoint(Point : TPoint) : HWND;
var
ev : TgdkEvent;
Window : PgdkWindow;
Widget : PgtkWidget;
begin
// Check the state of the widget. IF it's hidden or disabled, don't return it's handle!
Result := 0;
Window := gdk_window_at_pointer(@Point.x,@Point.Y);
if window <> nil then
Begin
ev.any.window := Window;
Widget := gtk_get_event_widget(@ev);
if widget <> nil then Result := Longint(widget);
Assert(False, format('Trace:Result = [%d]',[Result]));
end
else
Assert(False, 'Trace:Result = nil');
end;
{$IfDef Critical_Sections_Support}
{$IfNDef Win32}
{$Define pthread}
Type
_pthread_fastlock = packed record
__status: Longint;
__spinlock: Integer;
end;
pthread_mutex_t = packed record
__m_reserved: Integer;
__m_count: Integer;
__m_owner: Pointer;
__m_kind: Integer;
__m_lock: _pthread_fastlock;
end;
ppthread_mutex_t = ^pthread_mutex_t;
pthread_mutexattr_t = packed record
__mutexkind: Integer;
end;
{$linklib pthread}
function pthread_mutex_init(var Mutex: pthread_mutex_t;
var Attr: pthread_mutexattr_t): Integer; cdecl;external;
function pthread_mutexattr_settype(var Attr: pthread_mutexattr_t;
Kind: Integer): Integer; cdecl;external;
function pthread_mutex_lock(var Mutex: pthread_mutex_t):
Integer; cdecl; external;
function pthread_mutex_unlock(var Mutex: pthread_mutex_t):
Integer; cdecl; external;
function pthread_mutex_destroy(var Mutex: pthread_mutex_t):
Integer; cdecl; external;
{$EndIf}
{$EndIf}
Procedure TGTKObject.InitializeCriticalSection(var CritSection: TCriticalSection);
{$IfDef pthread}
var
Crit : ppthread_mutex_t;
Attribute: pthread_mutexattr_t;
begin
if pthread_mutexattr_settype(Attribute, 1) <> 0 then
Exit;
If CritSection <> 0 then
Try
Crit := ppthread_mutex_t(CritSection);
Dispose(Crit);
except
CritSection := 0;
end;
New(Crit);
pthread_mutex_init(Crit^, Attribute);
CritSection := Longint(Crit);
end;
{$Else}
begin
end;
{$EndIf}
Procedure TGTKObject.EnterCriticalSection(var CritSection: TCriticalSection);
{$IfDef pthread}
var
Crit,
tmp : ppthread_mutex_t;
begin
New(Crit);
If CritSection <> 0 then
Try
Crit^ := ppthread_mutex_t(CritSection)^;
except
begin
CritSection := Longint(Crit);
exit;
end;
end;
pthread_mutex_lock(Crit^);
tmp := ppthread_mutex_t(CritSection);
CritSection := Longint(Crit);
Dispose(Tmp);
end;
{$Else}
begin
end;
{$EndIf}
Procedure TGTKObject.LeaveCriticalSection(var CritSection: TCriticalSection);
{$IfDef pthread}
var
Crit,
tmp : ppthread_mutex_t;
begin
New(Crit);
If CritSection <> 0 then
Try
Crit^ := ppthread_mutex_t(CritSection)^;
except
begin
CritSection := Longint(Crit);
exit;
end;
end;
pthread_mutex_unlock(Crit^);
tmp := ppthread_mutex_t(CritSection);
CritSection := Longint(Crit);
Dispose(Tmp);
end;
{$Else}
begin
end;
{$EndIf}
Procedure TGTKObject.DeleteCriticalSection(var CritSection: TCriticalSection);
{$IfDef pthread}
var
Crit,
tmp : ppthread_mutex_t;
begin
New(Crit);
If CritSection <> 0 then
Try
Crit^ := ppthread_mutex_t(CritSection)^;
except
begin
CritSection := Longint(Crit);
exit;
end;
end;
pthread_mutex_destroy(Crit^);
Dispose(Crit);
tmp := ppthread_mutex_t(CritSection);
CritSection := 0;
Dispose(Tmp);
end;
{$Else}
begin
end;
{$EndIf}
//##apiwiz##eps## // Do not remove
{$IfDef ASSERT_IS_ON}
{$UNDEF ASSERT_IS_ON}
{$C-}
{$EndIf}
{ =============================================================================
$Log$
Revision 1.126 2002/09/09 14:01:06 lazarus
MG: improved TScreen and ShowModal
Revision 1.125 2002/09/06 19:45:11 lazarus
Cleanups plus a fix to TPanel parent/drawing problem.
Revision 1.124 2002/09/06 19:11:48 lazarus
MG: fixed scrollbars of TTreeView
Revision 1.123 2002/09/06 16:41:31 lazarus
MG: set SpecialOrigin
Revision 1.122 2002/09/06 16:38:25 lazarus
MG: added GetDCOffset
Revision 1.121 2002/09/06 15:57:36 lazarus
MG: fixed notebook client area, send messages and minor bugs
Revision 1.120 2002/09/06 11:33:36 lazarus
MG: added jitform error messagedlg
Revision 1.119 2002/09/03 08:07:22 lazarus
MG: image support, TScrollBox, and many other things from Andrew
Revision 1.118 2002/09/02 08:13:17 lazarus
MG: fixed GraphicClass.Create
Revision 1.117 2002/08/30 13:43:38 lazarus
MG: fixed drawing of non visual components in designer
Revision 1.116 2002/08/30 12:32:24 lazarus
MG: MoveWindowOrgEx, Splitted FWinControls/FControls, TControl drawing, Better DesignerDrawing, ...
Revision 1.115 2002/08/29 00:07:03 lazarus
MG: fixed TComboBox and InvalidateControl
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
MG: propedits text improvements from Andrew, uncapturing, improved comobobox
Revision 1.112 2002/08/27 06:40:51 lazarus
MG: ShortCut support for buttons from Andrew
Revision 1.111 2002/08/24 12:55:00 lazarus
MG: fixed mouse capturing, OI edit focus
Revision 1.110 2002/08/24 06:51:24 lazarus
MG: from Andrew: style list fixes, autosize for radio/checkbtns
Revision 1.109 2002/08/22 16:43:36 lazarus
MG: improved theme support from Andrew
Revision 1.108 2002/08/22 16:22:39 lazarus
MG: started debugging of mouse capturing
Revision 1.107 2002/08/22 13:45:58 lazarus
MG: fixed non AutoCheck menuitems and editor bookmark popupmenu
Revision 1.106 2002/08/22 12:25:00 lazarus
MG: fixed mouse events
Revision 1.105 2002/08/22 07:30:16 lazarus
MG: freeing more unused GCs
Revision 1.104 2002/08/21 15:46:08 lazarus
MG: fixed a mem leak in RestoreDC
Revision 1.103 2002/08/21 14:44:18 lazarus
MG: accelerated synedit
Revision 1.102 2002/08/21 14:06:41 lazarus
MG: added TDeviceContextMemManager
Revision 1.101 2002/08/21 13:51:31 lazarus
MG: removed SaveDC and RestoreDC in ExtTextOut
Revision 1.100 2002/08/21 13:35:25 lazarus
MG: accelerations for synedit
Revision 1.99 2002/08/21 11:29:36 lazarus
MG: fixed mem some leaks in ide and gtk
Revision 1.98 2002/08/21 10:46:37 lazarus
MG: fixed unreleased gdiRegions
Revision 1.97 2002/08/21 08:13:38 lazarus
MG: accelerated new/dispose of gdiobjects
Revision 1.96 2002/08/21 07:16:59 lazarus
MG: reduced mem leak of clipping stuff, still not fixed
Revision 1.95 2002/08/19 20:34:48 lazarus
MG: improved Clipping, TextOut, Polygon functions
Revision 1.94 2002/08/17 15:45:34 lazarus
MG: removed ClientRectBugfix defines
Revision 1.93 2002/08/15 15:46:50 lazarus
MG: added changes from Andrew (Clipping)
Revision 1.92 2002/08/15 13:37:58 lazarus
MG: started menuitem icon, checked, radio and groupindex
Revision 1.91 2002/08/13 07:08:24 lazarus
MG: added gdkpixbuf.pp and changes from Andrew Johnson
Revision 1.90 2002/08/08 18:05:47 lazarus
MG: added graphics extensions from Andrew Johnson
Revision 1.89 2002/08/08 17:26:39 lazarus
MG: added property TMenuItems.RightJustify
Revision 1.88 2002/08/08 09:07:07 lazarus
MG: TMenuItem can now be created/destroyed/moved at any time
Revision 1.87 2002/08/07 09:55:30 lazarus
MG: codecompletion now checks for filebreaks, savefile now checks for filedate
Revision 1.86 2002/08/05 10:45:06 lazarus
MG: TMenuItem.Caption can now be set after creation
Revision 1.85 2002/08/05 08:56:57 lazarus
MG: TMenuItems can now be enabled and disabled
Revision 1.84 2002/08/05 07:43:29 lazarus
MG: fixed BadCursor bug and Circle Reference of FixedWidget of csPanel
Revision 1.83 2002/07/23 07:40:52 lazarus
MG: fixed get widget position for inherited gdkwindows
Revision 1.82 2002/07/20 13:47:04 lazarus
MG: fixed eventmask for realized windows
Revision 1.81 2002/07/09 17:18:23 lazarus
MG: fixed parser for external vars
Revision 1.80 2002/06/21 15:41:56 lazarus
MG: moved RectVisible, ExcludeClipRect and IntersectClipRect to interface dependent functions
Revision 1.79 2002/06/19 19:46:10 lazarus
MG: Form Editing: snapping, guidelines, modified on move/resize, creating components in csDesigning, ...
Revision 1.78 2002/06/12 12:35:44 lazarus
MG: fixed apiwidget warnings/criticals
Revision 1.77 2002/06/11 13:41:11 lazarus
MG: fixed mouse coords and fixed mouse clicked thru bug
Revision 1.76 2002/06/05 12:33:58 lazarus
MG: fixed fonts in XLFD format and styles
Revision 1.75 2002/06/04 19:28:17 lazarus
MG: cursor is now inverted and can be used with twilight color scheme
Revision 1.74 2002/06/04 15:17:24 lazarus
MG: improved TFont for XLFD font names
Revision 1.73 2002/06/01 08:41:28 lazarus
MG: DrawFramControl now uses gtk style, transparent STrechBlt
Revision 1.72 2002/05/27 17:58:42 lazarus
MG: added command line help
Revision 1.71 2002/05/24 07:16:34 lazarus
MG: started mouse bugfix and completed Makefile.fpc
Revision 1.70 2002/05/17 10:45:23 lazarus
MG: finddeclaration for stupid things like var a:a;
Revision 1.69 2002/05/16 18:26:08 lazarus
MG: fixed selection painting of non highlighter
Revision 1.68 2002/05/10 06:05:57 lazarus
MG: changed license to LGPL
Revision 1.67 2002/05/09 12:41:30 lazarus
MG: further clientrect bugfixes
Revision 1.66 2002/05/06 08:50:37 lazarus
MG: replaced logo, increased version to 0.8.3a and some clientrectbugfix
Revision 1.65 2002/04/22 13:07:45 lazarus
MG: fixed AdjustClientRect of TGroupBox
Revision 1.64 2002/04/04 12:25:02 lazarus
MG: changed except statements to more verbosity
Revision 1.63 2002/03/31 22:01:38 lazarus
MG: fixed unreleased/unpressed Ctrl/Alt/Shift
Revision 1.62 2002/03/14 20:28:49 lazarus
Bug fix for Mattias.
Fixed spinedit so you can now get the value and set the value.
Shane
Revision 1.61 2002/02/25 16:48:13 lazarus
MG: new IDE window layout system
Revision 1.60 2002/02/03 00:24:01 lazarus
TPanel implemented.
Basic graphic primitives split into GraphType package, so that we can
reference it from interface (GTK, Win32) units.
New Frame3d canvas method that uses native (themed) drawing (GTK only).
New overloaded Canvas.TextRect method.
LCLLinux and Graphics was split, so a bunch of files had to be modified.
Revision 1.59 2002/01/24 15:40:59 lazarus
MG: deactivated clipboard setting target list for win32
Revision 1.58 2002/01/21 14:17:47 lazarus
MG: added find-block-start and renamed find-block-other-end
Revision 1.57 2002/01/08 16:02:45 lazarus
Minor changes to TListView.
Added TImageList to the IDE
Shane
Revision 1.56 2002/01/04 21:07:49 lazarus
MG: added TTreeView
Revision 1.55 2002/01/02 15:24:58 lazarus
MG: added TCanvas.Polygon and TCanvas.Polyline
Revision 1.54 2001/12/28 11:41:51 lazarus
MG: added TCanvas.Ellipse, TCanvas.Pie
Revision 1.53 2001/12/27 16:31:28 lazarus
MG: implemented TCanvas.Arc
Revision 1.52 2001/12/20 14:41:20 lazarus
Fixed setfocus for TComboBox and TMemo
Shane
Revision 1.51 2001/12/12 14:23:18 lazarus
MG: implemented DestroyCaret
Revision 1.50 2001/12/11 16:51:37 lazarus
Modified the Watches dialog
Shane
Revision 1.49 2001/11/14 17:46:59 lazarus
Changes to make toggling between form and unit work.
Added BringWindowToTop
Shane
Revision 1.48 2001/11/12 16:56:08 lazarus
MG: CLIPBOARD
Revision 1.47 2001/11/09 19:14:25 lazarus
HintWindow changes
Shane
Revision 1.46 2001/10/31 16:29:23 lazarus
Fixed the gtk mousemove bug where the control gets the coord's based on it's parent instead of itself.
Shane
Revision 1.45 2001/10/24 00:35:55 lazarus
MG: fixes for fpc 1.1: range check errors
Revision 1.44 2001/10/16 14:19:13 lazarus
MG: added nvidia opengl support and a new opengl example from satan
Revision 1.41 2001/09/30 08:34:52 lazarus
MG: fixed mem leaks and fixed range check errors
Revision 1.40 2001/07/01 23:33:13 lazarus
MG: added WaitMessage and HandleEvents is now non blocking
Revision 1.39 2001/06/26 21:44:32 lazarus
MG: reduced paint messages
Revision 1.37 2001/06/14 23:13:30 lazarus
MWE:
* Fixed some syntax errors for the latest 1.0.5 compiler
Revision 1.36 2001/06/14 14:57:59 lazarus
MG: small bugfixes and less notes
Revision 1.33 2001/04/13 13:22:23 lazarus
Made fix to buttonglyph to use the correct size of single glyph
Made fix to StretchBlt to use the correct height and width
Both of these corrected the Win32 Speedbutton problem MAH
Revision 1.32 2001/04/06 22:25:14 lazarus
* TTimer uses winapi-interface now instead of sendmessage-interface, stoppok
Revision 1.31 2001/03/26 14:58:31 lazarus
MG: setwindowpos + bugfixes
Revision 1.26 2001/03/19 18:51:57 lazarus
MG: added dynhasharray and renamed tsynautocompletion
Revision 1.25 2001/03/19 14:44:22 lazarus
MG: fixed many unreleased DC and GDIObj bugs
Revision 1.22 2001/03/12 12:17:02 lazarus
MG: fixed random function results
Revision 1.21 2001/02/20 16:53:27 lazarus
Changes for wordcompletion and many other things from Mattias.
Shane
Revision 1.20 2001/02/16 19:13:31 lazarus
Added some functions
Shane
Revision 1.19 2001/02/06 18:19:38 lazarus
Shane
Revision 1.18 2001/02/04 04:18:12 lazarus
Code cleanup and JITFOrms bug fix.
Shane
Revision 1.17 2001/02/01 19:34:50 lazarus
TScrollbar created and a lot of code added.
It's cose to working.
Shane
Revision 1.16 2001/01/23 23:33:55 lazarus
MWE:
- Removed old LM_InvalidateRect
- did some cleanup in old code
+ added some comments on gtkobject data (gtkproc)
Revision 1.15 2001/01/23 19:01:10 lazarus
Fixxed bug in RestoreDC
Shane
Revision 1.12 2001/01/12 18:46:50 lazarus
Named the speedbuttons in MAINIDE and took out some writelns.
Shane
Revision 1.11 2001/01/04 16:12:54 lazarus
Removed some writelns and changed the property editor for TStrings a bit.
Shane
Revision 1.10 2001/01/03 18:44:54 lazarus
The Speedbutton now has a numglyphs setting.
I started the TStringPropertyEditor
Revision 1.9 2000/10/09 22:50:33 lazarus
MWE:
* fixed some selection code
+ Added selection sample
Revision 1.8 2000/09/10 23:08:31 lazarus
MWE:
+ Added CreateCompatibeleBitamp function
+ Updated TWinControl.WMPaint
+ Added some checks to avoid gtk/gdk errors
- Removed no fixed warning from GetDC
- Removed some output
Revision 1.7 2000/08/14 12:31:12 lazarus
Minor modifications for SynEdit .
Shane
Revision 1.6 2000/08/11 14:59:09 lazarus
Adding all the Synedit files.
Changed the GDK_KEY_PRESS and GDK_KEY_RELEASE stuff to fix the problem in the editor with the shift key being ignored.
Shane
Revision 1.5 2000/08/10 18:56:24 lazarus
Added some winapi calls.
Most don't have code yet.
SetTextCharacterExtra
CharLowerBuff
IsCharAlphaNumeric
Shane
Revision 1.4 2000/08/07 17:06:39 lazarus
Slight modification to CreateFontIndirect.
I check to see if the GdiObject^.GDIFontObject is nil. If so After the code to retry the weight and slant I added code to retry the Family and Foundry.
Shane
Revision 1.3 2000/07/30 21:48:34 lazarus
MWE:
= Moved ObjectToGTKObject to GTKProc unit
* Fixed array checking in LoadPixmap
= Moved LM_SETENABLED to API func EnableWindow and EnableMenuItem
~ Some cleanup
Revision 1.2 2000/07/23 10:53:41 lazarus
workaround for possible compiler bug (KEYSTATE), stoppok
Revision 1.1 2000/07/13 10:28:30 michael
+ Initial import
Revision 1.17 2000/07/09 20:18:56 lazarus
MWE:
+ added new controlselection
+ some fixes
~ some cleanup
Revision 1.16 2000/06/04 10:00:33 lazarus
MWE:
* Fixed bug #6.
Revision 1.15 2000/05/30 22:28:41 lazarus
MWE:
Applied patches from Vincent Snijders:
+ Added GetWindowRect
* Fixed horz label alignment
+ Added vert label alignment
Revision 1.14 2000/05/14 21:56:12 lazarus
MWE:
+ added local messageloop
+ added PostMessage
* fixed Peekmessage
* fixed ClientToScreen
* fixed Flat style of Speedutton (TODO: Draw)
+ Added TApplicatio.OnIdle
Revision 1.13 2000/05/11 22:04:16 lazarus
MWE:
+ Added messagequeue
* Recoded SendMessage and Peekmessage
+ Added postmessage
+ added DeliverPostMessage
Revision 1.12 2000/05/10 22:52:59 lazarus
MWE:
= Moved some global api stuf to gtkobject
Revision 1.11 2000/05/10 02:32:34 lazarus
Put ERRORs and WARNINGs back to writelns. CAW
Revision 1.10 2000/05/10 01:45:12 lazarus
Replaced writelns with Asserts.
Put ERROR and WARNING messages back to writelns. CAW
Revision 1.9 2000/05/09 18:37:02 lazarus
*** empty log message ***
Revision 1.8 2000/05/08 16:07:32 lazarus
fixed screentoclient and clienttoscreen
Shane
Revision 1.7 2000/05/08 15:56:59 lazarus
MWE:
+ Added support for mwedit92 in Makefiles
* Fixed bug # and #5 (Fillrect)
* Fixed labelsize in ApiWizz
+ Added a call to the resize event in WMWindowPosChanged
Revision 1.6 2000/05/08 12:54:20 lazarus
Removed some writeln's
Added alignment for the TLabel. Isn't working quite right.
Added the shell code for WindowFromPoint and GetParent.
Added FindLCLWindow
Shane
Revision 1.5 2000/05/03 00:27:05 lazarus
MWE:
+ First rollout of the API wizzard.
Revision 1.4 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.3 2000/04/07 16:59:55 lazarus
Implemented GETCAPTURE and SETCAPTURE along with RELEASECAPTURE.
Shane
Revision 1.2 2000/03/31 18:41:03 lazarus
Implemented MessageBox / Application.MessageBox calls. No icons yet, though...
Revision 1.1 2000/03/30 22:51:43 lazarus
MWE:
Moved from ../../lcl
Revision 1.62 2000/03/30 21:57:44 lazarus
MWE:
+ Added some general functions to Get/Set the Main/Fixed/CoreChild
widget
+ Started with graphic scalig/depth stuff. This is way from finished
Hans-Joachim Ott <hjott@compuserve.com>:
+ Added some improvements for TMEMO
Revision 1.61 2000/03/30 18:07:54 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.60 2000/03/28 22:47:49 lazarus
MWE:
Started with the blt function family
Revision 1.59 2000/03/22 18:49:51 lazarus
Initial work for getting transparent speedbutton glyphs
Shane
Revision 1.58 2000/03/22 17:09:30 lazarus
*** empty log message ***
Revision 1.57 2000/03/19 23:01:43 lazarus
MWE:
= Changed splashscreen loading/colordepth
= Chenged Save/RestoreDC to platform dependent, since they are
relative to a DC
Revision 1.56 2000/03/17 19:19:58 lazarus
Added Hans Ott's code for TMemo
Shane
Revision 1.55 2000/03/17 17:07:00 lazarus
Added images to speedbuttons
Shane
Revision 1.54 2000/03/16 23:58:46 lazarus
MWE:
Added TPixmap for XPM support
Revision 1.53 2000/03/15 20:15:32 lazarus
MOdified TBitmap but couldn't get it to work
Shane
Revision 1.52 2000/03/15 01:09:59 lazarus
MWE:
+ Removed comment on LM_IMAGECHANGED in TgtkObject.IntSendMessage3
it does compile (compiler hickup ?)
Revision 1.51 2000/03/15 00:51:58 lazarus
MWE:
+ Added LM_Paint on expose
+ Added forced creation of gdkwindow if needed
~ Modified DrawFrameControl
+ Added BF_ADJUST support on DrawEdge
- Commented out LM_IMAGECHANGED in TgtkObject.IntSendMessage3
(It did not compile)
Revision 1.50 2000/03/14 21:18:23 lazarus
Added the ability to click on the speedbuttons
Shane
Revision 1.48 2000/03/10 18:31:10 lazarus
Added TSpeedbutton code
Shane
Revision 1.47 2000/03/09 23:47:58 lazarus
MWE:
* Fixed colorcache
* Fixed black window in new editor
~ Did some cosmetic stuff
From Peter Dyson <peter@skel.demon.co.uk>:
+ Added Rect api support functions
+ Added the start of ScrollWindowEx
Revision 1.46 2000/03/08 23:57:38 lazarus
MWE:
Added SetSysColors
Fixed TEdit text bug (thanks to hans-joachim ott <hjott@compuserve.com>)
Finished GetKeyState
Added changes from Peter Dyson <peter@skel.demon.co.uk>
- a new GetSysColor
- some improvements on ExTextOut
Revision 1.45 2000/03/07 16:52:58 lazarus
Fixxed a problem with the main.pp unit determining a new files FORM name.
Shane
Revision 1.44 2000/03/06 00:05:05 lazarus
MWE: Added changes from Peter Dyson <peter@skel.demon.co.uk> for a new
release of mwEdit (0.92)
Revision 1.43 2000/03/03 22:58:26 lazarus
MWE:
Fixed focussing problem.
LM-FOCUS was bound to the wrong signal
Added GetKeyState api func.
Now LCL knows if shift/trl/alt is pressed (might be handy for keyboard
selections ;-)
Revision 1.42 2000/02/26 23:31:50 lazarus
MWE:
Fixed notebook crash on insert
Fixed loadfont problem for win32 (tleast now a fontname is required)
Revision 1.41 2000/02/22 23:26:13 lazarus
MWE: Fixed cursor movement in editor
Started on focus problem
Revision 1.40 2000/02/22 21:51:40 lazarus
MWE: Removed some double (or triple) event declarations.
The latest compiler doesn't like it
Revision 1.39 2000/02/18 19:38:53 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.38 2000/01/31 20:00:21 lazarus
Added code for Application.ProcessMessages. Needs work.
Added TScreen.Width and TScreen.Height. Added the code into
GetSystemMetrics for these two properties.
Shane
Revision 1.37 2000/01/26 19:16:24 lazarus
Implemented TPen.Style properly for GTK. Done SelectObject for pen objects.
Misc bug fixes.
Corrected GDK declaration for gdk_gc_set_slashes.
Revision 1.36 2000/01/25 23:51:14 lazarus
MWE:
Added more Caret functionality.
Removed old ifdef stuff from the editor
Revision 1.35 2000/01/25 22:04:27 lazarus
MWE:
The first primitive Caret functions are getting visible
Revision 1.34 2000/01/25 00:38:25 lazarus
MWE:
Added GetFocus
Revision 1.33 2000/01/22 20:07:47 lazarus
Some cleanups. It needs much more cleanup than this.
Worked around a compiler bug (?) in mwCustomEdit.
Reverted some changes to font generation and increased font size.
Revision 1.32 2000/01/18 22:18:35 lazarus
Moved bitmap creation into appropriate place. Cleaned up a bit.
Finished DeleteObject procedure.
Revision 1.31 2000/01/18 21:47:00 lazarus
Added OffSetRec
Revision 1.30 2000/01/17 23:33:08 lazarus
MWE:
fixed: nil pointer reference in DeleteObject
fixed: some trace info didn't start with 'trace:'
Revision 1.29 2000/01/17 20:36:25 lazarus
Fixed Makefile again.
Made implementation of TScreen and screen info saner.
Began to implemented DeleteObject in GTKWinAPI.
Fixed a bug in GDI allocation which in turn fixed A LOT of other bugs :-)
Revision 1.28 2000/01/16 23:23:07 lazarus
MWE:
Added/completed scrollbar API funcs
Revision 1.27 2000/01/14 21:47:04 lazarus
Commented out SHOWCARET. Not sure how to implement yet. Seems like I may need to draw it myself and therefore will need to create a timer and draw a line, then copy the pixmap over the line to erase it.......not sure yet.
Shane
Revision 1.26 2000/01/13 22:44:05 lazarus
MWE:
Created/updated net gtkwidget for TWinControl decendants
also improved foccusing on such a control
Revision 1.25 2000/01/12 22:13:07 lazarus
Modified ShowCaret. Still not working.
Shane
Revision 1.24 2000/01/11 20:50:32 lazarus
Added some code for SETCURSOR. Doesn't work perfect yet but getting there.
Shane
Revision 1.22 2000/01/10 21:24:12 lazarus
Minor cleanup and changes.
Revision 1.21 2000/01/07 21:14:13 lazarus
Added code for getwindowlong and setwindowlong.
Shane
Revision 1.20 1999/12/21 21:35:54 lazarus
committed the latest toolbar code. Currently it doesn't appear anywhere and I have to get it to add buttons correctly through (I think) setstyle. I think I'll implement the LM_TOOLBARINSERTBUTTON call there.
Shane
Revision 1.19 1999/12/21 00:37:19 lazarus
MWE:
Fixed SetTextColor
Revision 1.18 1999/12/21 00:07:06 lazarus
MWE:
Some fixes
Completed a bit of DraWEdge
Revision 1.17 1999/12/20 21:01:13 lazarus
Added a few things for compatability with Delphi and TToolbar
Shane
Revision 1.16 1999/12/18 18:27:32 lazarus
MWE:
Rearranged some events to get a LM_SIZE, LM_MOVE and LM_WINDOWPOSCHANGED
Initialized the TextMetricstruct to zeros to clear unset values
Get mwEdit to show more than one line
Fixed some errors in earlier commits
Revision 1.15 1999/12/14 21:07:12 lazarus
Added more stuff for TToolbar
Shane
Revision 1.14 1999/12/14 01:08:56 lazarus
MWE:
Started GetTextMetrics
Revision 1.13 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.12 1999/12/06 20:41:14 lazarus
Miinor debugging changes.
Shane
Revision 1.11 1999/12/03 00:26:47 lazarus
MWE:
fixed control location
added gdiobject reference counter
Revision 1.10 1999/12/02 19:00:59 lazarus
MWE:
Added (GDI)Pen
Changed (GDI)Brush
Changed (GDI)Font (color)
Changed Canvas to use/create pen/brush/font
Hacked mwedit to allow setting the number of chars (till it get a WM/LM_SIZE event)
The editor shows a line !
Revision 1.9 1999/11/29 00:46:47 lazarus
MWE:
Added TBrush as gdiobject
commented out some more mwedit MWE_FPC ifdefs
Revision 1.8 1999/11/25 23:45:08 lazarus
MWE:
Added font as GDIobject
Added some API testcode to testform
Commented out some more IFDEFs in mwCustomEdit
Revision 1.7 1999/11/19 01:09:43 lazarus
MWE:
implemented TCanvas.CopyRect
Added StretchBlt
Enabled creation of TCustomControl.Canvas
Added a temp hack in TWinControl.Repaint to get a LM_PAINT
Revision 1.6 1999/11/18 00:13:08 lazarus
MWE:
Partly Implemented SelectObject
Added ExTextOut
Added GetTextExtentPoint
Added TCanvas.TextExtent/TextWidth/TextHeight
Added TSize and HPEN
Revision 1.5 1999/11/17 01:16:40 lazarus
MWE:
Added some more API stuff
Added an initial TBitmapCanvas
Added some DC stuff
Changed and commented out, original gtk linedraw/rectangle code. This
is now called through the winapi wrapper.
Revision 1.4 1999/11/16 01:32:22 lazarus
MWE:
Added some more DC functionality
}
Reference in New Issue View Git Blame Copy Permalink