paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-22 13:59:31 +02:00
Code Issues Packages Projects Releases Wiki Activity

started MaskBlt for gtkIF and applied patch for dir dlg in env opts from Vincent

Browse Source 
git-svn-id: trunk@5083 -
This commit is contained in:
mattias 2004-01-22 11:23:36 +00:00
parent 80997fee5d
commit 6b0b23469e
13 changed files with 996 additions and 651 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
ide/environmentopts.pp
View File

@ -534,6 +534,7 @@ type
procedure CompilerPathGroupBoxResize(Sender: TObject);
procedure FPCSourceDirGroupBoxResize(Sender: TObject);
procedure FilesButtonClick(Sender: TObject);
procedure DirectoriesButtonClick(Sender: TObject);
procedure FormEditMiscGroupBoxResize(Sender: TObject);
procedure GridGroupBoxResize(Sender: TObject);
procedure GuideLinesGroupBoxResize(Sender: TObject);
@ -2117,7 +2118,7 @@ begin
Name:='LazarusDirButton';
Parent:=LazarusDirGroupBox;
Caption:='...';
OnClick:=@FilesButtonClick;
OnClick:=@DirectoriesButtonClick;
end;
CompilerPathGroupBox:=TGroupBox.Create(Self);
@ -2172,7 +2173,7 @@ begin
Name:='FPCSourceDirButton';
Parent:=FPCSourceDirGroupBox;
Caption:='...';
OnClick:=@FilesButtonClick;
OnClick:=@DirectoriesButtonClick;
end;
TestBuildDirGroupBox:=TGroupBox.Create(Self);
@ -2202,7 +2203,7 @@ begin
Name:='TestBuildDirButton';
Parent:=TestBuildDirGroupBox;
Caption:='...';
OnClick:=@FilesButtonClick;
OnClick:=@DirectoriesButtonClick;
end;
end;
@ -3022,14 +3023,39 @@ var
AFilename: string;
begin
OpenDialog:=TOpenDialog.Create(Application);
try
InputHistories.ApplyFileDialogSettings(OpenDialog);
OpenDialog.Options:=OpenDialog.Options+[ofPathMustExist];
// set title
OpenDialog.Title:=lisChooseCompilerPath;
if OpenDialog.Execute then begin
AFilename:=CleanAndExpandFilename(OpenDialog.Filename);
// check compiler filename
SetComboBoxText(CompilerPathComboBox,AFilename);
CheckExecutable(FOldCompilerFilename,CompilerPathComboBox.Text,
lisEnvOptDlgInvalidCompilerFilename,
lisEnvOptDlgInvalidCompilerFilenameMsg);
end;
InputHistories.StoreFileDialogSettings(OpenDialog);
finally
OpenDialog.Free;
end;
end;
procedure TEnvironmentOptionsDialog.DirectoriesButtonClick(Sender: TObject);
var
OpenDialog: TSelectDirectoryDialog;
ADirectoryName: string;
begin
OpenDialog:=TSelectDirectoryDialog.Create(Application);
try
InputHistories.ApplyFileDialogSettings(OpenDialog);
OpenDialog.Options:=OpenDialog.Options+[ofPathMustExist];
// set title
if Sender=LazarusDirButton then
OpenDialog.Title:=lisChooseLazarusSourceDirectory
else if Sender=CompilerPathButton then
OpenDialog.Title:=lisChooseCompilerPath
else if Sender=FPCSourceDirButton then
OpenDialog.Title:=lisChooseFPCSourceDir
else if Sender=TestBuildDirButton then
@ -3038,25 +3064,19 @@ begin
exit;
if OpenDialog.Execute then begin
AFilename:=CleanAndExpandFilename(OpenDialog.Filename);
ADirectoryName:=CleanAndExpandFilename(OpenDialog.Filename);
if Sender=LazarusDirButton then begin
// check lazarus directory
SetComboBoxText(LazarusDirComboBox,AFilename);
SetComboBoxText(LazarusDirComboBox,ADirectoryName);
CheckLazarusDir;
end else if Sender=CompilerPathButton then begin
// check compiler filename
SetComboBoxText(CompilerPathComboBox,AFilename);
CheckExecutable(FOldCompilerFilename,CompilerPathComboBox.Text,
lisEnvOptDlgInvalidCompilerFilename,
lisEnvOptDlgInvalidCompilerFilenameMsg);
end else if Sender=FPCSourceDirButton then begin
// check fpc source directory
SetComboBoxText(FPCSourceDirComboBox,AFilename);
SetComboBoxText(FPCSourceDirComboBox,ADirectoryName);
IsFPCSourceDir;
end else if Sender=TestBuildDirButton then begin
// check test directory
SetComboBoxText(TestBuildDirComboBox,AFilename);
SetComboBoxText(TestBuildDirComboBox,ADirectoryName);
CheckTestDir;
end;

2
lcl/editbtn.pas
View File

@ -909,7 +909,7 @@ end;
function TCalcEdit.GetAsFloat: Double;
begin
Try
Result:=StrToDouble(Text);
Result:=StrToDouble(Trim(Text));
except
Result:=0.0;
end;

29
lcl/fpcadds.pas
View File

@ -27,7 +27,7 @@ interface
uses
Classes, SysUtils;
// current TStream calculates in int64, old in longint
type
TStreamSeekType = int64;
@ -35,7 +35,9 @@ type
TCompareMemSize = integer;
function RoundToInt(const e: Extended): integer;
function RoundToCardinal(const e: Extended): cardinal;
function TruncToInt(const e: Extended): integer;
function TruncToCardinal(const e: Extended): cardinal;
function StrToDouble(const s: string): double;
implementation
@ -43,15 +45,40 @@ implementation
function RoundToInt(const e: Extended): integer;
begin
Result:=integer(Round(e));
{$IFDEF VerboseRound}
writeln('RoundToInt ',e,' ',Result);
{$ENDIF}
end;
function RoundToCardinal(const e: Extended): cardinal;
begin
Result:=cardinal(Round(e));
{$IFDEF VerboseRound}
writeln('RoundToCardinal ',e,' ',Result);
{$ENDIF}
end;
function TruncToInt(const e: Extended): integer;
begin
Result:=integer(Trunc(e));
{$IFDEF VerboseRound}
writeln('TruncToInt ',e,' ',Result);
{$ENDIF}
end;
function TruncToCardinal(const e: Extended): cardinal;
begin
Result:=cardinal(Trunc(e));
{$IFDEF VerboseRound}
writeln('TruncToCardinal ',e,' ',Result);
{$ENDIF}
end;
function StrToDouble(const s: string): double;
begin
{$IFDEF VerboseRound}
writeln('StrToDouble "',s,'"');
{$ENDIF}
Result:=Double(StrToFloat(s));
end;

29
lcl/interfaces/gtk/gtkcallback.inc
View File

@ -1168,7 +1168,7 @@ begin
TControl(Data).Name,':',TControl(Data).ClassName,
' Widget=',HexStr(Cardinal(Widget),8),
' DSO=',DesignOnlySignal,
' Event^.X=',trunc(Event^.X),' Event^.Y=',trunc(Event^.Y)
' Event^.X=',TruncToInt(Event^.X),' Event^.Y=',TruncToInt(Event^.Y)
);
{$ENDIF}
@ -1456,7 +1456,7 @@ begin
' Widget=',HexStr(Cardinal(Widget),8),
' ControlWidget=',HexStr(Cardinal(TWinControl(Data).Handle),8),
' DSO=',DesignOnlySignal,
' ',Trunc(Event^.X),',',Trunc(Event^.Y),
' ',TruncToInt(Event^.X),',',TruncToInt(Event^.Y),
' Type=',Event^.theType);
{$ENDIF}
//writeln('DDD1 MousePress Widget=',HexStr(Cardinal(Widget),8),
@ -1508,7 +1508,7 @@ begin
{writeln('[gtkMouseBtnPressAfter] ',
TControl(Data).Name,':',TObject(Data).ClassName,
' Widget=',HexStr(Cardinal(Widget),8),
' ',Trunc(Event^.X),',',Trunc(Event^.Y));}
' ',TruncToInt(Event^.X),',',TruncToInt(Event^.Y));}
{$ENDIF}
UpdateMouseCaptureControl;
@ -1630,7 +1630,7 @@ begin
TComponent(Data).Name,':',TObject(Data).ClassName,' ',
' Widget=',HexStr(Cardinal(Widget),8),
' DSO=',DesignOnlySignal,
' ',Trunc(Event^.X),',',Trunc(Event^.Y),' Btn=',event^.Button);
' ',TruncToInt(Event^.X),',',TruncToInt(Event^.Y),' Btn=',event^.Button);
{$ENDIF}
//writeln('EEE1 MouseRelease Widget=',HexStr(Cardinal(Widget),8),
@ -1675,7 +1675,7 @@ begin
{$IFDEF VerboseMouseBugfix}
{writeln('[gtkMouseBtnReleaseAfter] ',
TControl(Data).Name,':',TObject(Data).ClassName,' ',
Trunc(Event^.X),',',Trunc(Event^.Y));}
TruncToInt(Event^.X),',',TruncToInt(Event^.Y));}
{$ENDIF}
// stop the signal, so that it is not sent to the parent widgets
@ -2732,11 +2732,11 @@ var
Mask: TGdkModifierType;
Status : GBoolean;
begin
Assert(False, Format('Trace:[GTKHScrollCB] Value: %d', [Round(Adjustment^.Value)]));
Assert(False, Format('Trace:[GTKHScrollCB] Value: %d', [RoundToInt(Adjustment^.Value)]));
OldValue := Integer(gtk_object_get_data(PGTKObject(Adjustment), 'OldValue'));
gtk_object_set_data(PGTKObject(Adjustment), 'OldValue',
Pointer(Longint(Round(Adjustment^.Value))));
Pointer(RoundToInt(Adjustment^.Value)));
Scroll := gtk_object_get_data(PGTKObject(Adjustment), 'ScrollBar');
// Get rounded values
@ -2744,10 +2744,10 @@ begin
begin
V := RoundToInt(Value);
U := RoundToInt(Upper);
//L := Round(Lower);
//L := RoundToInt(Lower);
StepI := RoundToInt(Step_Increment);
PageI := RoundToInt(Page_Increment);
//Page := Round(Page_Size);
//Page := RoundToInt(Page_Size);
end;
// get keystates
@ -2799,11 +2799,11 @@ var
Mask: TGdkModifierType;
Status : GBoolean;
begin
Assert(False, Format('Trace:[GTKVScrollCB] Value: %d', [Round(Adjustment^.Value)]));
Assert(False, Format('Trace:[GTKVScrollCB] Value: %d', [RoundToInt(Adjustment^.Value)]));
OldValue := Integer(gtk_object_get_data(PGTKObject(Adjustment), 'OldValue'));
gtk_object_set_data(PGTKObject(Adjustment), 'OldValue',
Pointer(Longint(Round(Adjustment^.Value))));
Pointer(RoundToInt(Adjustment^.Value)));
Scroll := gtk_object_get_data(PGTKObject(Adjustment), 'ScrollBar');
// Get rounded values
@ -2811,10 +2811,10 @@ begin
begin
V := RoundToInt(Value);
U := RoundToInt(Upper);
//L := Round(Lower);
//L := RoundToInt(Lower);
StepI := RoundToInt(Step_Increment);
PageI := RoundToInt(Page_Increment);
//Page := Round(Page_Size);
//Page := RoundToInt(Page_Size);
end;
// get keystates
@ -3230,6 +3230,9 @@ end;
{ =============================================================================
$Log$
Revision 1.214 2004/01/22 11:23:36 mattias
started MaskBlt for gtkIF and applied patch for dir dlg in env opts from Vincent
Revision 1.213 2004/01/14 20:09:49 mattias
added TColorDialog debugging

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

@ -203,6 +203,10 @@ type
Desc: PRawImageDescription): boolean;
function GetRawImageFromGdkWindow(GDKWindow: PGdkWindow;
const SrcRect: TRect; var NewRawImage: TRawImage): boolean;
function StretchCopyArea(DestDC: HDC; X, Y, Width, Height: Integer;
SrcDC: HDC; XSrc, YSrc, SrcWidth, SrcHeight: Integer;
Mask: HBITMAP; XMask, YMask: Integer;
Rop: Cardinal): Boolean;
// RC file
procedure SetRCFilename(const AValue: string);virtual;
@ -418,6 +422,9 @@ end.
{ =============================================================================
$Log$
Revision 1.167 2004/01/22 11:23:36 mattias
started MaskBlt for gtkIF and applied patch for dir dlg in env opts from Vincent
Revision 1.166 2004/01/10 22:34:20 mattias
started double buffering for gtk intf

7
lcl/interfaces/gtk/gtklclintf.inc
View File

@ -99,7 +99,7 @@ begin
if VertAdj=nil then
AdjValue:=y
else
AdjValue:=round(VertAdj^.value)+y;
AdjValue:=RoundToInt(VertAdj^.value)+y;
GListItem:=ListWidget^.children;
while GListItem<>nil do begin
inc(Result);
@ -160,7 +160,7 @@ begin
if VertAdj=nil then
AdjValue:=0
else
AdjValue:= (-round(VertAdj^.value));
AdjValue:= (-RoundToInt(VertAdj^.value));
GListItem:=ListWidget^.children;
while GListItem<>nil do begin
ListItemWidget:=PGtkWidget(GListItem^.data);
@ -293,6 +293,9 @@ end;
{ =============================================================================
$Log$
Revision 1.12 2004/01/22 11:23:36 mattias
started MaskBlt for gtkIF and applied patch for dir dlg in env opts from Vincent
Revision 1.11 2004/01/12 13:43:12 mattias
improved and activated new statusbar

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

@ -1621,7 +1621,7 @@ procedure TGtkObject.LoadFromPixbufFile(Bitmap: TObject; Filename: PChar);
var
TheBitmap: TBitmap;
function LoadFile : Boolean;
function LoadFile: Boolean;
{$Ifndef NoGdkPixbufLib}
var
Src : PGDKPixbuf;
@ -2203,6 +2203,526 @@ begin
Result:=true;
end;
{------------------------------------------------------------------------------
Function: TgtkObject.StretchCopyArea
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: An optional mask
XMask, YMask: Only used if Mask<>nil
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.StretchCopyArea(DestDC: HDC; X, Y, Width, Height: Integer;
SrcDC: HDC; XSrc, YSrc, SrcWidth, SrcHeight: Integer;
Mask: HBITMAP; XMask, YMask: Integer;
Rop: Cardinal): Boolean;
//type
// TBltFunction = function: Boolean;
var
fGC: PGDKGC;
SrcDevContext, DestDevContext: TDeviceContext;
SrcGDIBitmap: PGdiObject;
TempPixmap, TempMaskPixmap: PGdkPixmap;
NewClipMask: PGdkPixmap;
SizeChange, ROpIsSpecial: Boolean;
CopyingWholeSrc: Boolean;
SrcWholeWidth, SrcWholeHeight: integer;
DestWholeWidth, DestWholeHeight: integer;
Procedure ResetClipping(DestGC : PGDKGC);
begin
ResetGCClipping(DestDC,DestGC);
if (NewClipMask <> nil) then begin
gdk_bitmap_unref(NewClipMask);
NewClipMask:=nil;
end;
end;
Function ScaleAndROP(DestGC: PGDKGC;
Src: PGDKDrawable; SrcPixmap, SrcMaskPixmap: PGdkPixmap): Boolean;
var
Depth: Integer;
begin
{$IFDEF VerboseStretchCopyArea}
writeln('ScaleAndROP START DestGC=',HexStr(Cardinal(DestGC),8),
' SrcPixmap=',HexStr(Cardinal(SrcPixmap),8),
' SrcMaskPixmap=',HexStr(Cardinal(SrcMaskPixmap),8));
{$ENDIF}
Result := False;
if DestGC = nil
then begin
WriteLn('WARNING: [TgtkObject.StretchCopyArea] Uninitialized DestGC');
exit;
end;
// copy the destination GC values into the temporary GC (fGC)
GDK_GC_COPY(fGC, DestGC);
// clear any previous clipping in the temporary GC (fGC)
gdk_gc_set_clip_region(fGC,nil);
gdk_gc_set_clip_rectangle(fGC,nil);
if CopyingWholeSrc then ;
if SizeChange then begin
{$IFDEF VerboseStretchCopyArea}
Depth:=gdk_visual_get_system^.Depth;
writeln('ScaleAndROP Scaling buffer: ',Width,' x ',Height,' x ',Depth,' CopyingWholeSrc=',CopyingWholeSrc);
{$ENDIF}
// Scale the src part to a temporary pixmap with the size of the
// destination rectangle
Result := ScalePixmap(fGC,
SrcPixmap,XSrc,YSrc,SrcWidth,SrcHeight,
GDK_ColorMap_Get_System,
Width,Height,TempPixmap);
if not Result then begin
writeln('WARNING: ScaleAndROP ScalePixmap for pixmap failed');
exit;
end;
// same for mask
if SrcMaskPixmap<>nil then begin
writeln('WARNING: ScaleAndROP Scaling mask not yet implemented');
{ColorMap:=gdk_colormap_new(gdk_visual_get_best_with_depth(1),2);
Result := ScalePixmap(DestGC,
SrcMaskPixmap,XSrc,YSrc,SrcWidth,SrcHeight,
ColorMap,
Width,Height,TempMaskPixmap);
gdk_colormap_unref(ColorMap);
if not Result then begin
writeln('WARNING: ScaleAndROP ScalePixmap for mask failed');
exit;
end;}
end;
end else if ROpIsSpecial then begin
// no scaling, but special ROp
Depth:=gdk_visual_get_system^.Depth;
{$IFDEF VerboseStretchCopyArea}
writeln('ScaleAndROP Creating rop buffer: ',Width,' x ',Height,' x ',Depth);
{$ENDIF}
TempPixmap := gdk_pixmap_new(nil,SrcWidth,SrcHeight,Depth);
gdk_window_copy_area(TempPixmap, fGC, 0, 0,
Src, XSrc, YSrc, SrcWidth, SrcHeight);
end;
// set raster operation in the destination GC
SetGCRasterOperation(DestGC,ROP);
Result:=true;
end;
Procedure ROPFillBuffer(DC : hDC);
var
OldCurrentBrush: PGdiObject;
Brush : hBrush;
begin
if TempPixmap=nil then exit;
if (ROp=WHITENESS) or (ROp=BLACKNESS) or (ROp=DSTINVERT) then begin
{$IFDEF VerboseStretchCopyArea}
writeln('ROPFillBuffer ROp=',ROp);
{$ENDIF}
with TDeviceContext(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);
SelectedColors := dcscCustom;
SelectGDKBrushProps(DC);
If not CurrentBrush^.IsNullBrush then begin
BeginGDKErrorTrap;
gdk_draw_rectangle(TempPixmap, GC, 1, 0, 0, Width, Height);
EndGDKErrorTrap;
end;
// Restore current brush
SelectedColors := dcscCustom;
CurrentBrush := OldCurrentBrush;
end;
end;
end;
function SrcDevBitmapToDrawable: Boolean;
var
SrcPixmap, MaskPixmap: PGdkPixmap;
begin
Result:=true;
{$IFDEF VerboseStretchCopyArea}
writeln('SrcDevBitmapToDrawable Start');
{$ENDIF}
SrcGDIBitmap:=SrcDevContext.CurrentBitmap;
if (SrcGDIBitmap=nil) then begin
writeln('SrcDevBitmapToDrawable NOTE: SrcDevContext.CurrentBitmap=nil');
exit;
end;
SrcPixmap:=SrcGDIBitmap^.GDIPixmapObject;
MaskPixmap:=nil;
if (Mask<>0) then
MaskPixmap:=PGdiObject(Mask)^.GDIBitmapMaskObject;
if MaskPixmap=nil then
MaskPixmap:=SrcGDIBitmap^.GDIBitmapMaskObject;
if (MaskPixmap=nil) and (not SizeChange) and (ROP=SRCCOPY)
then begin
// simply copy the area
{$IFDEF VerboseStretchCopyArea}
writeln('SrcDevBitmapToDrawable Simple copy');
{$ENDIF}
BeginGDKErrorTrap;
gdk_window_copy_area(DestDevContext.Drawable, DestDevContext.GC, X, Y,
SrcPixmap, XSrc, YSrc, Width, Height);
EndGDKErrorTrap;
exit;
end;
// create a temporary graphic context for the scale and raster operations
fGC := GDK_GC_New(DestDevContext.Drawable);
// perform raster operation and scaling into Scale and fGC
DestDevContext.SelectedColors := dcscCustom;
If not ScaleAndROP(DestDevContext.GC, SrcDevContext.Drawable, SrcPixmap,
MaskPixmap)
then begin
writeln('WARNING: SrcDevBitmapToDrawable: ScaleAndROP failed');
exit;
end;
{$IFDEF VerboseStretchCopyArea}
writeln('SrcDevBitmapToDrawable TempPixmap=',HexStr(Cardinal(TempPixmap),8),' TempMaskPixmap=',HexStr(Cardinal(TempMaskPixmap),8));
{$ENDIF}
if TempPixmap<>nil then begin
SrcPixmap:=TempPixmap;
XSrc:=0;
YSrc:=0;
SrcWidth:=Width;
SrcHeight:=Height;
end;
if TempMaskPixmap<>nil then begin
MaskPixmap:=TempMaskPixmap;
XMask:=0;
YMask:=0;
end;
GDK_GC_Unref(fGC);
Case ROP of
WHITENESS, BLACKNESS :
ROPFillBuffer(DestDC);
end;
{$IFDEF VerboseStretchCopyArea}
writeln('SrcDevBitmapToDrawable ',
' SrcPixmap=',HexStr(Cardinal(SrcPixmap),8),
' XSrc=',XSrc,' YSrc=',YSrc,' SrcWidth=',SrcWidth,' SrcHeight=',SrcHeight,
' MaskPixmap=',HexStr(Cardinal(MaskPixmap),8),
' XMask=',XMask,' YMask=',YMask,
'');
{$ENDIF}
// set clipping mask for transparency
MergeClipping(DestDevContext, DestDevContext.GC, X,Y,Width,Height,
MaskPixmap,XMask,YMask,
NewClipMask);
// draw image
BeginGDKErrorTrap;
gdk_window_copy_area(DestDevContext.Drawable, DestDevContext.GC, X, Y,
SrcPixmap, XSrc, YSrc, SrcWidth, SrcHeight);
EndGDKErrorTrap;
// unset clipping mask for transparency
ResetClipping(DestDevContext.GC);
// restore raster operation to SRCCOPY
GDK_GC_Set_Function(DestDevContext.GC, GDK_Copy);
Result:=True;
end;
function DrawableToDrawable: Boolean;
begin
{$IFDEF VerboseStretchCopyArea}
writeln('DrawableToDrawable Start');
{$ENDIF}
Result:=SrcDevBitmapToDrawable;
end;
function PixmapToDrawable: Boolean;
begin
{$IFDEF VerboseStretchCopyArea}
writeln('PixmapToDrawable Start');
{$ENDIF}
Result:=SrcDevBitmapToDrawable;
end;
function ImageToImage: Boolean;
begin
WriteLn('WARNING: [TgtkObject.StretchCopyArea] ImageToImage unimplemented!');
Result:=false;
end;
function ImageToDrawable: Boolean;
begin
WriteLn('WARNING: [TgtkObject.StretchCopyArea] ImageToDrawable unimplemented!');
Result:=false;
end;
function ImageToBitmap: Boolean;
begin
WriteLn('WARNING: [TgtkObject.StretchCopyArea] ImageToBitmap unimplemented!');
Result:=false;
end;
function PixmapToImage: Boolean;
begin
WriteLn('WARNING: [TgtkObject.StretchCopyArea] PixmapToImage unimplemented!');
Result:=false;
end;
function PixmapToBitmap: Boolean;
begin
WriteLn('WARNING: [TgtkObject.StretchCopyArea] PixmapToBitmap unimplemented!');
Result:=false;
end;
function BitmapToImage: Boolean;
begin
WriteLn('WARNING: [TgtkObject.StretchCopyArea] BitmapToImage unimplemented!');
Result:=false;
end;
function BitmapToPixmap: Boolean;
begin
WriteLn('WARNING: [TgtkObject.StretchCopyArea] BitmapToPixmap unimplemented!');
Result:=false;
end;
function Unsupported: Boolean;
begin
WriteLn('WARNING: [TgtkObject.StretchCopyArea] Destination and/or Source '
+ 'unsupported!!');
Result:=false;
end;
//----------
function NoDrawableToNoDrawable: Boolean;
begin
If (SrcDevContext.CurrentBitmap <> nil) and
(DestDevContext.CurrentBitmap <> nil)
then
case SrcDevContext.CurrentBitmap^.GDIBitmapType of
gbBitmap: case TDeviceContext(DestDC).CurrentBitmap^.GDIBitmapType of
gbBitmap: Result:=DrawableToDrawable;
gbPixmap: Result:=BitmapToPixmap;
gbImage: Result:=BitmapToImage;
end;
gbPixmap: case TDeviceContext(DestDC).CurrentBitmap^.GDIBitmapType of
gbBitmap: Result:=PixmapToBitmap;
gbPixmap: Result:=DrawableToDrawable;
gbImage: Result:=PixmapToImage;
end;
gbImage: case TDeviceContext(DestDC).CurrentBitmap^.GDIBitmapType of
gbBitmap: Result:=ImageToBitmap;
gbPixmap: Result:=ImageToDrawable;
gbImage: Result:=ImageToImage;
end;
end
else
Result := Unsupported;
end;
function NoDrawableToDrawable: Boolean;
begin
If SrcDevContext.CurrentBitmap <> nil then
case TDeviceContext(SrcDC).CurrentBitmap^.GDIBitmapType of
gbBitmap: Result:=PixmapToDrawable;
gbPixmap: Result:=PixmapToDrawable;
gbImage: Result:=ImageToDrawable;
end
else
Result := Unsupported;
end;
function DrawableToNoDrawable: Boolean;
begin
If DestDevContext.CurrentBitmap <> nil then
case TDeviceContext(DestDC).CurrentBitmap^.GDIBitmapType of
gbBitmap: Result:=Unsupported;
gbPixmap: Result:=Unsupported;
gbImage: Result:=Unsupported;
end
else
Result := Unsupported;
end;
var
DCOrigin: TPoint;
NewSrcWidth: Integer;
NewSrcHeight: Integer;
NewWidth: Integer;
NewHeight: Integer;
begin
Result := IsValidDC(DestDC) and IsValidDC(SrcDC);
{$IFDEF VerboseStretchCopyArea}
writeln('StretchCopyArea Start ',Result);
{$ENDIF}
if not Result then exit;
if (Width=0) or (Height=0) then exit;
if (SrcWidth=0) or (SrcHeight=0) then exit;
SizeChange:=(Width<>SrcWidth) or (Height<>SrcHeight);
ROpIsSpecial:=(ROp<>SRCCOPY);
SrcDevContext:=TDeviceContext(SrcDC);
DestDevContext:=TDeviceContext(DestDC);
with SrcDevContext do begin
DCOrigin:=GetDCOffset(TDeviceContext(SrcDC));
Inc(XSrc,DCOrigin.X);
Inc(YSrc,DCOrigin.Y);
gdk_window_get_size(PGdkWindow(Drawable),@SrcWholeWidth,@SrcWholeHeight);
end;
with DestDevContext do begin
DCOrigin:=GetDCOffset(TDeviceContext(DestDC));
Inc(X,DCOrigin.X);
Inc(Y,DCOrigin.Y);
gdk_window_get_size(PGdkWindow(Drawable),@DestWholeWidth,@DestWholeHeight);
end;
{$IFDEF VerboseStretchCopyArea}
writeln('TgtkObject.StretchCopyArea BEFORE CLIPPING X=',X,' Y=',Y,' Width=',Width,' Height=',Height,
' XSrc=',XSrc,' YSrc=',YSrc,' SrcWidth=',SrcWidth,' SrcHeight=',SrcHeight,
' SrcDrawable=',HexStr(Cardinal(TDeviceContext(SrcDC).Drawable),8),
' DestDrawable=',HexStr(Cardinal(TDeviceContext(DestDC).Drawable),8),
' Mask=',HexStr(Cardinal(Mask),8),' XMask=',XMask,' YMask=',YMask,
' SizeChange=',SizeChange,' ROpIsSpecial=',ROpIsSpecial,
' DestWhole=',DestWholeWidth,',',DestWholeHeight,
' SrcWhole=',SrcWholeWidth,',',SrcWholeHeight,
'');
{$ENDIF}
if (X>=DestWholeWidth) or (Y>=DestWholeHeight) then exit;
if (X+Width<=0) then exit;
if (Y+Height<=0) then exit;
if (XSrc>=SrcWholeWidth) or (YSrc>=SrcWholeHeight) then exit;
if (XSrc+SrcWidth<=0) then exit;
if (YSrc+SrcHeight<=0) then exit;
// gdk does not allow copying areas, party laying out of bounds
// -> clip
// clip src to the left
if (XSrc<0) then begin
NewSrcWidth:=SrcWidth+XSrc;
NewWidth:=((Width*NewSrcWidth) div SrcWidth);
{$IFDEF VerboseStretchCopyArea}
writeln('StretchCopyArea Cliping Src to left NewSrcWidth=',NewSrcWidth,' NewWidth=',NewWidth);
{$ENDIF}
if NewWidth=0 then exit;
inc(X,Width-NewWidth);
if (X>=DestWholeWidth) then exit;
XSrc:=0;
SrcWidth:=NewSrcWidth;
end;
// clip src to the top
if (YSrc<0) then begin
NewSrcHeight:=SrcHeight+YSrc;
NewHeight:=((Height*NewSrcHeight) div SrcHeight);
{$IFDEF VerboseStretchCopyArea}
writeln('StretchCopyArea Cliping Src to top NewSrcHeight=',NewSrcHeight,' NewHeight=',NewHeight);
{$ENDIF}
if NewHeight=0 then exit;
inc(Y,Height-NewHeight);
if (Y>=DestWholeHeight) then exit;
YSrc:=0;
SrcHeight:=NewSrcHeight;
end;
// clip src to the right
if (XSrc+SrcWidth>SrcWholeWidth) then begin
NewSrcWidth:=SrcWholeWidth-XSrc;
Width:=((Width*NewSrcWidth) div SrcWidth);
{$IFDEF VerboseStretchCopyArea}
writeln('StretchCopyArea Cliping Src to right NewSrcWidth=',NewSrcWidth,' NewWidth=',Width);
{$ENDIF}
if (Width=0) then exit;
if (X+Width<=0) then exit;
SrcWidth:=NewSrcWidth;
end;
// clip src to the bottom
if (YSrc+SrcHeight>SrcWholeHeight) then begin
NewSrcHeight:=SrcWholeHeight-YSrc;
Height:=((Height*NewSrcHeight) div SrcHeight);
{$IFDEF VerboseStretchCopyArea}
writeln('StretchCopyArea Cliping Src to bottom NewSrcHeight=',NewSrcHeight,' NewHeight=',Height);
{$ENDIF}
if (Height=0) then exit;
if (Y+Height<=0) then exit;
SrcHeight:=NewSrcHeight;
end;
CopyingWholeSrc:=(XSrc=0) and (YSrc=0)
and (SrcWholeWidth=SrcWidth) and (SrcWholeHeight=SrcHeight);
if Mask=0 then begin
XMask:=XSrc;
YMask:=YSrc;
end;
// mark temporary scaling/rop buffers as uninitialized
TempPixmap:=nil;
TempMaskPixmap:=nil;
{$IFDEF VerboseStretchCopyArea}
writeln('TgtkObject.StretchCopyArea AFTER CLIPPING X=',X,' Y=',Y,' Width=',Width,' Height=',Height,
' XSrc=',XSrc,' YSrc=',YSrc,' SrcWidth=',SrcWidth,' SrcHeight=',SrcHeight,
' SrcDrawable=',HexStr(Cardinal(TDeviceContext(SrcDC).Drawable),8),
' DestDrawable=',HexStr(Cardinal(TDeviceContext(DestDC).Drawable),8),
' Mask=',HexStr(Cardinal(Mask),8),' XMask=',XMask,' YMask=',YMask,
' SizeChange=',SizeChange,' ROpIsSpecial=',ROpIsSpecial,
' CopyingWholeSrc=',CopyingWholeSrc);
{$ENDIF}
If TDeviceContext(SrcDC).Drawable = nil then begin
If TDeviceContext(DestDC).Drawable = nil then
Result := NoDrawableToNoDrawable
else
Result := NoDrawableToDrawable;
end
else begin
If TDeviceContext(DestDC).Drawable = nil then
Result := DrawableToNoDrawable
else
Result := DrawableToDrawable;
end;
if TempPixmap<>nil then
gdk_pixmap_unref(TempPixmap);
if TempMaskPixmap<>nil then
gdk_pixmap_unref(TempMaskPixmap);
end;
procedure TGtkObject.ListViewChangeItem(TheListView: TObject; Index: integer);
{$IfDef GTK2}
begin
@ -8691,6 +9211,9 @@ end;
{ =============================================================================
$Log$
Revision 1.454 2004/01/22 11:23:36 mattias
started MaskBlt for gtkIF and applied patch for dir dlg in env opts from Vincent
Revision 1.453 2004/01/14 20:09:50 mattias
added TColorDialog debugging

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

@ -191,9 +191,9 @@ var
begin
gtk_color_selection_get_color(colorsel, @colorArray[0]);
Color^.pixel := 0;
Color^.red := gushort(Trunc(colorArray[0] * $FFFF));
Color^.green := gushort(Trunc(colorArray[1] * $FFFF));
Color^.blue := gushort(Trunc(colorArray[2] * $FFFF));
Color^.red := gushort(TruncToCardinal(colorArray[0] * $FFFF));
Color^.green := gushort(TruncToCardinal(colorArray[1] * $FFFF));
Color^.blue := gushort(TruncToCardinal(colorArray[2] * $FFFF));
{$IFDEF VerboseColorDialog}
writeln('gtk_color_selection_get_current_color ',
' Red=',HexStr(Cardinal(Color^.Red),8),
@ -302,12 +302,10 @@ begin
end;
{$IfNDef NoGdkPixbufLib}
Procedure gdk_pixbuf_render_pixmap_and_mask(pixbuf : PGdkPixbuf; var pixmap_return : PGdkPixmap; var mask_return : PGdkBitmap; alpha_threshold : gint);
begin
gdkpixbuf.gdk_pixbuf_render_pixmap_and_mask(pixbuf, @pixmap_return, @mask_return, alpha_threshold);
end;
{$EndIf}
Function gdk_drawable_get_depth(Drawable : PGDKDrawable) : gint;
@ -471,7 +469,9 @@ var
Xerror : gint;
begin
Dec(GdkTrapCalls);
if (not GdkTrapIsSet) or (GdkTrapCalls > 0) then
if (not GdkTrapIsSet) then
RaiseGDBException('EndGDKErrorTrap without BeginGDKErrorTrap');
if (GdkTrapCalls > 0) then
exit;
Xerror := gdk_error_trap_pop;
@ -873,6 +873,255 @@ begin
end;
end;
procedure SetGCRasterOperation(TheGC: PGDKGC; Rop: Cardinal);
begin
Case ROP of
WHITENESS,
BLACKNESS,
SRCCOPY :
GDK_GC_Set_Function(TheGC, GDK_Copy);
SRCPAINT :
GDK_GC_Set_Function(TheGC, GDK_NOOP);
SRCAND :
GDK_GC_Set_Function(TheGC, GDK_Clear);
SRCINVERT :
GDK_GC_Set_Function(TheGC, GDK_XOR);
SRCERASE :
GDK_GC_Set_Function(TheGC, GDK_AND);
NOTSRCCOPY :
GDK_GC_Set_Function(TheGC, GDK_OR_REVERSE);
NOTSRCERASE :
GDK_GC_Set_Function(TheGC, GDK_AND);
MERGEPAINT :
GDK_GC_Set_Function(TheGC, GDK_Copy_Invert);
DSTINVERT :
GDK_GC_Set_Function(TheGC, GDK_INVERT);
else begin
gdk_gc_set_function(TheGC, GDK_COPY);
WriteLn('WARNING: [SetRasterOperation] Got unknown/unsupported CopyMode!!');
end;
end;
end;
procedure MergeClipping(DestinationDC: TDeviceContext; DestinationGC: PGDKGC;
X, Y, Width, Height: integer; ClipMergeMask: PGdkPixmap;
ClipMergeMaskX, ClipMergeMaskY: integer;
var NewClipMask: PGdkPixmap);
// merge ClipMergeMask into the destination clipping mask at the
// destination rectangle
var
temp_gc : PGDKGC;
temp_color : TGDKColor;
Region: PGdiObject;
RGNType : Longint;
OffsetXY: TPoint;
begin
{$IFDEF VerboseStretchCopyArea}
writeln('MergeClipping START DestinationDC=',HexStr(Cardinal(DestinationDC),8),
' DestinationGC=',HexStr(Cardinal(DestinationGC),8),
' X=',X,' Y=',Y,' Width=',Width,' Height=',Height,
' ClipMergeMask=',HexStr(Cardinal(ClipMergeMask),8),
' ClipMergeMaskX=',ClipMergeMaskX,' ClipMergeMaskY=',ClipMergeMaskY);
{$ENDIF}
// activate clipping region of destination
SelectGDIRegion(HDC(DestinationDC));
NewClipMask := nil;
if (ClipMergeMask = nil) then exit;
BeginGDKErrorTrap;
// create temporary mask with the size of the destination rectangle
NewClipMask := PGdkBitmap(gdk_pixmap_new(nil, width, height, 1));
// create temporary GC for combination mask
temp_gc := gdk_gc_new(NewClipMask);
gdk_gc_set_clip_region(temp_gc, nil); // no default clipping
gdk_gc_set_clip_rectangle(temp_gc, nil);
// clear mask
temp_color.pixel := 0;
gdk_gc_set_foreground(temp_gc, @temp_color);
gdk_draw_rectangle(NewClipMask, temp_gc, 1, 0, 0, width, height);
gdk_draw_rectangle(NewClipMask, temp_gc, 0, 0, 0, width, height);
// copy the destination clipping mask into the temporary mask
with DestinationDC do begin
If (ClipRegion <> 0) then begin
Region:=PGDIObject(ClipRegion);
RGNType := RegionType(Region^.GDIRegionObject);
If (RGNType <> ERROR) and (RGNType <> NULLREGION) then begin
// destination has a clipping mask
{$IFDEF VerboseStretchCopyArea}
writeln('MergeClipping Destination has clipping mask -> apply to temp GC');
{$ENDIF}
// -> copy the destination clipping mask to the temporary mask
// The X,Y coordinate in the destination relates to
// 0,0 in the temporary mask.
// The clip region of dest is always at 0,0 in dest
OffsetXY:=Point(-X,-Y);
// 1. Move the region
gdk_region_offset(Region^.GDIRegionObject,OffsetXY.X,OffsetXY.Y);
// 2. Apply region to temporary mask
gdk_gc_set_clip_region(temp_gc, Region^.GDIRegionObject);
// 3. Undo moving the region
gdk_region_offset(Region^.GDIRegionObject,-OffsetXY.X,-OffsetXY.Y);
end;
end;
end;
// merge the source clipping mask into the temporary mask
gdk_draw_pixmap(NewClipMask, temp_gc,
ClipMergeMask, ClipMergeMaskX, ClipMergeMaskY,
0, 0, Width, Height);
// free the temporary GC
gdk_gc_destroy(temp_gc);
// apply the new mask to the destination GC
// The new mask has only the size of the destination rectangle, not of
// the whole destination. Apply it to destination and move it to the right
// position.
gdk_gc_set_clip_mask(DestinationGC, NewClipMask);
gdk_gc_set_clip_origin(DestinationGC, x, y);
EndGDKErrorTrap;
end;
procedure ResetGCClipping(DC: HDC; GC: PGDKGC);
begin
BeginGDKErrorTrap;
gdk_gc_set_clip_mask(GC, nil);
gdk_gc_set_clip_origin (GC, 0,0);
SelectGDIRegion(DC);
EndGDKErrorTrap;
end;
function ScalePixmap(ScaleGC: PGDKGC;
SrcPixmap: PGdkPixmap; SrcX, SrcY, SrcWidth, SrcHeight: integer;
SrcColorMap: PGdkColormap;
NewWidth, NewHeight: integer;
var NewPixmap: PGdkPixmap) : Boolean;
{$Ifndef NoGdkPixbufLib}
var
ScaleSrc, ScaleDest: PGDKPixbuf;
ShrinkWidth,
ShrinkHeight : Boolean;
ScaleMethod : TGDKINTERPTYPE;
DummyMask: PGdkPixmap;
SrcWholeWidth, SrcWholeHeight: integer;
{$IFDEF VerboseStretchCopyArea}
NewWholeWidth, NewWholeHeight: integer;
{$ENDIF}
begin
{$IFDEF VerboseStretchCopyArea}
writeln('ScalePixmap ScaleGC=',HexStr(Cardinal(ScaleGC),8),
' SrcPixmap=',HexStr(Cardinal(SrcPixmap),8),
' SrcX=',SrcX,' SrcY=',SrcY,' SrcWidth=',SrcWidth,' SrcHeight=',SrcHeight,
' NewPixmap=',HexStr(Cardinal(NewPixmap),8),
' NewWidth=',NewWidth,' NewHeight=',NewHeight);
{$ENDIF}
Result := False;
if SrcPixmap=nil then begin
writeln('WARNING: ScalePixmap SrcPixmap=nil');
exit;
end;
if NewPixmap<>nil then begin
writeln('WARNING: ScalePixmap NewPixmap<>nil');
exit;
end;
ScaleSRC := nil;
ScaleDest := nil;
gdk_window_get_size(PGDKWindow(SrcPixmap),@SrcWholeWidth,@SrcWholeHeight);
if SrcX+SrcWidth>SrcWholeWidth then begin
writeln('WARNING: ScalePixmap SrcX+SrcWidth>SrcWholeWidth');
end;
if SrcY+SrcHeight>SrcWholeHeight then begin
writeln('WARNING: ScalePixmap SrcY+SrcHeight>SrcWholeHeight');
end;
// calculate ScaleMethod
ShrinkWidth := NewWidth < SrcWidth;
ShrinkHeight := NewHeight < 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;
// Creating PixBuf from pixmap
{$IFDEF VerboseStretchCopyArea}
writeln('ScalePixmap Creating PixBuf from pixmap SrcWhole=',SrcWholeWidth,',',SrcWholeHeight);
{$ENDIF}
ScaleSRC := gdk_pixbuf_get_from_drawable(nil,SrcPixmap,
SrcColorMap,0,0,SrcX,SrcY,SrcWidth,SrcHeight);
If ScaleSRC = nil then begin
writeln('WARNING: ScalePixmap ScaleSRC=nil');
exit;
end;
// Scaling PixBuf
{$IFDEF VerboseStretchCopyArea}
writeln('ScalePixmap Scaling PixBuf ',
' Width=',gdk_pixbuf_get_width(ScaleSrc),
' Height=',gdk_pixbuf_get_height(ScaleSrc),
' HasAlpha=',gdk_pixbuf_get_has_alpha(ScaleSrc),
' RowStride=',gdk_pixbuf_get_rowstride(ScaleSrc),
'');
{$ENDIF}
ScaleDest := gdk_pixbuf_scale_simple(ScaleSRC,NewWidth,NewHeight,ScaleMethod);
GDK_Pixbuf_Unref(ScaleSRC);
If ScaleDest = nil then begin
writeln('WARNING: ScalePixmap ScaleDest=nil');
exit;
end;
BeginGDKErrorTrap;
// Creating pixmap from scaled pixbuf
{$IFDEF VerboseStretchCopyArea}
writeln('ScalePixmap Creating pixmap from scaled pixbuf',
' Width=',gdk_pixbuf_get_width(ScaleDest),
' Height=',gdk_pixbuf_get_height(ScaleDest),
' HasAlpha=',gdk_pixbuf_get_has_alpha(ScaleDest),
' RowStride=',gdk_pixbuf_get_rowstride(ScaleDest),
'');
{$ENDIF}
DummyMask:=nil;
gdk_pixbuf_render_pixmap_and_mask(ScaleDest,NewPixmap,DummyMask,0);
// clean up
{$IFDEF VerboseStretchCopyArea}
gdk_window_get_size(PGDKWindow(NewPixmap),@NewWholeWidth,@NewWholeHeight);
writeln('ScalePixmap RESULT NewPixmap=',HexStr(Cardinal(NewPixmap),8),
' DummyMask=',HexStr(Cardinal(DummyMask),8),
' NewWidth=',NewWholeWidth,' NewHeight=',NewWholeHeight,
'');
{$ENDIF}
if DummyMask<>nil then gdk_pixmap_unref(DummyMask);
EndGDKErrorTrap;
GDK_Pixbuf_Unref(ScaleDest);
Result := True;
{$Else not NoGdkPixbufLib}
begin
WriteLn('ScalePixmap GDKPixbuf support has been disabled, no stretching is available!');
Result := True;
{$EndIf}
end;
{$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}
{------------------------------------------------------------------------------
Function: AllocGDKColor
Params: AColor: A RGB color (TColor)
@ -2557,10 +2806,10 @@ begin
if GtkWidgetIsA(Fixed,GTK_LAYOUT_GET_TYPE) then begin
Adjustment:=gtk_layout_get_hadjustment(PGtkLayout(Fixed));
if Adjustment<>nil then
dec(Result.X,Trunc(Adjustment^.Value-Adjustment^.Lower));
dec(Result.X,TruncToInt(Adjustment^.Value-Adjustment^.Lower));
Adjustment:=gtk_layout_get_vadjustment(PGtkLayout(Fixed));
if Adjustment<>nil then
dec(Result.Y,Trunc(Adjustment^.Value-Adjustment^.Lower));
dec(Result.Y,TruncToInt(Adjustment^.Value-Adjustment^.Lower));
end;
end;
end else begin
@ -5816,6 +6065,9 @@ end;
{ =============================================================================
$Log$
Revision 1.247 2004/01/22 11:23:36 mattias
started MaskBlt for gtkIF and applied patch for dir dlg in env opts from Vincent
Revision 1.246 2004/01/18 11:03:01 mattias
added finnish translation

121
lcl/interfaces/gtk/gtkproc.pp
View File

@ -27,7 +27,7 @@ interface
{off $DEFINE GDK_ERROR_TRAP_FLUSH}
{$DEFINE REPORT_GDK_ERRORS}
{.$DEFINE VerboseAccelerator}
{off $DEFINE VerboseAccelerator}
uses
SysUtils, Classes, FPCAdds,
@ -207,9 +207,6 @@ function ClipboardSelectionLostOwnershipHandler(TargetWidget: PGtkWidget;
Procedure GTKStyleChanged(Widget: PGtkWidget; previous_style :
PGTKStyle; Data: Pointer); cdecl;
function DeliverPostMessage(const Target: Pointer; var TheMessage): GBoolean;
function DeliverMessage(const Target: Pointer; var AMessage): Integer;
// gtkDragCallback.inc headers
Function edit_drag_data_received(widget : pgtkWidget;
Context : pGdkDragContext;
@ -248,31 +245,45 @@ function gtkLVEndSelection(AList: PGTKCList; AData: gPointer): GBoolean; cdecl;
function gtkComboBoxShowCB(widget: PGtkWidget; data: gPointer): GBoolean; cdecl;
function gtkComboBoxHideCB(widget: PGtkWidget; data: gPointer): GBoolean; cdecl;
//==============================================================================
// functions
procedure Set_RC_Name(Sender : TObject; AWidget: PGtkWidget);
// debugging
procedure RaiseException(const Msg: string);
function CreatePChar(const s: string): PChar;
function ComparePChar(P1, P2: PChar): boolean;
function FindChar(c: char; p:PChar; Max: integer): integer;
function GtkWidgetIsA(Widget: PGtkWidget; AType: TGtkType): boolean;
function GetWidgetClassName(Widget: PGtkWidget): string;
function GetWidgetDebugReport(Widget: PGtkWidget): string;
function GetWindowDebugReport(AWindow: PGDKWindow): string;
function GetDrawableDebugReport(ADrawable: PGDKDrawable): string;
// gtk resources
procedure Set_RC_Name(Sender : TObject; AWidget: PGtkWidget);
// messages
function DeliverPostMessage(const Target: Pointer; var TheMessage): GBoolean;
function DeliverMessage(const Target: Pointer; var AMessage): Integer;
// PChar
function CreatePChar(const s: string): PChar;
function ComparePChar(P1, P2: PChar): boolean;
function FindChar(c: char; p:PChar; Max: integer): integer;
// flags
function WidgetIsDestroyingHandle(Widget: PGtkWidget): boolean;
procedure SetWidgetIsDestroyingHandle(Widget: PGtkWidget);
function ComponentIsDestroyingHandle(AWinControl: TWinControl): boolean;
function LockOnChange(GtkObject: PGtkObject; LockOffset: integer): integer;
// glib
procedure MoveGListLinkBehind(First, Item, After: PGList);
// properties
function ObjectToGTKObject(const AnObject: TObject): PGtkObject;
function GetMainWidget(const Widget: Pointer): Pointer;
procedure SetMainWidget(const ParentWidget, ChildWidget: Pointer);
function GetFixedWidget(const Widget: Pointer): Pointer;
procedure SetFixedWidget(const ParentWidget, FixedWidget: Pointer);
Function GetControlWindow(Widget: Pointer) : PGDKWindow;
function GetDCOffset(DC: TDeviceContext): TPoint;
function CreateWidgetInfo(const Widget: Pointer): PWinWidgetInfo;
function GetWidgetInfo(const Widget: Pointer; const Create: Boolean): PWinWidgetInfo;
procedure FreeWinWidgetInfo(Widget: Pointer);
@ -282,34 +293,40 @@ function GetLCLObject(const Widget: Pointer): TObject;
function GetParentLCLObject(Widget: PGtkWidget): TObject;
procedure SetHiddenLCLObject(const Widget: Pointer; const AnObject: TObject);
function GetHiddenLCLObject(const Widget: Pointer): TObject;
Procedure FixedMoveControl(Parent, Child : PGTKWIdget; Left, Top : Longint);
Procedure FixedPutControl(Parent, Child : PGTKWidget; Left, Top : Longint);
function GetParentWidget(Child: PGtkWidget): PGtkWidget;
function GetParentFixedWidget(Child: PGtkWidget): PGtkWidget;
function FindFixedChild(ParentFixed: PGtkFixed; Child: PGtkWidget): PGList;
procedure MoveGListLinkBehind(First, Item, After: PGList);
// fixed widgets
Procedure FixedMoveControl(Parent, Child : PGTKWIdget; Left, Top : Longint);
Procedure FixedPutControl(Parent, Child : PGTKWidget; Left, Top : Longint);
// caret
procedure HideCaretOfWidgetGroup(ChildWidget: PGtkWidget;
var MainWidget: PGtkWidget; var CaretWasVisible: boolean);
// combobox
procedure SetComboBoxText(ComboWidget: PGtkCombo; NewText: PChar);
function GetComboBoxItemIndex(ComboBox: TComboBox): integer;
procedure SetComboBoxItemIndex(ComboBox: TComboBox; Index: integer);
// paint messages
function GtkPaintMessageToPaintMessage(const GtkPaintMsg: TLMGtkPaint;
FreeGtkPaintMsg: boolean): TLMPaint;
procedure FinalizePaintMessage(Msg: PLMessage);
procedure FinalizePaintTagMsg(Msg: PMsg);
function NewGDI_RGBImage(const AWidth, AHeight: Integer; const ADepth: Byte): PGDI_RGBImage;
// DC
function GetDCOffset(DC: TDeviceContext): TPoint;
function CopyDCData(DestinationDC, SourceDC: TDeviceContext): Boolean;
// region
Function RegionType(RGN: PGDKRegion): Longint;
Procedure SelectGDIRegion(const DC: HDC);
function GDKRegionAsString(RGN: PGDKRegion): string;
function CreateRectGDKRegion(const ARect: TRect): PGDKRegion;
function GDKRegionAsString(RGN: PGDKRegion): string;
// color
Procedure FreeGDIColor(GDIColor : PGDIColor);
Procedure AllocGDIColor(DC: hDC; GDIColor: PGDIColor);
procedure BuildColorRefFromGDKColor(var GDIColor : TGDIColor);
@ -323,10 +340,18 @@ function TColortoTGDKColor(const value : TColor) : TGDKColor;
procedure UpdateSysColorMap(Widget: PGtkWidget);
function IsBackgroundColor(Color: TColor): boolean;
procedure RealizeGDKColor(ColorMap: PGdkColormap; Color: PGDKColor);
procedure RealizeGtkStyleColor(Style: PGTKStyle; Color: PGDKColor);
Function GetSysGCValues(Color: TColorRef; ThemeWidget: PGtkWidget): TGDKGCValues;
Function GDKPixel2GDIRGB(Pixel : Longint; Visual : PGDKVisual;
Colormap : PGDKColormap) : TGDIRGB;
function CompareGDIColor(const Color1, Color2: TGDIColor): boolean;
function CompareGDIFill(const Fill1, Fill2: TGdkFill): boolean;
function CompareGDIBrushes(Brush1, Brush2: PGdiObject): boolean;
// palette
function PaletteIndexExists(Pal : PGDIObject; I : longint): Boolean;
function PaletteRGBExists(Pal : PGDIObject; RGB : longint): Boolean;
function PaletteAddIndex(Pal : PGDIObject; I, RGB : Longint): Boolean;
@ -353,17 +378,24 @@ function GetVKeyInfo(const AVKey: Byte): TVKeyInfo;
function IsToggleKey(const AVKey: Byte): Boolean;
//function GTKEventState2ShiftState(KeyState: Word): TShiftState;
//function KeyToListCode_(KeyCode, VirtKeyCode: Word; Extended: boolean): integer;
procedure gdk_event_key_get_string(Event : PGDKEventKey; var theString : Pointer);
function gdk_event_get_type(Event : Pointer) : guint;
procedure RememberKeyEventWasHandledByLCL(Event: PGdkEventKey);
function KeyEventWasHandledByLCL(Event: PGdkEventKey): boolean;
// ----
// common dialogs
procedure StoreCommonDialogSetup(ADialog: TCommonDialog);
procedure DestroyCommonDialogAddOns(ADialog: TCommonDialog);
// notebook
function GetGtkNoteBookDummyPage(ANoteBookWidget: PGtkNoteBook): PGtkWidget;
procedure SetGtkNoteBookDummyPage(ANoteBookWidget: PGtkNoteBook;
DummyWidget: PGtkWidget);
procedure UpdateNoteBookClientWidget(ANoteBook: TObject);
function GetGtkNoteBookPageCount(ANoteBookWidget: PGtkNoteBook): integer;
// coordinate transformation
function GetWidgetOrigin(TheWidget: PGtkWidget): TPoint;
function GetWidgetClientOrigin(TheWidget: PGtkWidget): TPoint;
function TranslateGdkPointToClientArea(SourceWindow: PGdkWindow;
@ -372,6 +404,13 @@ procedure ReleaseMouseCapture(OnlyIfCapturedByLCL: boolean);
procedure UpdateMouseCaptureControl;
procedure SetCursor(AWinControl : TWinControl; Data: Pointer);
{$IFNDEF GTK2_2}
// MWE:
// TODO: check if the new keyboard routines require X on GTK2
function X11Display: Pointer;
{$ENDIF}
// designing
type
TConnectSignalFlag = (
csfAfter, // connect after signal
@ -424,12 +463,6 @@ const
var
DesignSignalMasks: array[TDesignSignalType] of TDesignSignalMask;
{$IFNDEF GTK2_2}
// MWE:
// TODO: check if the new keyboard routines require X on GTK2
function X11Display: Pointer;
{$ENDIF}
procedure InitDesignSignalMasks;
function DesignSignalNameToType(Name: PChar; After: boolean): TDesignSignalType;
function GetDesignSignalMask(Widget: PGtkWidget): TDesignSignalMask;
@ -437,6 +470,7 @@ procedure SetDesignSignalMask(Widget: PGtkWidget; NewMask: TDesignSignalMask);
function GetDesignOnlySignalFlag(Widget: PGtkWidget;
DesignSignalType: TDesignSignalType): boolean;
// signals
procedure ConnectSignal(const AnObject:PGTKObject; const ASignal: PChar;
const ACallBackProc: Pointer; LCLComponent: TComponent;
const ReqSignalMask: TGdkEventMask; SFlags: TConnectSignalFlags);
@ -473,8 +507,25 @@ procedure Accelerate(Component: TComponent; const Widget : PGtkWidget;
procedure ShareWindowAccelGroups(AWindow: PGtkWidget);
procedure UnshareWindowAccelGroups(AWindow: PGtkWidget);
// pixmaps
procedure GetGdkPixmapFromGraphic(LCLGraphic: TGraphic;
var IconImg, IconMask: PGdkPixmap; var Width, Height: integer);
function NewGDI_RGBImage(const AWidth, AHeight: Integer; const ADepth: Byte): PGDI_RGBImage;
Procedure SetGCRasterOperation(TheGC: PGDKGC; Rop: Cardinal);
Procedure MergeClipping(DestinationDC: TDeviceContext; DestinationGC: PGDKGC;
X,Y,Width,Height: integer; ClipMergeMask: PGdkPixmap;
ClipMergeMaskX, ClipMergeMaskY: integer;
var NewClipMask: PGdkPixmap);
Procedure ResetGCClipping(DC: HDC; GC: PGDKGC);
function ScalePixmap(ScaleGC: PGDKGC;
SrcPixmap: PGdkPixmap; SrcX, SrcY, SrcWidth, SrcHeight: integer;
SrcColorMap: PGdkColormap;
NewWidth, NewHeight: integer;
var NewPixmap: PGdkPixmap) : Boolean;
{$IfDef Win32}
Procedure gdk_window_copy_area(Dest : PGDKWindow; GC : PGDKGC; X,
Y : Longint; SRC : PGDKWindow; XSRC, YSRC, Width, Height : Longint);
{$EndIf}
// menus
function MENU_ITEM_CLASS(widget: PGtkWidget): PGtkMenuItemClass;
@ -492,6 +543,7 @@ function CreateMenuItem(LCLMenuItem: TMenuItem): Pointer;
procedure GetGdkPixmapFromMenuItem(LCLMenuItem: TMenuItem;
var IconImg, IconMask: PGdkPixmap; var Width, Height: integer);
// size messages
procedure SaveSizeNotification(Widget: PGtkWidget);
procedure SaveClientSizeNotification(FixWidget: PGtkWidget);
function CreateTopologicalSortedWidgets(HashArray: TDynHashArray): TList;
@ -501,8 +553,10 @@ function RequestSelectionData(ClipboardWidget: PGtkWidget;
ClipboardType: TClipboardType; FormatID: cardinal): TGtkSelectionData;
procedure FreeClipboardTargetEntries(ClipboardType: TClipboardType);
// forms
Function CreateFormContents(AForm: TCustomForm; var FormWidget: Pointer): Pointer;
// style
function IndexOfStyle(const WName : String): integer;
Procedure ReleaseStyle(const WName : String);
function GetStyle(const WName : String) : PGTKStyle;
@ -526,17 +580,11 @@ function GetDefaultFontName: string;
Procedure FillScreenFonts(ScreenFonts : TStrings);
function GetTextHeight(DCTextMetric: TDevContextTextMetric): integer;
procedure RealizeGDKColor(ColorMap: PGdkColormap; Color: PGDKColor);
procedure RealizeGtkStyleColor(Style: PGTKStyle; Color: PGDKColor);
Function GetSysGCValues(Color: TColorRef; ThemeWidget: PGtkWidget): TGDKGCValues;
Function GDKPixel2GDIRGB(Pixel : Longint; Visual : PGDKVisual;
Colormap : PGDKColormap) : TGDIRGB;
// decoration
Function GetWindowDecorations(AForm : TCustomForm) : Longint;
Function GetWindowFunction(AForm : TCustomForm) : Longint;
// mouse cursor
function GetGDKMouseCursor(Cursor: TCursor): PGdkCursor;
Procedure FreeGDKCursors;
@ -547,12 +595,7 @@ function gtk_widget_get_ythickness(Style : PGTKStyle) : gint; overload;
function gtk_widget_get_xthickness(Style : PGTKWidget) : gint; overload;
function gtk_widget_get_ythickness(Style : PGTKWidget) : gint; overload;
// keyboard
procedure gdk_event_key_get_string(Event : PGDKEventKey; var theString : Pointer);
function gdk_event_get_type(Event : Pointer) : guint;
procedure RememberKeyEventWasHandledByLCL(Event: PGdkEventKey);
function KeyEventWasHandledByLCL(Event: PGdkEventKey): boolean;
// debugging
procedure BeginGDKErrorTrap;
procedure EndGDKErrorTrap;
@ -790,10 +833,6 @@ finalization
{$ENDIF}
{$ENDIF}
GdkTrapCalls := 0;
EndGDKErrorTrap;
DoneKeyboardTables;
end.

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

@ -4225,9 +4225,7 @@ begin
If IsValidDC(DC) then
with TDeviceContext(DC) do begin
if Drawable<>nil then begin
BeginGDKErrorTrap;
gdk_window_get_size(PGdkWindow(Drawable), @P.X, @P.Y);
EndGDKErrorTrap;
Result := true;
end else begin
{$IFDEF RaiseExceptionOnNilPointers}
@ -4892,7 +4890,7 @@ begin
end;
// PAGE
if (fMask and SIF_PAGE) <> 0 then
nPage := Cardinal(Round(Page_Size));
nPage := RoundToCardinal(Page_Size);
// TRACKPOS
if (fMask and SIF_TRACKPOS)<>0 then
nTrackPos := RoundToInt(Value);
@ -5943,7 +5941,7 @@ end;
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
ROp: The raster operation to be performed
Returns: True if succesful
The MaskBlt function copies a bitmap from a source context into a destination
@ -5951,9 +5949,12 @@ end;
------------------------------------------------------------------------------}
function TgtkObject.MaskBlt(DestDC: HDC; X, Y, Width, Height: Integer;
SrcDC: HDC; XSrc, YSrc: Integer; Mask: HBITMAP; XMask, YMask: Integer;
Rop: DWORD): Boolean;
ROp: DWORD): Boolean;
begin
Result:=false;
Result:=StretchMaskBlt(DestDC,X,Y,Width,Height,
SrcDC,XSrc,YSrc,Width,Height,
Mask,XMask,YMask,
ROp);
end;
{------------------------------------------------------------------------------
@ -7978,10 +7979,10 @@ begin
{writeln('');
writeln('[TgtkObject.SetScrollInfo] Result=',Result,
' Lower=',round(Lower),
' Upper=',round(Upper),
' Page_Size=',round(Page_Size),
' Page_Increment=',round(Page_Increment),
' Lower=',RoundToInt(Lower),
' Upper=',RoundToInt(Upper),
' Page_Size=',RoundToInt(Page_Size),
' Page_Increment=',RoundToInt(Page_Increment),
' bRedraw=',bRedraw,
' Handle=',HexStr(Cardinal(Handle),8));}
@ -8009,12 +8010,12 @@ begin
end;
{writeln('');
writeln('TgtkObject.SetScrollInfo: ',
' lower=',round(lower),'/',nMin,
' upper=',round(upper),'/',nMax,
' value=',round(value),'/',nPos,
' step_increment=',round(step_increment),'/',1,
' page_increment=',round(page_increment),'/',nPage,
' page_size=',round(page_size),'/',nPage,
' lower=',RoundToInt(lower),'/',nMin,
' upper=',RoundToInt(upper),'/',nMax,
' value=',RoundToInt(value),'/',nPos,
' step_increment=',RoundToInt(step_increment),'/',1,
' page_increment=',RoundToInt(page_increment),'/',nPage,
' page_size=',RoundToInt(page_size),'/',nPage,
'');}
gtk_adjustment_changed(Adjustment);
@ -8341,7 +8342,7 @@ end;
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
ROp: The raster operation to be performed
Returns: True if succesful
The StretchBlt function copies a bitmap from a source rectangle into a
@ -8354,551 +8355,12 @@ end;
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: TDeviceContext;
SrcGDIBitmap: PGdiObject;
ScaleBMP : hBITMAP;
Scale : PGdiObject;
temp_mask : PGdkPixmap;
{$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; ClipMergeMask: PGdiObject);
// merge ClipMergeMask into the destination clipping mask at the
// destination rectangle
var
temp_gc : PGDKGC;
temp_color : TGDKColor;
Region: PGdiObject;
RGNType : Longint;
OffsetXY: TPoint;
begin
// activate clipping region of destination
SelectGDIRegion(DestDC);
temp_mask := nil;
if ((ClipMergeMask = NIL)
or (ClipMergeMask^.GDIBitmapMaskObject = nil)) then exit;
BeginGDKErrorTrap;
// create temporary mask with the size of the destination rectangle
temp_mask := PGdkBitmap(gdk_pixmap_new(NIL, width, height, 1));
// create temporary GC for mask with no clipping
temp_gc := gdk_gc_new(temp_mask);
gdk_gc_set_clip_region(temp_gc, nil);
gdk_gc_set_clip_rectangle(temp_gc, nil);
// clear mask
temp_color.pixel := 0;
gdk_gc_set_foreground(temp_gc, @temp_color);
gdk_draw_rectangle(temp_mask, temp_gc, 1, 0, 0, width, height);
gdk_draw_rectangle(temp_mask, temp_gc, 0, 0, 0, width, height);
// copy the destination clipping mask into the temporary mask
with TDeviceContext(DestDC) do
begin
If (ClipRegion <> 0) then begin
Region:=PGDIObject(ClipRegion);
RGNType := RegionType(Region^.GDIRegionObject);
If (RGNType <> ERROR) and (RGNType <> NULLREGION) then begin
// destination has a clipping mask
// -> copy the destination clipping mask to the temporary mask
// The X,Y coordinate in the destination relates to
// 0,0 in the temporary mask.
// The clip region of dest is always at 0,0 in dest
OffsetXY:=Point(-X,-Y);
// 1. Move the region
gdk_region_offset(Region^.GDIRegionObject,OffsetXY.X,OffsetXY.Y);
// 2. Apply region to temporary mask
gdk_gc_set_clip_region(temp_gc, Region^.GDIRegionObject);
// 3. Undo moving the region
gdk_region_offset(Region^.GDIRegionObject,-OffsetXY.X,-OffsetXY.Y);
end;
end;
end;
// merge the source clipping mask into the temporary mask
gdk_draw_pixmap(temp_mask, temp_gc, ClipMergeMask^.GDIBitmapMaskObject,
0, 0, 0, 0, width, height);
// free the temporary GC
gdk_gc_destroy(temp_gc);
// apply the new mask to the destination GC
// The new mask has only the size of the destination rectangle, not of
// the whole destination. Apply it to destination and move it to the right
// position
gdk_gc_set_clip_mask(DestGC, temp_mask);
gdk_gc_set_clip_origin(DestGC, x, y);
EndGDKErrorTrap;
end;
Procedure ResetClipping(DestGC : PGDKGC);
begin
BeginGDKErrorTrap;
gdk_gc_set_clip_mask (DestGC, nil);
gdk_gc_set_clip_origin (DestGC, 0,0);
if (temp_mask <> nil) then gdk_bitmap_unref(temp_mask);
SelectGDIRegion(DestDC);
EndGDKErrorTrap;
end;
Procedure SetRasterOperation(TheGC : PGDKGC);
begin
Case ROP of
WHITENESS,
BLACKNESS,
SRCCOPY :
GDK_GC_Set_Function(TheGC, GDK_Copy);
SRCPAINT :
GDK_GC_Set_Function(TheGC, GDK_NOOP);
SRCAND :
GDK_GC_Set_Function(TheGC, GDK_Clear);
SRCINVERT :
GDK_GC_Set_Function(TheGC, GDK_XOR);
SRCERASE :
GDK_GC_Set_Function(TheGC, GDK_AND);
NOTSRCCOPY :
GDK_GC_Set_Function(TheGC, GDK_OR_REVERSE);
NOTSRCERASE :
GDK_GC_Set_Function(TheGC, GDK_AND);
MERGEPAINT :
GDK_GC_Set_Function(TheGC, GDK_Copy_Invert);
DSTINVERT :
GDK_GC_Set_Function(TheGC, GDK_INVERT);
else begin
gdk_gc_set_function(TheGC, 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;
BeginGDKErrorTrap;
ScaleSRC := gdk_pixbuf_get_from_drawable(nil,Scale^.GDIPixmapObject,
GDK_ColorMap_Get_System,0,0,0,0,SrcWidth,SrcHeight);
EndGDKErrorTrap;
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(0, Width, Height);
Scale := PGdiObject(ScaleBMP);
BeginGDKErrorTrap;
gdk_pixbuf_render_pixmap_and_mask(ScaleDest,Scale^.GDIPixmapObject,
Scale^.GDIBitmapMaskObject,0);
EndGDKErrorTrap;
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(DestGC: PGDKGC;
Src: PGDKDrawable; SrcBitmap: PGDIObject): Boolean;
var
SrcClip : PGDKPixmap;
begin
Result := False;
if DestGC = nil
then begin
WriteLn('WARNING: [TgtkObject.StretchBlt] Uninitialized DestGC');
exit;
end;
// get source mask for clipping
If (SrcBitmap <> nil)
and (SrcBitmap^.GDIBitmapMaskObject <> nil) then
SrcClip := SrcBitmap^.GDIBitmapMaskObject
else
SrcClip := nil;
// create a temporary buffer for raster operations and scaling
Case ROP of
WHITENESS,
BLACKNESS,
DSTINVERT :
begin
ScaleBMP := CreateCompatibleBitmap(0, Width, Height);
Scale := PGdiObject(ScaleBMP);
Scale^.GDIBitmapMaskObject := SrcClip;
SetRasterOperation(DestGC);
Result := True;
exit; //skip scaling
end;
else begin
// create a temporary compatible bitmap with the size
// of the source and the source mask
ScaleBMP := CreateCompatibleBitmap(0, SrcWidth, SrcHeight);
Scale := PGdiObject(ScaleBMP);
Scale^.GDIBitmapMaskObject := SrcClip;
end;
end;
// set raster operation for SrcCopy or NotSrcCopy
If ROP = NotSrcErase then
GDK_GC_Set_Function(DestGC, GDK_OR_REVERSE)
else
GDK_GC_Set_Function(DestGC, GDK_Copy);
// copy the destination GC values into the temporary GC (fGC)
GDK_GC_COPY(fGC, DestGC);
// clear any previous clipping in the temporary GC (fGC)
gdk_gc_set_clip_region(fGC,nil);
gdk_gc_set_clip_rectangle(fGC,nil);
// copy source into scale buffer
BeginGDKErrorTrap;
gdk_window_copy_area(Scale^.GDIPixmapObject, fGC, 0, 0,
Src, XSrc, YSrc, SrcWidth, SrcHeight);
EndGDKErrorTrap;
// restore the raster operation back to SRCCOPY in the destination GC
GDK_GC_Set_Function(DestGC, GDK_Copy);
// Scale Buffer if needed
If (Width <> SrcWidth) or (Height <> SrcHeight) then
Result := ScaleBuffer(DestGC)
else
Result := True;
// set raster operation in the destination GC
If Result then
SetRasterOperation(DestGC);
end;
Procedure ROPFillBuffer(DC : hDC);
var
OldCurrentBrush: PGdiObject;
Brush : hBrush;
begin
with TDeviceContext(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);
SelectedColors := dcscCustom;
SelectGDKBrushProps(DC);
If not CurrentBrush^.IsNullBrush then begin
BeginGDKErrorTrap;
gdk_draw_rectangle(Scale^.GDIPixmapObject, GC, 1, 0, 0, Width, Height);
EndGDKErrorTrap;
end;
// Restore current brush
SelectedColors := dcscCustom;
CurrentBrush := OldCurrentBrush;
end;
end;
function DrawableToDrawable: Boolean;
begin
SrcDevContext:=TDeviceContext(SrcDC);
DestDevContext:=TDeviceContext(DestDC);
SrcGDIBitmap:=SrcDevContext.CurrentBitmap;
if (SrcGDIBitmap=nil) then exit;
if (SrcGDIBitmap^.GDIBitmapMaskObject=nil)
and (Width=SrcWidth) and (Height=SrcHeight)
and (ROP=SRCCOPY)
then begin
// simply copy the area
//writeln('DrawableToDrawable Simple copy');
BeginGDKErrorTrap;
gdk_window_copy_area(DestDevContext.Drawable, DestDevContext.GC, X, Y,
SrcGDIBitmap^.GDIPixmapObject, XSrc, YSrc, Width, Height);
EndGDKErrorTrap;
exit;
end;
// create a temporary graphic context for the scale and raster operations
fGC := GDK_GC_New(DestDevContext.Drawable);
// perform raster operation and scaling into Scale and fGC
DestDevContext.SelectedColors := dcscCustom;
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
BeginGDKErrorTrap;
gdk_window_copy_area(DestDevContext.Drawable,
DestDevContext.GC, X, Y, Scale^.GDIPixmapObject,
0, 0, Width, Height);
EndGDKErrorTrap;
// 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:=TDeviceContext(SrcDC);
DestDevContext:=TDeviceContext(DestDC);
SrcGDIBitmap:=SrcDevContext.CurrentBitmap;
fGC := GDK_GC_New(SrcDevContext.Drawable);
// perform raster operation and scaling in a buffer
DestDevContext.SelectedColors := dcscCustom;
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
BeginGDKErrorTrap;
gdk_window_copy_area(DestDevContext.Drawable,
DestDevContext.GC,X, Y, Scale^.GDIPixmapObject,
0, 0, Width, Height);
EndGDKErrorTrap;
// 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 (TDeviceContext(SrcDC).CurrentBitmap <> nil) and
(TDeviceContext(DestDC).CurrentBitmap <> nil)
then
case TDeviceContext(SrcDC).CurrentBitmap^.GDIBitmapType of
gbBitmap: case TDeviceContext(DestDC).CurrentBitmap^.GDIBitmapType of
gbBitmap: Result:=DrawableToDrawable;
gbPixmap: Result:=BitmapToPixmap;
gbImage: Result:=BitmapToImage;
end;
gbPixmap: case TDeviceContext(DestDC).CurrentBitmap^.GDIBitmapType of
gbBitmap: Result:=PixmapToBitmap;
gbPixmap: Result:=DrawableToDrawable;
gbImage: Result:=PixmapToImage;
end;
gbImage: case TDeviceContext(DestDC).CurrentBitmap^.GDIBitmapType of
gbBitmap: Result:=ImageToBitmap;
gbPixmap: Result:=ImageToDrawable;
gbImage: Result:=ImageToImage;
end;
end
else
Result := Unsupported;
end;
function NoDrawableToDrawable: Boolean;
{const
BLT_FUNCTION: array[TGDIBitmapType] of TBltFunction = (
@PixmapToDrawable, @PixmapToDrawable, @ImageToDrawable
);}
begin
If TDeviceContext(SrcDC).CurrentBitmap <> nil then
case TDeviceContext(SrcDC).CurrentBitmap^.GDIBitmapType of
gbBitmap: Result:=PixmapToDrawable;
gbPixmap: Result:=PixmapToDrawable;
gbImage: Result:=ImageToDrawable;
end
else
Result := Unsupported;
end;
function DrawableToNoDrawable: Boolean;
{const
BLT_FUNCTION: array[TGDIBitmapType] of TBltFunction = (
@Unsupported, @Unsupported, @Unsupported
);}
begin
If TDeviceContext(DestDC).CurrentBitmap <> nil then
case TDeviceContext(DestDC).CurrentBitmap^.GDIBitmapType of
gbBitmap: Result:=Unsupported;
gbPixmap: Result:=Unsupported;
gbImage: Result:=Unsupported;
end
else
Result := Unsupported;
end;
{const // FROM TO
DRAWABLE_MATRIX: array[Boolean, Boolean] of TBltFunction = (
(@NoDrawableToNoDrawable, @NoDrawableToDrawable),
(@DrawableToNoDrawable, @DrawableToDrawable)
);}
var DCOrigin: TPoint;
SrcDC: HDC; XSrc, YSrc, SrcWidth, SrcHeight: Integer; ROp: Cardinal): Boolean;
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 not Result then exit;
if (Width=0) and (Height=0) then exit;
if (SrcWidth=0) and (SrcHeight=0) then exit;
with TDeviceContext(DestDC) do begin
DCOrigin:=GetDCOffset(TDeviceContext(DestDC));
Inc(X,DCOrigin.X);
Inc(Y,DCOrigin.Y);
end;
with TDeviceContext(SrcDC) do begin
DCOrigin:=GetDCOffset(TDeviceContext(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,
' SrcDrawable=',HexStr(Cardinal(TDeviceContext(SrcDC).Drawable),8),
' DestDrawable=',HexStr(Cardinal(TDeviceContext(DestDC).Drawable),8));}
If TDeviceContext(SrcDC).Drawable = nil then begin
If TDeviceContext(DestDC).Drawable = nil then
Result := NoDrawableToNoDrawable
else
Result := NoDrawableToDrawable;
end
else begin
If TDeviceContext(DestDC).Drawable = nil then
Result := DrawableToNoDrawable
else
Result := DrawableToDrawable;
end;
Assert(True, Format('trace:< [TgtkObject.StretchBlt] DestDC:0x%x --> %s', [DestDC, BOOL_TEXT[Result]]));
Result:=StretchCopyArea(DestDC,X,Y,Width,Height,
SrcDC,XSrc,YSrc,SrcWidth,SrcHeight,
0,0,0,
ROp);
end;
{------------------------------------------------------------------------------
@ -8911,7 +8373,7 @@ end;
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
ROp: The raster operation to be performed
Returns: True if succesful
The StretchMaskBlt function copies a bitmap from a source rectangle into a
@ -8924,7 +8386,10 @@ 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;
Result:=StretchCopyArea(DestDC,X,Y,Width,Height,
SrcDC,XSrc,YSrc,SrcWidth,SrcHeight,
Mask,XMask,YMask,
ROp);
end;
{------------------------------------------------------------------------------
@ -9235,6 +8700,9 @@ end;
{ =============================================================================
$Log$
Revision 1.320 2004/01/22 11:23:36 mattias
started MaskBlt for gtkIF and applied patch for dir dlg in env opts from Vincent
Revision 1.319 2004/01/18 11:03:01 mattias
added finnish translation

5
lcl/interfaces/gtk/gtkwinapih.inc
View File

@ -197,7 +197,7 @@ function SetWindowPos(hWnd: HWND; hWndInsertAfter: HWND;
function ShowCaret(hWnd: HWND): Boolean; override;
function ShowScrollBar(Handle: HWND; wBar: Integer; bShow: Boolean): Boolean; override;
function ShowWindow(hWnd: HWND; nCmdShow: Integer): Boolean; override;
function StretchBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc, SrcWidth, SrcHeight: Integer; Rop: Cardinal): Boolean; override;
function StretchBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc, SrcWidth, SrcHeight: Integer; ROp: Cardinal): Boolean; override;
function StretchMaskBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc, SrcWidth, SrcHeight: Integer; Mask: HBITMAP; XMask, YMask: Integer; Rop: DWORD): Boolean; override;
Function TextOut(DC: HDC; X,Y : Integer; Str : Pchar; Count: Integer) : Boolean; override;
@ -214,6 +214,9 @@ Function WindowFromPoint(Point : TPoint) : HWND; override;
{ =============================================================================
$Log$
Revision 1.84 2004/01/22 11:23:36 mattias
started MaskBlt for gtkIF and applied patch for dir dlg in env opts from Vincent
Revision 1.83 2004/01/10 18:00:42 mattias
fixed GetWindowOrgEx, added GetDCOriginRelativeToWindow

4
lcl/interfaces/qt/qtcallback.inc
View File

@ -60,8 +60,8 @@ begin
end;
// MessE.WheelDelta := 1;
//MessE.State := state;
MessE.X := Trunc(x);
MessE.Y := Trunc(y);
MessE.X := TruncToInt(x);
MessE.Y := TruncToInt(y);
if MessE.Msg <> LM_NULL then

6
lcl/interfaces/win32/winext.pas
View File

@ -95,9 +95,9 @@ Function GetAncestor(Const HWnd: HWND; Const Flag: UINT): HWND; StdCall; Externa
Function GetComboBoxInfo(Const hwndCombo: HWND; pcbi: PCOMBOBOXINFO): BOOL; StdCall; External 'user32';
{ Functions allocate and dealocate memory used in ole32 functions
i.e. BrowseForFolder dialog functions}
function CoTaskMemAlloc(cb : ULONG) : PVOID; external 'ole32.dll' name 'CoTaskMemAlloc';
procedure CoTaskMemFree(pv : PVOID); external 'ole32.dll' name 'CoTaskMemFree';
e.g. BrowseForFolder dialog functions}
function CoTaskMemAlloc(cb : ULONG) : PVOID; stdcall; external 'ole32.dll' name 'CoTaskMemAlloc';
procedure CoTaskMemFree(pv : PVOID); stdcall; external 'ole32.dll' name 'CoTaskMemFree';
{ Miscellaneous functions }