You've already forked lazarus-ccr
adds lazextensions since virtualtreeview depends on it
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@3535 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
sekelsenmat
168
components/lclextensions/delphicompat.pas
Executable file
168
components/lclextensions/delphicompat.pas
Executable file
@ -0,0 +1,168 @@
|
|||||||
|
unit DelphiCompat;
|
||||||
|
|
||||||
|
{ Delphi Compatibility Unit
|
||||||
|
|
||||||
|
Copyright (C) 2007 Luiz Am�rico Pereira C�mara
|
||||||
|
pascalive@bol.com.br
|
||||||
|
|
||||||
|
This library is free software; you can redistribute it and/or modify it
|
||||||
|
under the terms of the GNU Library General Public License as published by
|
||||||
|
the Free Software Foundation; either version 2 of the License, or (at your
|
||||||
|
option) any later version with the following modification:
|
||||||
|
|
||||||
|
As a special exception, the copyright holders of this library give you
|
||||||
|
permission to link this library with independent modules to produce an
|
||||||
|
executable, regardless of the license terms of these independent modules,and
|
||||||
|
to copy and distribute the resulting executable under terms of your choice,
|
||||||
|
provided that you also meet, for each linked independent module, the terms
|
||||||
|
and conditions of the license of that module. An independent module is a
|
||||||
|
module which is not derived from or based on this library. If you modify
|
||||||
|
this library, you may extend this exception to your version of the library,
|
||||||
|
but you are not obligated to do so. If you do not wish to do so, delete this
|
||||||
|
exception statement from your version.
|
||||||
|
|
||||||
|
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. See the GNU Library General Public License
|
||||||
|
for more details.
|
||||||
|
|
||||||
|
You should have received a copy of the GNU Library General Public License
|
||||||
|
along with this library; if not, write to the Free Software Foundation,
|
||||||
|
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
|
{$mode objfpc}{$H+}
|
||||||
|
{.$define DEBUG_DELPHICOMPAT}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
LMessages, Types, Classes, LCLType, LCLVersion;
|
||||||
|
|
||||||
|
const
|
||||||
|
//Messages
|
||||||
|
WM_GETDLGCODE = LM_GETDLGCODE;
|
||||||
|
WM_ERASEBKGND = LM_ERASEBKGND;
|
||||||
|
WM_VSCROLL = LM_VSCROLL;
|
||||||
|
WM_HSCROLL = LM_HSCROLL;
|
||||||
|
WM_CHAR = LM_CHAR;
|
||||||
|
WM_KEYDOWN = LM_KEYDOWN;
|
||||||
|
WM_KEYUP = LM_KEYUP;
|
||||||
|
WM_KILLFOCUS = LM_KILLFOCUS;
|
||||||
|
WM_SIZE = LM_SIZE;
|
||||||
|
WM_LBUTTONDBLCLK = LM_LBUTTONDBLCLK;
|
||||||
|
WM_LBUTTONDOWN = LM_LBUTTONDOWN;
|
||||||
|
|
||||||
|
type
|
||||||
|
//TWM* types
|
||||||
|
TMessage = TLMessage;
|
||||||
|
TWMHScroll = TLMHScroll;
|
||||||
|
TWMVScroll = TLMVScroll;
|
||||||
|
TWMChar = TLMChar;
|
||||||
|
TWMKeyDown = TLMKeyDown;
|
||||||
|
TWMKeyUp = TLMKeyUp;
|
||||||
|
TWMKillFocus = TLMKillFocus;
|
||||||
|
TWMSize = TLMSize;
|
||||||
|
TWMLButtonDblClk = TLMLButtonDblClk;
|
||||||
|
TWMMeasureItem = TLMMeasureItem;
|
||||||
|
TWMDrawItem = TLMDrawItems;
|
||||||
|
|
||||||
|
//timer
|
||||||
|
TTimerNotify = procedure (TimerId: PtrUInt) of object;
|
||||||
|
|
||||||
|
function BeginDeferWindowPos(nNumWindows: LongInt):THandle;
|
||||||
|
function BitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc: Integer; Rop: DWORD): Boolean;
|
||||||
|
|
||||||
|
function CF_UNICODETEXT: TClipboardFormat;
|
||||||
|
function CopyImage(hImage: THandle; uType:LongWord; cxDesired, cyDesired: LongInt; fuFlags:LongWord):THandle;
|
||||||
|
|
||||||
|
function DeferWindowPos(hWinPosInfo, hWnd, hWndInsertAfter:THandle; x, y, cx, cy:longint; uFlags:LongWord):THandle;
|
||||||
|
function DrawTextW(hDC: HDC; lpString: PWideChar; nCount: Integer; var lpRect: TRect; uFormat: LongWord): Integer;
|
||||||
|
|
||||||
|
function EndDeferWindowPos(hWinPosInfo:THandle):Boolean;
|
||||||
|
function ExtTextOutW(DC: HDC; X, Y: Integer; Options: LongInt; Rect: PRect;
|
||||||
|
Str: PWideChar; Count: LongInt; Dx: PInteger): Boolean;
|
||||||
|
|
||||||
|
function GdiFlush: Boolean;
|
||||||
|
function GetACP:LongWord;
|
||||||
|
function GetBkColor(DC:HDC):COLORREF;
|
||||||
|
function GetCurrentObject(hdc: HDC; uObjectType: UINT): HGDIOBJ;
|
||||||
|
function GetDCEx(hWnd:THandle; hrgnClip:HRGN; flags:DWORD):HDC;
|
||||||
|
function GetDoubleClickTime: UINT;
|
||||||
|
function GetKeyboardLayout(dwLayout:DWORD):THandle;
|
||||||
|
function GetKeyboardState(lpKeyState:PBYTE):BOOLEAN;
|
||||||
|
function GetLocaleInfo(Locale, LCType:LongWord; lpLCData:PChar; cchData:longint):longint;
|
||||||
|
function GetRandomRgn(DC: HDC; Rgn: HRGN; iNum: Integer): Integer; stdcall;
|
||||||
|
function GetTextAlign(hDC:HDC): LongWord;
|
||||||
|
function GetTextExtentExPoint(DC: HDC; Str: PChar;
|
||||||
|
Count, MaxWidth: Integer; MaxCount, PartialWidths: PInteger;
|
||||||
|
var Size: TSize): BOOL;
|
||||||
|
function GetTextExtentExPointW(DC: HDC; Str: PWideChar; Count, MaxWidth: Integer;
|
||||||
|
MaxCount, PartialWidths: PInteger; var Size: TSize): BOOL;
|
||||||
|
function GetTextExtentPoint32W(DC: HDC; Str: PWideChar; Count: Integer; out Size: TSize): Boolean;
|
||||||
|
function GetTextExtentPointW(DC: HDC; Str: PWideChar; Count: Integer; out Size: TSize): Boolean;
|
||||||
|
function GetWindowDC(hWnd:THandle):HDC;
|
||||||
|
|
||||||
|
function ImageList_DragShowNolock(fShow: Boolean): Boolean;
|
||||||
|
function InvertRect(DC: HDC; const lprc: TRECT): Boolean;
|
||||||
|
|
||||||
|
function KillTimer(hWnd:THandle; nIDEvent:UINT_PTR):Boolean;
|
||||||
|
|
||||||
|
function MapWindowPoints(hWndFrom, hWndTo: HWND; var lpPoints; cPoints: UINT): Integer;
|
||||||
|
function MultiByteToWideChar(CodePage, dwFlags:DWORD; lpMultiByteStr:PChar; cchMultiByte:longint; lpWideCharStr:PWideChar;cchWideChar:longint):longint;
|
||||||
|
|
||||||
|
function OffsetRgn(hrgn:HRGN; nxOffset, nYOffset:longint):longint;
|
||||||
|
|
||||||
|
function RedrawWindow(hWnd:THandle; lprcUpdate:PRECT; hrgnUpdate:HRGN; flags:LongWord): Boolean;
|
||||||
|
|
||||||
|
function ScrollDC(DC:HDC; dx:longint; dy:longint; var lprcScroll:TRECT; var lprcClip:TRECT;hrgnUpdate:HRGN; lprcUpdate:PRECT):Boolean;
|
||||||
|
function ScrollWindow(hWnd:THandle; XAmount, YAmount:longint;lpRect:PRECT; lpClipRect:PRECT):Boolean;
|
||||||
|
function SetBrushOrgEx(DC:HDC; nXOrg, nYOrg:longint; lppt:PPOINT):Boolean;
|
||||||
|
function SetTimer(hWnd:THandle; nIDEvent:UINT_PTR; uElapse:LongWord; lpTimerFunc:TTimerNotify):UINT_PTR;
|
||||||
|
function SubtractRect(var lprcDst: TRect; const lprcSrc1, lprcSrc2: TRect): Boolean;
|
||||||
|
|
||||||
|
function TextOutW(DC: HDC; X,Y : Integer; Str : PWideChar; Count: Integer) : Boolean;
|
||||||
|
function ToAscii(uVirtKey, uScanCode:LongWord; lpKeyState: PByte; lpChar: PWord; uFlags:LongWord): LongInt;
|
||||||
|
|
||||||
|
function UpdateWindow(Handle: HWND): Boolean;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
|
||||||
|
uses
|
||||||
|
{$i uses.inc}
|
||||||
|
maps, LCLProc, LCLMessageGlue, Controls
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT}
|
||||||
|
,multiloglcl, filechannel
|
||||||
|
{$endif}
|
||||||
|
;
|
||||||
|
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT}
|
||||||
|
const
|
||||||
|
//Logger classes
|
||||||
|
lcInfo = 0;
|
||||||
|
lcStack = 1;
|
||||||
|
|
||||||
|
var
|
||||||
|
Logger: TLCLLogger;
|
||||||
|
{$endif}
|
||||||
|
|
||||||
|
|
||||||
|
{$i delphicompat.inc}
|
||||||
|
|
||||||
|
initialization
|
||||||
|
FTimerList := TTimerList.Create;
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT}
|
||||||
|
Logger := TLCLLogger.Create;
|
||||||
|
Logger.Channels.Add(TFileChannel.Create('delphicompat.log'));
|
||||||
|
Logger.ActivateClasses := [lcInfo,lcStack];
|
||||||
|
Logger.MaxStackCount := 3;
|
||||||
|
{$endif}
|
||||||
|
|
||||||
|
finalization
|
||||||
|
FTimerList.Free;
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT}
|
||||||
|
Logger.Free;
|
||||||
|
{$endif}
|
||||||
|
end.
|
||||||
82
components/lclextensions/include/carbon/delphicompat.inc
Executable file
82
components/lclextensions/include/carbon/delphicompat.inc
Executable file
@ -0,0 +1,82 @@
|
|||||||
|
|
||||||
|
{
|
||||||
|
Carbon Interface
|
||||||
|
|
||||||
|
Dummy implementation. Not tested.
|
||||||
|
Waiting for someone with a Mac to implement it
|
||||||
|
}
|
||||||
|
|
||||||
|
type
|
||||||
|
TTimerList = class
|
||||||
|
end;
|
||||||
|
|
||||||
|
var
|
||||||
|
FTimerList: TTimerList;
|
||||||
|
|
||||||
|
function CF_UNICODETEXT: TClipboardFormat;
|
||||||
|
begin
|
||||||
|
//todo
|
||||||
|
Result := TClipboardFormat(0);
|
||||||
|
end;
|
||||||
|
|
||||||
|
{
|
||||||
|
Only a few functions are necessary to compile VirtualTreeView:
|
||||||
|
BitBlt
|
||||||
|
GetCurrentObject
|
||||||
|
Set/KillTimer (Look at Qt/Gtk implementation)
|
||||||
|
}
|
||||||
|
|
||||||
|
{$define HAS_GETCURRENTOBJECT}
|
||||||
|
{.$define HAS_MAPMODEFUNCTIONS}
|
||||||
|
{.$define HAS_GETTEXTEXTENTEXPOINT}
|
||||||
|
{.$define HAS_GETDOUBLECLICKTIME}
|
||||||
|
{.$define HAS_GETTEXTALIGN}
|
||||||
|
{.$define HAS_GETWINDOWDC}
|
||||||
|
{.$define HAS_INVERTRECT}
|
||||||
|
{.$define HAS_OFFSETRGN}
|
||||||
|
{.$define HAS_REDRAWWINDOW}
|
||||||
|
{.$define HAS_SCROLLWINDOW}
|
||||||
|
{.$define HAS_SETBRUSHORGEX}
|
||||||
|
|
||||||
|
|
||||||
|
{$i ../generic/stubs.inc}
|
||||||
|
{$i ../generic/independentfunctions.inc}
|
||||||
|
{$i ../generic/unicodefunctions.inc}
|
||||||
|
|
||||||
|
|
||||||
|
function BitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc,
|
||||||
|
YSrc: Integer; Rop: DWORD): Boolean;
|
||||||
|
begin
|
||||||
|
Result := StretchMaskBlt(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc,
|
||||||
|
Width, Height, 0, 0, 0, Rop);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetCurrentObject(hdc: HDC; uObjectType: UINT): HGDIOBJ;
|
||||||
|
var
|
||||||
|
CarbonDC: TCarbonDeviceContext absolute hdc;
|
||||||
|
begin
|
||||||
|
Result := 0;
|
||||||
|
with CarbonDC do
|
||||||
|
begin
|
||||||
|
case uObjectType of
|
||||||
|
OBJ_BITMAP:
|
||||||
|
begin
|
||||||
|
if CarbonDC is TCarbonBitmapContext then
|
||||||
|
Result := HGDIOBJ(TCarbonBitmapContext(CarbonDC).Bitmap);
|
||||||
|
end;
|
||||||
|
OBJ_BRUSH: Result := HGDIOBJ(CurrentBrush);
|
||||||
|
OBJ_FONT: Result := HGDIOBJ(CurrentFont);
|
||||||
|
OBJ_PEN: Result := HGDIOBJ(CurrentPen);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function KillTimer(hWnd: THandle; nIDEvent: UINT_PTR):Boolean;
|
||||||
|
begin
|
||||||
|
Result := LCLIntf.KillTimer(hWnd, nIDEvent);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function SetTimer(hWnd: THandle; nIDEvent: UINT_PTR; uElapse: LongWord; lpTimerFunc: TTimerNotify): UINT_PTR;
|
||||||
|
begin
|
||||||
|
Result := LCLIntf.SetTimer(hWnd, nIDEvent, uElapse, nil{lpTimerFunc});
|
||||||
|
end;
|
||||||
24
components/lclextensions/include/carbon/lclext.inc
Executable file
24
components/lclextensions/include/carbon/lclext.inc
Executable file
@ -0,0 +1,24 @@
|
|||||||
|
|
||||||
|
|
||||||
|
function CreateBitmapMask(BitmapDC: HDC; Width, Height: Integer; TransparentColor: TColor): HBITMAP;
|
||||||
|
begin
|
||||||
|
//todo
|
||||||
|
Result := 0;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function DirectMaskBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc: Integer; Mask: HBITMAP): Boolean;
|
||||||
|
begin
|
||||||
|
//todo: see if is possible todo it faster
|
||||||
|
Result := StretchMaskBlt(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, Width, Height,
|
||||||
|
Mask, 0, 0, SRCCOPY);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function OptimalPixelFormat: TPixelFormat;
|
||||||
|
begin
|
||||||
|
Result := pfDevice;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function OSSupportsUTF16: Boolean;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
end;
|
||||||
1
components/lclextensions/include/carbon/uses.inc
Executable file
1
components/lclextensions/include/carbon/uses.inc
Executable file
@ -0,0 +1 @@
|
|||||||
|
InterfaceBase, LCLIntf, Graphics, CarbonInt, CarbonCanvas, Math,
|
||||||
2
components/lclextensions/include/carbon/uses_lclext.inc
Executable file
2
components/lclextensions/include/carbon/uses_lclext.inc
Executable file
@ -0,0 +1,2 @@
|
|||||||
|
uses
|
||||||
|
LclIntf;
|
||||||
67
components/lclextensions/include/cocoa/delphicompat.inc
Executable file
67
components/lclextensions/include/cocoa/delphicompat.inc
Executable file
@ -0,0 +1,67 @@
|
|||||||
|
|
||||||
|
{
|
||||||
|
Carbon Interface
|
||||||
|
|
||||||
|
Dummy implementation. Not tested.
|
||||||
|
Waiting for someone with a Mac to implement it
|
||||||
|
}
|
||||||
|
|
||||||
|
type
|
||||||
|
TTimerList = class
|
||||||
|
end;
|
||||||
|
|
||||||
|
var
|
||||||
|
FTimerList: TTimerList;
|
||||||
|
|
||||||
|
function CF_UNICODETEXT: TClipboardFormat;
|
||||||
|
begin
|
||||||
|
//todo
|
||||||
|
Result := TClipboardFormat(0);
|
||||||
|
end;
|
||||||
|
|
||||||
|
{
|
||||||
|
Only a few functions are necessary to compile VirtualTreeView:
|
||||||
|
BitBlt
|
||||||
|
GetCurrentObject
|
||||||
|
Set/KillTimer (Look at Qt/Gtk implementation)
|
||||||
|
}
|
||||||
|
|
||||||
|
{$define HAS_GETCURRENTOBJECT}
|
||||||
|
{.$define HAS_MAPMODEFUNCTIONS}
|
||||||
|
{.$define HAS_GETTEXTEXTENTEXPOINT}
|
||||||
|
{.$define HAS_GETDOUBLECLICKTIME}
|
||||||
|
{.$define HAS_GETTEXTALIGN}
|
||||||
|
{.$define HAS_GETWINDOWDC}
|
||||||
|
{.$define HAS_INVERTRECT}
|
||||||
|
{.$define HAS_OFFSETRGN}
|
||||||
|
{.$define HAS_REDRAWWINDOW}
|
||||||
|
{.$define HAS_SCROLLWINDOW}
|
||||||
|
{.$define HAS_SETBRUSHORGEX}
|
||||||
|
|
||||||
|
|
||||||
|
{$i ../generic/stubs.inc}
|
||||||
|
{$i ../generic/independentfunctions.inc}
|
||||||
|
{$i ../generic/unicodefunctions.inc}
|
||||||
|
|
||||||
|
|
||||||
|
function BitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc,
|
||||||
|
YSrc: Integer; Rop: DWORD): Boolean;
|
||||||
|
begin
|
||||||
|
Result := StretchMaskBlt(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc,
|
||||||
|
Width, Height, 0, 0, 0, Rop);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetCurrentObject(hdc: HDC; uObjectType: UINT): HGDIOBJ;
|
||||||
|
begin
|
||||||
|
Result := LCLIntf.GetCurrentObject(hdc, uObjectType);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function KillTimer(hWnd: THandle; nIDEvent: UINT_PTR):Boolean;
|
||||||
|
begin
|
||||||
|
Result := LCLIntf.KillTimer(hWnd, nIDEvent);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function SetTimer(hWnd: THandle; nIDEvent: UINT_PTR; uElapse: LongWord; lpTimerFunc: TTimerNotify): UINT_PTR;
|
||||||
|
begin
|
||||||
|
Result := LCLIntf.SetTimer(hWnd, nIDEvent, uElapse, nil{lpTimerFunc});
|
||||||
|
end;
|
||||||
24
components/lclextensions/include/cocoa/lclext.inc
Executable file
24
components/lclextensions/include/cocoa/lclext.inc
Executable file
@ -0,0 +1,24 @@
|
|||||||
|
|
||||||
|
|
||||||
|
function CreateBitmapMask(BitmapDC: HDC; Width, Height: Integer; TransparentColor: TColor): HBITMAP;
|
||||||
|
begin
|
||||||
|
//todo
|
||||||
|
Result := 0;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function DirectMaskBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc: Integer; Mask: HBITMAP): Boolean;
|
||||||
|
begin
|
||||||
|
//todo: see if is possible todo it faster
|
||||||
|
Result := StretchMaskBlt(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, Width, Height,
|
||||||
|
Mask, 0, 0, SRCCOPY);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function OptimalPixelFormat: TPixelFormat;
|
||||||
|
begin
|
||||||
|
Result := pfDevice;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function OSSupportsUTF16: Boolean;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
end;
|
||||||
1
components/lclextensions/include/cocoa/uses.inc
Executable file
1
components/lclextensions/include/cocoa/uses.inc
Executable file
@ -0,0 +1 @@
|
|||||||
|
InterfaceBase, LCLIntf, Graphics, CocoaInt, Math,
|
||||||
2
components/lclextensions/include/cocoa/uses_lclext.inc
Executable file
2
components/lclextensions/include/cocoa/uses_lclext.inc
Executable file
@ -0,0 +1,2 @@
|
|||||||
|
uses
|
||||||
|
LclIntf;
|
||||||
38
components/lclextensions/include/generic/independentfunctions.inc
Executable file
38
components/lclextensions/include/generic/independentfunctions.inc
Executable file
@ -0,0 +1,38 @@
|
|||||||
|
|
||||||
|
function MapWindowPoints(hWndFrom, hWndTo: HWND; var lpPoints; cPoints: UINT): Integer;
|
||||||
|
var
|
||||||
|
i: Integer;
|
||||||
|
XOffset, YOffset: SmallInt;
|
||||||
|
FromPoint, ToPoint: TPoint;
|
||||||
|
begin
|
||||||
|
FromPoint := Point(0, 0);
|
||||||
|
ToPoint := Point(0, 0);
|
||||||
|
if hWndFrom <> 0 then
|
||||||
|
ClientToScreen(hWndFrom, FromPoint);
|
||||||
|
if hWndTo <> 0 then
|
||||||
|
ClientToScreen(hWndTo, ToPoint);
|
||||||
|
XOffset := (FromPoint.X - ToPoint.X);
|
||||||
|
YOffset := (FromPoint.Y - ToPoint.Y);
|
||||||
|
for i := 0 to cPoints - 1 do
|
||||||
|
begin
|
||||||
|
PPoint(@lpPoints)[i].x := XOffset + PPoint(@lpPoints)[i].x;
|
||||||
|
PPoint(@lpPoints)[i].y := YOffset + PPoint(@lpPoints)[i].y;
|
||||||
|
end;
|
||||||
|
Result := MakeLong(XOffset, YOffset);
|
||||||
|
end;
|
||||||
|
|
||||||
|
{$ifndef HAS_GETDOUBLECLICKTIME}
|
||||||
|
function GetDoubleClickTime: UINT;
|
||||||
|
begin
|
||||||
|
//todo: see if gtk has a value. Use Windows default for now
|
||||||
|
Result := 500;
|
||||||
|
end;
|
||||||
|
{$endif}
|
||||||
|
|
||||||
|
{$ifndef HAS_REDRAWWINDOW}
|
||||||
|
function RedrawWindow(hWnd:THandle; lprcUpdate:PRECT; hrgnUpdate:HRGN; flags:LongWord):BOOLEAN;
|
||||||
|
begin
|
||||||
|
//todo: see if there's a better way of doing this
|
||||||
|
Result := LCLIntf.InvalidateRect(hWnd, lprcUpdate, (RDW_ERASE and flags) > 0);
|
||||||
|
end;
|
||||||
|
{$endif}
|
||||||
177
components/lclextensions/include/generic/stubs.inc
Executable file
177
components/lclextensions/include/generic/stubs.inc
Executable file
@ -0,0 +1,177 @@
|
|||||||
|
|
||||||
|
function BeginDeferWindowPos(nNumWindows:longint):THandle;
|
||||||
|
begin
|
||||||
|
Result := 0;
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
|
||||||
|
end;
|
||||||
|
|
||||||
|
function CopyImage(hImage:THANDLE; uType:LongWord; cxDesired, cyDesired: LongInt; fuFlags:LongWord):THandle;
|
||||||
|
begin
|
||||||
|
Result := 0;
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
|
||||||
|
end;
|
||||||
|
|
||||||
|
function DeferWindowPos(hWinPosInfo, hWnd, hWndInsertAfter:THandle; x, y, cx, cy:longint; uFlags:LongWord):THandle;
|
||||||
|
begin
|
||||||
|
Result := 0;
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
|
||||||
|
end;
|
||||||
|
|
||||||
|
function EndDeferWindowPos(hWinPosInfo:THandle):Boolean;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GdiFlush: Boolean;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetACP:LongWord;
|
||||||
|
begin
|
||||||
|
Result := 0;
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
|
||||||
|
end;
|
||||||
|
|
||||||
|
{$ifndef HAS_GETBKCOLOR}
|
||||||
|
function GetBkColor(DC:HDC):COLORREF;
|
||||||
|
begin
|
||||||
|
Result := 0;
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
|
||||||
|
end;
|
||||||
|
{$endif}
|
||||||
|
|
||||||
|
{$ifndef HAS_GETCURRENTOBJECT}
|
||||||
|
function GetCurrentObject(hdc: HDC; uObjectType: UINT): HGDIOBJ;
|
||||||
|
begin
|
||||||
|
Result := 0;
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
|
||||||
|
end;
|
||||||
|
{$endif}
|
||||||
|
|
||||||
|
function GetDCEx(hWnd:THandle; hrgnClip:HRGN; flags:DWORD):HDC;
|
||||||
|
begin
|
||||||
|
Result := 0;
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetKeyboardLayout(dwLayout:DWORD):THandle;
|
||||||
|
begin
|
||||||
|
Result := 0;
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetKeyboardState(lpKeyState: System.PByte):BOOLEAN;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetLocaleInfo(Locale, LCType:LongWord; lpLCData:PChar; cchData:longint):longint;
|
||||||
|
begin
|
||||||
|
Result := 0;
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetRandomRgn(DC: HDC; Rgn: HRGN; iNum: Integer): Integer; stdcall;
|
||||||
|
begin
|
||||||
|
Result := 0;
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
|
||||||
|
end;
|
||||||
|
|
||||||
|
{$ifndef HAS_GETTEXTEXTENTEXPOINT}
|
||||||
|
function GetTextExtentExPoint(DC: HDC; Str: PChar;
|
||||||
|
Count, MaxWidth: Integer; MaxCount, PartialWidths: PInteger;
|
||||||
|
var Size: TSize): BOOL;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
|
||||||
|
end;
|
||||||
|
{$endif}
|
||||||
|
|
||||||
|
{$ifndef HAS_GETTEXTALIGN}
|
||||||
|
function GetTextAlign(hDC:HDC): LongWord;
|
||||||
|
begin
|
||||||
|
Result := 0;
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
|
||||||
|
end;
|
||||||
|
{$endif}
|
||||||
|
|
||||||
|
{$ifndef HAS_GETWINDOWDC}
|
||||||
|
function GetWindowDC(hWnd:THandle):HDC;
|
||||||
|
begin
|
||||||
|
Result := 0;
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
|
||||||
|
end;
|
||||||
|
{$endif}
|
||||||
|
|
||||||
|
function ImageList_DragShowNolock(fShow: Boolean): Boolean;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
|
||||||
|
end;
|
||||||
|
|
||||||
|
{$ifndef HAS_INVERTRECT}
|
||||||
|
function InvertRect(DC: HDC; const lprc: TRect): Boolean;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
|
||||||
|
end;
|
||||||
|
{$endif}
|
||||||
|
|
||||||
|
function MultiByteToWideChar(CodePage, dwFlags:DWORD; lpMultiByteStr:PChar; cchMultiByte:longint; lpWideCharStr:PWideChar;cchWideChar:longint):longint;
|
||||||
|
begin
|
||||||
|
Result := 0;
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
|
||||||
|
end;
|
||||||
|
|
||||||
|
{$ifndef HAS_OFFSETRGN}
|
||||||
|
function OffsetRgn(hrgn:HRGN; nxOffset, nYOffset:longint):longint;
|
||||||
|
begin
|
||||||
|
Result := 0;
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
|
||||||
|
end;
|
||||||
|
{$endif}
|
||||||
|
|
||||||
|
function ScrollDC(DC:HDC; dx:longint; dy:longint; var lprcScroll:TRECT; var lprcClip:TRECT;hrgnUpdate:HRGN; lprcUpdate:PRECT):Boolean;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
|
||||||
|
end;
|
||||||
|
|
||||||
|
{$ifndef HAS_SCROLLWINDOW}
|
||||||
|
function ScrollWindow(hWnd:THandle; XAmount, YAmount:longint;lpRect:PRECT; lpClipRect:PRECT):Boolean;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
|
||||||
|
end;
|
||||||
|
{$endif}
|
||||||
|
|
||||||
|
{$ifndef HAS_SETBRUSHORGEX}
|
||||||
|
function SetBrushOrgEx(DC:HDC; nXOrg, nYOrg:longint; lppt:PPOINT):Boolean;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
|
||||||
|
end;
|
||||||
|
{$endif}
|
||||||
|
|
||||||
|
function SubtractRect(var lprcDst: TRect; const lprcSrc1, lprcSrc2: TRect): BOOLEAN;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
|
||||||
|
end;
|
||||||
|
|
||||||
|
function ToAscii(uVirtKey, uScanCode:LongWord; lpKeyState: System.PByte; lpChar: System.PWord; uFlags:LongWord):longint;
|
||||||
|
begin
|
||||||
|
Result := 0;
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
|
||||||
|
end;
|
||||||
|
|
||||||
|
function UpdateWindow(Handle: HWND): Boolean;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
|
||||||
|
end;
|
||||||
|
|
||||||
8
components/lclextensions/include/generic/timerfunctions.inc
Executable file
8
components/lclextensions/include/generic/timerfunctions.inc
Executable file
@ -0,0 +1,8 @@
|
|||||||
|
|
||||||
|
function KillTimer(hWnd:THandle; nIDEvent: LongWord):Boolean;
|
||||||
|
begin
|
||||||
|
end;
|
||||||
|
|
||||||
|
function SetTimer(hWnd:THandle; nIDEvent:LongWord; uElapse:LongWord; lpTimerFunc:TTimerNotify): LongWord;
|
||||||
|
begin
|
||||||
|
end;
|
||||||
84
components/lclextensions/include/generic/unicodefunctions.inc
Executable file
84
components/lclextensions/include/generic/unicodefunctions.inc
Executable file
@ -0,0 +1,84 @@
|
|||||||
|
|
||||||
|
{
|
||||||
|
GetUTF8ByteCount returns the number of bytes necessary to hold the requested number
|
||||||
|
of characters (count). Not necessarily the number of characters is equal to the
|
||||||
|
widestring length but here we assume it to skip the extra overhead
|
||||||
|
}
|
||||||
|
//todo do a function that convert the str and the count at one pass
|
||||||
|
function GetUTF8ByteCount(const UTF8Str: UTF8String; WideCount: Integer): Integer;
|
||||||
|
var
|
||||||
|
CharCount, CharLen, StrLen: Integer;
|
||||||
|
P: PChar;
|
||||||
|
begin
|
||||||
|
Result := 0;
|
||||||
|
CharCount := 0;
|
||||||
|
P := PChar(UTF8Str);
|
||||||
|
StrLen := Length(UTF8Str);
|
||||||
|
WideCount := Min(WideCount, StrLen);
|
||||||
|
while (CharCount < WideCount) do
|
||||||
|
begin
|
||||||
|
CharLen := UTF8CharacterLength(P);
|
||||||
|
Inc(P, CharLen);
|
||||||
|
Inc(Result, CharLen);
|
||||||
|
Inc(CharCount);
|
||||||
|
end;
|
||||||
|
Result := Min(Result, StrLen);
|
||||||
|
end;
|
||||||
|
|
||||||
|
{$ifndef HAS_DRAWTEXTW}
|
||||||
|
function DrawTextW(hDC: HDC; lpString: PWideChar; nCount: Integer; var lpRect: TRect; uFormat: LongWord): Integer;
|
||||||
|
var
|
||||||
|
TempStr: UTF8String;
|
||||||
|
begin
|
||||||
|
TempStr := UTF8Encode(WideString(lpString));
|
||||||
|
Result := DrawText(hDC, PChar(TempStr), GetUTF8ByteCount(TempStr, nCount),
|
||||||
|
lpRect, uFormat);
|
||||||
|
end;
|
||||||
|
{$endif}
|
||||||
|
|
||||||
|
function ExtTextOutW(DC: HDC; X, Y: Integer; Options: LongInt; Rect: PRect;
|
||||||
|
Str: PWideChar; Count: LongInt; Dx: ObjPas.PInteger): Boolean;
|
||||||
|
var
|
||||||
|
TempStr: UTF8String;
|
||||||
|
begin
|
||||||
|
TempStr := UTF8Encode(WideString(Str));
|
||||||
|
Result := ExtTextOut(DC, X, Y, Options, Rect, PChar(TempStr),
|
||||||
|
GetUTF8ByteCount(TempStr, Count), Dx);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetTextExtentPoint32W(DC: HDC; Str: PWideChar; Count: Integer; out Size: TSize): Boolean;
|
||||||
|
var
|
||||||
|
TempStr: UTF8String;
|
||||||
|
begin
|
||||||
|
TempStr := UTF8Encode(WideString(Str));
|
||||||
|
Result := GetTextExtentPoint(DC, PChar(TempStr),
|
||||||
|
GetUTF8ByteCount(TempStr, Count), Size);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetTextExtentExPointW(DC: HDC; Str: PWideChar;
|
||||||
|
Count, MaxWidth: Integer; MaxCount, PartialWidths: ObjPas.PInteger;
|
||||||
|
var Size: TSize): BOOL;
|
||||||
|
var
|
||||||
|
TempStr: UTF8String;
|
||||||
|
begin
|
||||||
|
TempStr := UTF8Encode(WideString(Str));
|
||||||
|
Result := DelphiCompat.GetTextExtentExPoint(DC, PChar(TempStr),
|
||||||
|
Count, MaxWidth, MaxCount, PartialWidths, Size);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetTextExtentPointW(DC: HDC; Str: PWideChar; Count: Integer; out Size: TSize): Boolean;
|
||||||
|
var
|
||||||
|
TempStr: UTF8String;
|
||||||
|
begin
|
||||||
|
TempStr := UTF8Encode(WideString(Str));
|
||||||
|
Result := GetTextExtentPoint(DC, PChar(TempStr),
|
||||||
|
GetUTF8ByteCount(TempStr, Count), Size);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TextOutW(DC: HDC; X,Y : Integer; Str : PWideChar; Count: Integer) : Boolean;
|
||||||
|
var
|
||||||
|
TempStr: UTF8String;
|
||||||
|
begin
|
||||||
|
TempStr := UTF8Encode(WideString(Str));
|
||||||
|
Result := TextOut(DC, X, Y, PChar(TempStr), GetUTF8ByteCount(TempStr, Count));
|
||||||
|
end;
|
||||||
336
components/lclextensions/include/gtk/delphicompat.inc
Executable file
336
components/lclextensions/include/gtk/delphicompat.inc
Executable file
@ -0,0 +1,336 @@
|
|||||||
|
|
||||||
|
{ This file is part of Delphi Compatibility Unit
|
||||||
|
|
||||||
|
Copyright (C) 2007 Luiz Américo Pereira Câmara
|
||||||
|
pascalive@bol.com.br
|
||||||
|
|
||||||
|
This library is free software; you can redistribute it and/or modify it
|
||||||
|
under the terms of the GNU Library General Public License as published by
|
||||||
|
the Free Software Foundation; either version 2 of the License, or (at your
|
||||||
|
option) any later version with the following modification:
|
||||||
|
|
||||||
|
As a special exception, the copyright holders of this library give you
|
||||||
|
permission to link this library with independent modules to produce an
|
||||||
|
executable, regardless of the license terms of these independent modules,and
|
||||||
|
to copy and distribute the resulting executable under terms of your choice,
|
||||||
|
provided that you also meet, for each linked independent module, the terms
|
||||||
|
and conditions of the license of that module. An independent module is a
|
||||||
|
module which is not derived from or based on this library. If you modify
|
||||||
|
this library, you may extend this exception to your version of the library,
|
||||||
|
but you are not obligated to do so. If you do not wish to do so, delete this
|
||||||
|
exception statement from your version.
|
||||||
|
|
||||||
|
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. See the GNU Library General Public License
|
||||||
|
for more details.
|
||||||
|
|
||||||
|
You should have received a copy of the GNU Library General Public License
|
||||||
|
along with this library; if not, write to the Free Software Foundation,
|
||||||
|
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
|
{$define HAS_INVERTRECT}
|
||||||
|
{$define HAS_DRAWTEXTW}
|
||||||
|
{$define HAS_GETCURRENTOBJECT}
|
||||||
|
{$define HAS_GETBKCOLOR}
|
||||||
|
{$define HAS_GETTEXTEXTENTEXPOINT}
|
||||||
|
{$define HAS_DRAWFRAMECONTROL}
|
||||||
|
{$define HAS_SCROLLWINDOW}
|
||||||
|
|
||||||
|
{$i ../generic/stubs.inc}
|
||||||
|
{$i ../generic/independentfunctions.inc}
|
||||||
|
{$i ../generic/unicodefunctions.inc}
|
||||||
|
|
||||||
|
function BitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc,
|
||||||
|
YSrc: Integer; Rop: DWORD): Boolean;
|
||||||
|
begin
|
||||||
|
Result := GTKWidgetSet.StretchCopyArea(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, Width, Height,
|
||||||
|
0, XSrc, YSrc, Rop);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function DrawFrameControl(DC: HDC; const Rect: TRect; uType, uState: LongWord): Boolean;
|
||||||
|
begin
|
||||||
|
Result := LCLIntf.DrawFrameControl(DC, Rect, uType, uState);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function DrawTextW(hDC: HDC; lpString: PWideChar; nCount: Integer; var lpRect: TRect; uFormat: LongWord): Integer;
|
||||||
|
var
|
||||||
|
TempStr: UTF8String;
|
||||||
|
TempRect: TRect;
|
||||||
|
TextHeight: Integer;
|
||||||
|
TM: TTextMetric;
|
||||||
|
begin
|
||||||
|
//Logger.Send('DrawTextW');
|
||||||
|
TempRect := lpRect;
|
||||||
|
//fix position under gtk (lcl bug 8565)
|
||||||
|
if (uFormat and DT_VCENTER) > 0 then
|
||||||
|
begin
|
||||||
|
GetTextMetrics(hDC, TM);
|
||||||
|
//gtk overestimate height
|
||||||
|
TextHeight := TM.tmHeight - 2;
|
||||||
|
TempRect.Top := (TempRect.Top + TempRect.Bottom - TextHeight) div 2;
|
||||||
|
end;
|
||||||
|
TempStr := UTF8Encode(WideString(lpString));
|
||||||
|
Result := DrawText(hDC, PChar(TempStr), GetUTF8ByteCount(TempStr, nCount),
|
||||||
|
TempRect, uFormat);
|
||||||
|
//Logger.Send('Rect',TempRect);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetBkColor(DC:HDC):COLORREF;
|
||||||
|
begin
|
||||||
|
if GTKWidgetSet.IsValidDC(DC) then
|
||||||
|
Result := TGtkDeviceContext(DC).CurrentBackColor.ColorRef
|
||||||
|
else
|
||||||
|
Result := CLR_INVALID;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetCurrentObject(hdc: HDC; uObjectType: UINT): HGDIOBJ;
|
||||||
|
begin
|
||||||
|
Result := 0;
|
||||||
|
if GTKWidgetSet.IsValidDC(hdc) then
|
||||||
|
with TGtkDeviceContext(hdc) do
|
||||||
|
begin
|
||||||
|
case uObjectType of
|
||||||
|
OBJ_BITMAP: Result := HGDIOBJ(CurrentBitmap);
|
||||||
|
OBJ_BRUSH: Result := HGDIOBJ(CurrentBrush);
|
||||||
|
OBJ_FONT: Result := HGDIOBJ(CurrentFont);
|
||||||
|
OBJ_PEN: Result := HGDIOBJ(CurrentPen);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetTextExtentExPoint(DC: HDC; Str: PChar; Count, MaxWidth: Integer;
|
||||||
|
MaxCount, PartialWidths: ObjPas.PInteger; var Size: TSize): BOOL;
|
||||||
|
var
|
||||||
|
lbearing, rbearing, width, ascent,descent: LongInt;
|
||||||
|
UseFont : PGDKFont;
|
||||||
|
IsDBCSFont: Boolean;
|
||||||
|
NewCount,Accumulator,i: Integer;
|
||||||
|
begin
|
||||||
|
//based in lcl code
|
||||||
|
Result := GTKWidgetSet.IsValidDC(DC);
|
||||||
|
if Result then
|
||||||
|
with TGtkDeviceContext(DC) do
|
||||||
|
begin
|
||||||
|
if (CurrentFont = nil) or (CurrentFont^.GDIFontObject = nil)
|
||||||
|
then begin
|
||||||
|
UseFont := GTKWidgetSet.GetDefaultGtkFont(false);
|
||||||
|
end
|
||||||
|
else begin
|
||||||
|
UseFont := CurrentFont^.GDIFontObject;
|
||||||
|
end;
|
||||||
|
If UseFont = nil then
|
||||||
|
DebugLn('WARNING: [TGtkWidgetSet.GetTextExtentPoint] Missing font')
|
||||||
|
else begin
|
||||||
|
descent:=0;
|
||||||
|
{
|
||||||
|
UpdateDCTextMetric(TDeviceContext(DC));
|
||||||
|
IsDBCSFont:=TDeviceContext(DC).DCTextMetric.IsDoubleByteChar;
|
||||||
|
|
||||||
|
if IsDBCSFont then begin
|
||||||
|
NewCount:=Count*2;
|
||||||
|
if FExtUTF8OutCacheSize<NewCount then begin
|
||||||
|
ReAllocMem(FExtUTF8OutCache,NewCount);
|
||||||
|
FExtUTF8OutCacheSize:=NewCount;
|
||||||
|
end;
|
||||||
|
NewCount:=UTF8ToDoubleByte(Str,Count,FExtUTF8OutCache)*2;
|
||||||
|
gdk_text_extents(UseFont, FExtUTF8OutCache, NewCount,
|
||||||
|
@lbearing, @rBearing, @width, @ascent, @descent);
|
||||||
|
end else begin
|
||||||
|
gdk_text_extents(UseFont, Str, Count,
|
||||||
|
@lbearing, @rBearing, @width, @ascent, @descent);
|
||||||
|
end;
|
||||||
|
}
|
||||||
|
gdk_text_extents(UseFont, Str, Count,@lbearing, @rBearing, @width, @ascent, @descent);
|
||||||
|
Size.cX := Width;
|
||||||
|
Size.cY := ascent+descent;
|
||||||
|
if PartialWidths <> nil then
|
||||||
|
begin
|
||||||
|
Accumulator:=0;
|
||||||
|
for i:= 0 to Count - 1 do
|
||||||
|
begin
|
||||||
|
Inc(Accumulator,gdk_char_width(UseFont,(Str+i)^));
|
||||||
|
PartialWidths[i]:=Accumulator;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function InvertRect(DC: HDC; const lprc: TRect): Boolean;
|
||||||
|
var
|
||||||
|
DCOrigin: TPoint;
|
||||||
|
Values: TGdkGCValues;
|
||||||
|
begin
|
||||||
|
//todo: see the windows result when rect is invalid
|
||||||
|
Result := GTKWidgetSet.IsValidDC(DC) and (lprc.Bottom > lprc.Top)
|
||||||
|
and (lprc.Right > lprc.Left);
|
||||||
|
if Result then
|
||||||
|
begin
|
||||||
|
with TGtkDeviceContext(DC) do
|
||||||
|
begin
|
||||||
|
DCOrigin := Offset;
|
||||||
|
//todo: see if is necessary store old function
|
||||||
|
gdk_gc_get_values(GC, @Values);
|
||||||
|
gdk_gc_set_function(GC,GDK_INVERT);
|
||||||
|
gdk_draw_rectangle(Drawable,GC,1,
|
||||||
|
DCOrigin.X + lprc.Left, DCOrigin.Y + lprc.Top,
|
||||||
|
lprc.Right - lprc.Left, lprc.Bottom - lprc.Top);
|
||||||
|
gdk_gc_set_function(GC,Values.thefunction);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function ScrollWindow(hWnd:THandle; XAmount, YAmount:longint;lpRect:PRECT; lpClipRect:PRECT):Boolean;
|
||||||
|
begin
|
||||||
|
//gtk implementation does nothing if lpRect and lpClipRect are not nil
|
||||||
|
Result := LCLIntf.ScrollWindowEx(hWnd, XAmount, YAmount, nil, nil, 0, nil, SW_INVALIDATE);
|
||||||
|
end;
|
||||||
|
|
||||||
|
var
|
||||||
|
CachedUnicodeFormat: TClipboardFormat;
|
||||||
|
|
||||||
|
function CF_UNICODETEXT: TClipboardFormat;
|
||||||
|
begin
|
||||||
|
//todo: see what mime type gtk expects for utf16
|
||||||
|
if CachedUnicodeFormat = 0 then
|
||||||
|
CachedUnicodeFormat:= gdk_atom_intern('text/utf16',GdkFalse);
|
||||||
|
Result := CachedUnicodeFormat;
|
||||||
|
end;
|
||||||
|
|
||||||
|
type
|
||||||
|
TTimerRecord = record
|
||||||
|
Control: TControl;
|
||||||
|
Notify: TTimerNotify;
|
||||||
|
Id: LongWord;
|
||||||
|
TimerHandle: guint;
|
||||||
|
end;
|
||||||
|
PTimerRecord = ^TTimerRecord;
|
||||||
|
|
||||||
|
{ TTimerList }
|
||||||
|
|
||||||
|
TTimerList = class
|
||||||
|
private
|
||||||
|
FList: TMap;
|
||||||
|
public
|
||||||
|
constructor Create;
|
||||||
|
destructor Destroy; override;
|
||||||
|
function Add(hWnd: THandle; ID: LongWord; NotifyFunc: TTimerNotify; WinControl: TControl):PTimerRecord;
|
||||||
|
function GetTimerInfo(Handle: hWnd; idEvent:LongWord; out TimerInfo: TTimerRecord):Boolean;
|
||||||
|
function GetTimerInfoPtr(Handle: hWnd; idEvent:LongWord): PTimerRecord;
|
||||||
|
end;
|
||||||
|
|
||||||
|
var
|
||||||
|
FTimerList: TTimerList;
|
||||||
|
|
||||||
|
function MakeQWord(d1, d2: dword): QWord; inline;
|
||||||
|
begin
|
||||||
|
Result:=(QWord(d2) shl 32) or d1;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TTimerList }
|
||||||
|
|
||||||
|
constructor TTimerList.Create;
|
||||||
|
begin
|
||||||
|
//todo: see 64bit (itu16??)
|
||||||
|
FList:=TMap.Create(itu8,SizeOf(TTimerRecord));
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TTimerList.Destroy;
|
||||||
|
begin
|
||||||
|
FList.Destroy;
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TTimerList.Add(hWnd: THandle; ID: LongWord; NotifyFunc: TTimerNotify; WinControl: TControl):PTimerRecord;
|
||||||
|
var
|
||||||
|
AID: QWord;
|
||||||
|
ATimerRec: TTimerRecord;
|
||||||
|
begin
|
||||||
|
ATimerRec.Notify := NotifyFunc;
|
||||||
|
ATimerRec.Control := WinControl;
|
||||||
|
ATimerRec.Id := ID;
|
||||||
|
AId:=MakeQWord(hWnd,ID);
|
||||||
|
with FList do
|
||||||
|
begin
|
||||||
|
if HasId(AID) then
|
||||||
|
SetData(AID, ATimerRec)
|
||||||
|
else
|
||||||
|
Add(AID, ATimerRec);
|
||||||
|
Result := GetDataPtr(AID);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TTimerList.GetTimerInfo(Handle: hWnd; idEvent: LongWord; out
|
||||||
|
TimerInfo: TTimerRecord): Boolean;
|
||||||
|
begin
|
||||||
|
Result:= FList.GetData(MakeQWord(Handle,idEvent),TimerInfo);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TTimerList.GetTimerInfoPtr(Handle: hWnd; idEvent: LongWord
|
||||||
|
): PTimerRecord;
|
||||||
|
begin
|
||||||
|
Result := FList.GetDataPtr(MakeQWord(Handle,idEvent));
|
||||||
|
end;
|
||||||
|
|
||||||
|
function gtkTimerCB(Data: gPointer): {$IFDEF Gtk2}gBoolean{$ELSE}gint{$ENDIF}; cdecl;
|
||||||
|
begin
|
||||||
|
Result := GdkFalse; // assume: timer will stop
|
||||||
|
with PTimerRecord(Data)^ do
|
||||||
|
begin
|
||||||
|
//DebugLn('gtkTimerCalled for TimerHandle: %d',[TimerHandle]);
|
||||||
|
if TimerHandle <> 0 then
|
||||||
|
begin
|
||||||
|
if Notify <> nil then
|
||||||
|
begin
|
||||||
|
Notify(Id);
|
||||||
|
Result := GdkTrue;
|
||||||
|
end
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
if Control <> nil then
|
||||||
|
begin
|
||||||
|
LCLSendTimerMsg(Control,Id,0);
|
||||||
|
Result := GdkTrue;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function SetTimer(hWnd:THandle; nIDEvent:LongWord; uElapse:LongWord; lpTimerFunc:TTimerNotify):LongWord;
|
||||||
|
var
|
||||||
|
TimerInfo: PTimerRecord;
|
||||||
|
Control: TControl;
|
||||||
|
begin
|
||||||
|
//todo: properly set Result
|
||||||
|
//todo: make a custom GetLCLObject
|
||||||
|
if hWnd <> 0 then
|
||||||
|
Control := TControl(GetLCLObject(PGtkWidget(hWnd)))
|
||||||
|
else
|
||||||
|
Control := nil;
|
||||||
|
TimerInfo := FTimerList.Add(hWnd, nIDEvent, lpTimerFunc, Control);
|
||||||
|
TimerInfo^.TimerHandle := gtk_timeout_add(uElapse, @gtkTimerCB, TimerInfo);
|
||||||
|
//DebugLn('SetTimer HWnd: %d ID: %d TimerHandle: %d',[hWnd,nIDEvent,TimerInfo^.TimerHandle]);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function KillTimer(hWnd:THandle; nIDEvent: LongWord):Boolean;
|
||||||
|
var
|
||||||
|
TimerInfo: PTimerRecord;
|
||||||
|
begin
|
||||||
|
TimerInfo := FTimerList.GetTimerInfoPtr(hWnd,nIDEvent);
|
||||||
|
if TimerInfo <> nil then
|
||||||
|
begin
|
||||||
|
//DebugLn('KillTimer HWnd: %d ID: %d TimerHandle: %d',[hWnd,nIDEvent,TimerInfo^.TimerHandle]);
|
||||||
|
gtk_timeout_remove(TimerInfo^.TimerHandle);
|
||||||
|
//next time gtkTimerCB be called the timeout will be destroied automatically
|
||||||
|
//todo: see if is really necessary to set TimerHandle to 0 and check in gtkTimerCB
|
||||||
|
TimerInfo^.TimerHandle := 0;
|
||||||
|
end;
|
||||||
|
//else
|
||||||
|
// DebugLn('KillTimer Could not find the timer info of HWnd: %d ID: %d',[hWnd,nIDEvent]);
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
24
components/lclextensions/include/gtk/lclext.inc
Executable file
24
components/lclextensions/include/gtk/lclext.inc
Executable file
@ -0,0 +1,24 @@
|
|||||||
|
|
||||||
|
|
||||||
|
function CreateBitmapMask(BitmapDC: HDC; Width, Height: Integer; TransparentColor: TColor): HBITMAP;
|
||||||
|
begin
|
||||||
|
//todo
|
||||||
|
Result := 0;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function DirectMaskBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc: Integer; Mask: HBITMAP): Boolean;
|
||||||
|
begin
|
||||||
|
//todo: see if is possible todo it faster
|
||||||
|
Result := GTKWidgetSet.StretchCopyArea(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, Width, Height,
|
||||||
|
Mask, XSrc, YSrc, SRCCOPY);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function OptimalPixelFormat: TPixelFormat;
|
||||||
|
begin
|
||||||
|
Result := pfDevice;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function OSSupportsUTF16: Boolean;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
end;
|
||||||
3
components/lclextensions/include/gtk/uses.inc
Executable file
3
components/lclextensions/include/gtk/uses.inc
Executable file
@ -0,0 +1,3 @@
|
|||||||
|
|
||||||
|
LCLIntf, Graphics, gtkdef, gdk, GTKProc, GtkInt, glib, gtk, Math,
|
||||||
|
|
||||||
2
components/lclextensions/include/gtk/uses_lclext.inc
Executable file
2
components/lclextensions/include/gtk/uses_lclext.inc
Executable file
@ -0,0 +1,2 @@
|
|||||||
|
uses
|
||||||
|
GtkInt;
|
||||||
394
components/lclextensions/include/gtk2/delphicompat.inc
Executable file
394
components/lclextensions/include/gtk2/delphicompat.inc
Executable file
@ -0,0 +1,394 @@
|
|||||||
|
{ This file is part of Delphi Compatibility Unit
|
||||||
|
|
||||||
|
Copyright (C) 2007 Luiz Américo Pereira Câmara
|
||||||
|
pascalive@bol.com.br
|
||||||
|
|
||||||
|
This library is free software; you can redistribute it and/or modify it
|
||||||
|
under the terms of the GNU Library General Public License as published by
|
||||||
|
the Free Software Foundation; either version 2 of the License, or (at your
|
||||||
|
option) any later version with the following modification:
|
||||||
|
|
||||||
|
As a special exception, the copyright holders of this library give you
|
||||||
|
permission to link this library with independent modules to produce an
|
||||||
|
executable, regardless of the license terms of these independent modules,and
|
||||||
|
to copy and distribute the resulting executable under terms of your choice,
|
||||||
|
provided that you also meet, for each linked independent module, the terms
|
||||||
|
and conditions of the license of that module. An independent module is a
|
||||||
|
module which is not derived from or based on this library. If you modify
|
||||||
|
this library, you may extend this exception to your version of the library,
|
||||||
|
but you are not obligated to do so. If you do not wish to do so, delete this
|
||||||
|
exception statement from your version.
|
||||||
|
|
||||||
|
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. See the GNU Library General Public License
|
||||||
|
for more details.
|
||||||
|
|
||||||
|
You should have received a copy of the GNU Library General Public License
|
||||||
|
along with this library; if not, write to the Free Software Foundation,
|
||||||
|
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
|
{$MACRO ON}
|
||||||
|
{$if lcl_fullversion > 1000000}
|
||||||
|
{$define TGtk2DeviceContext:=TGtkDeviceContext}
|
||||||
|
{$endif}
|
||||||
|
|
||||||
|
{$define HAS_INVERTRECT}
|
||||||
|
{$define HAS_DRAWTEXTW}
|
||||||
|
{$define HAS_GETCURRENTOBJECT}
|
||||||
|
{$define HAS_GETBKCOLOR}
|
||||||
|
{$define HAS_GETTEXTEXTENTEXPOINT}
|
||||||
|
{$define HAS_SCROLLWINDOW}
|
||||||
|
|
||||||
|
{$i ../generic/stubs.inc}
|
||||||
|
{$i ../generic/independentfunctions.inc}
|
||||||
|
{$i ../generic/unicodefunctions.inc}
|
||||||
|
|
||||||
|
|
||||||
|
procedure pango_extents_to_pixels (ink_rect: PPangoRectangle;
|
||||||
|
logical_rect: PPangoRectangle); cdecl; external 'libpango-1.0.so.0';
|
||||||
|
|
||||||
|
function BitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc,
|
||||||
|
YSrc: Integer; Rop: DWORD): Boolean;
|
||||||
|
begin
|
||||||
|
Result := GTK2WidgetSet.StretchCopyArea(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, Width, Height,
|
||||||
|
0, XSrc, YSrc, Rop);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function DrawTextW(hDC: HDC; lpString: PWideChar; nCount: Integer; var lpRect: TRect; uFormat: LongWord): Integer;
|
||||||
|
var
|
||||||
|
TempStr: UTF8String;
|
||||||
|
TempRect: TRect;
|
||||||
|
TextHeight: Integer;
|
||||||
|
TM: TTextMetric;
|
||||||
|
begin
|
||||||
|
//Logger.Send('DrawTextW');
|
||||||
|
TempRect := lpRect;
|
||||||
|
//fix position under gtk (lcl bug 8565)
|
||||||
|
if (uFormat and DT_VCENTER) > 0 then
|
||||||
|
begin
|
||||||
|
GetTextMetrics(hDC, TM);
|
||||||
|
//gtk overestimate height
|
||||||
|
TextHeight := TM.tmHeight - 2;
|
||||||
|
TempRect.Top := (TempRect.Top + TempRect.Bottom - TextHeight) div 2;
|
||||||
|
end;
|
||||||
|
TempStr := UTF8Encode(WideString(lpString));
|
||||||
|
Result := DrawText(hDC, PChar(TempStr), GetUTF8ByteCount(TempStr, nCount),
|
||||||
|
TempRect, uFormat);
|
||||||
|
//Logger.Send('Rect',TempRect);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetBkColor(DC:HDC):COLORREF;
|
||||||
|
begin
|
||||||
|
if GTK2WidgetSet.IsValidDC(DC) then
|
||||||
|
Result := TGtkDeviceContext(DC).CurrentBackColor.ColorRef
|
||||||
|
else
|
||||||
|
Result := CLR_INVALID;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetCurrentObject(hdc: HDC; uObjectType: UINT): HGDIOBJ;
|
||||||
|
begin
|
||||||
|
Result := 0;
|
||||||
|
if GTK2WidgetSet.IsValidDC(hdc) then
|
||||||
|
with TGtk2DeviceContext(hdc) do
|
||||||
|
begin
|
||||||
|
case uObjectType of
|
||||||
|
OBJ_BITMAP: Result := HGDIOBJ(CurrentBitmap);
|
||||||
|
OBJ_BRUSH: Result := HGDIOBJ(CurrentBrush);
|
||||||
|
OBJ_FONT: Result := HGDIOBJ(CurrentFont);
|
||||||
|
OBJ_PEN: Result := HGDIOBJ(CurrentPen);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetTextExtentExPoint(DC: HDC; Str: PChar;
|
||||||
|
Count, MaxWidth: Integer; MaxCount, PartialWidths: PInteger;
|
||||||
|
var Size: TSize): BOOL;
|
||||||
|
var
|
||||||
|
layout: PPangoLayout;
|
||||||
|
i: Integer;
|
||||||
|
Rect: TPangoRectangle;
|
||||||
|
iter : PPangoLayoutIter;
|
||||||
|
begin
|
||||||
|
Result := GTK2WidgetSet.IsValidDC(DC);
|
||||||
|
if Result then
|
||||||
|
with TGtk2DeviceContext(DC) do
|
||||||
|
begin
|
||||||
|
if (CurrentFont = nil) or (CurrentFont^.GDIFontObject = nil) then
|
||||||
|
layout := GTK2WidgetSet.GetDefaultGtkFont(false)
|
||||||
|
else
|
||||||
|
layout := CurrentFont^.GDIFontObject;
|
||||||
|
pango_layout_set_text(layout, Str, Count);
|
||||||
|
if PartialWidths = nil then
|
||||||
|
pango_layout_get_pixel_size (layout, @Size.cx, @Size.cy)
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
i := 0;
|
||||||
|
Size.cx := 0;
|
||||||
|
Size.cy := 0;
|
||||||
|
iter := pango_layout_get_iter(layout);
|
||||||
|
repeat
|
||||||
|
pango_layout_iter_get_char_extents(iter,@Rect);
|
||||||
|
pango_extents_to_pixels(nil,@Rect);
|
||||||
|
inc(Size.cx, Rect.Width);
|
||||||
|
PartialWidths[i] := Size.cx;
|
||||||
|
if Size.cy < Rect.Height then
|
||||||
|
Size.cy := Rect.Height;
|
||||||
|
inc(i);
|
||||||
|
until not pango_layout_iter_next_char(iter);
|
||||||
|
pango_layout_iter_free(iter);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function InvertRect(DC: HDC; const lprc: TRect): Boolean;
|
||||||
|
var
|
||||||
|
DCOrigin: TPoint;
|
||||||
|
Values: TGdkGCValues;
|
||||||
|
begin
|
||||||
|
//todo: see the windows result when rect is invalid
|
||||||
|
Result := GTK2WidgetSet.IsValidDC(DC) and (lprc.Bottom > lprc.Top)
|
||||||
|
and (lprc.Right > lprc.Left);
|
||||||
|
if Result then
|
||||||
|
begin
|
||||||
|
with TGtk2DeviceContext(DC) do
|
||||||
|
begin
|
||||||
|
DCOrigin := Offset;
|
||||||
|
//todo: see if is necessary store old function
|
||||||
|
gdk_gc_get_values(GC, @Values);
|
||||||
|
gdk_gc_set_function(GC,GDK_INVERT);
|
||||||
|
gdk_draw_rectangle(Drawable,GC,1,
|
||||||
|
DCOrigin.X + lprc.Left, DCOrigin.Y + lprc.Top,
|
||||||
|
lprc.Right - lprc.Left, lprc.Bottom - lprc.Top);
|
||||||
|
gdk_gc_set_function(GC,Values._function);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function ScrollWindow(hWnd:THandle; XAmount, YAmount:longint;lpRect:PRECT; lpClipRect:PRECT):Boolean;
|
||||||
|
begin
|
||||||
|
//gtk implementation does nothing if lpRect and lpClipRect are not nil
|
||||||
|
Result := LCLIntf.ScrollWindowEx(hWnd, XAmount, YAmount, nil, nil, 0, nil, SW_INVALIDATE);
|
||||||
|
end;
|
||||||
|
|
||||||
|
var
|
||||||
|
CachedUnicodeFormat: TClipboardFormat;
|
||||||
|
|
||||||
|
function CF_UNICODETEXT: TClipboardFormat;
|
||||||
|
begin
|
||||||
|
//todo: see what mime type gtk expects for utf16
|
||||||
|
if CachedUnicodeFormat = 0 then
|
||||||
|
CachedUnicodeFormat:= gdk_atom_intern('text/utf16',GdkFalse);
|
||||||
|
Result := CachedUnicodeFormat;
|
||||||
|
end;
|
||||||
|
|
||||||
|
type
|
||||||
|
|
||||||
|
TTimerID = record
|
||||||
|
hWnd: THandle;
|
||||||
|
nIDEvent: UINT_PTR;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TGtk2Timer }
|
||||||
|
|
||||||
|
TGtk2Timer = class
|
||||||
|
private
|
||||||
|
FControl: TControl;
|
||||||
|
FNotify: TTimerNotify;
|
||||||
|
FId: UINT_PTR;
|
||||||
|
FHandle: THandle;
|
||||||
|
FTimerHandle: guint;
|
||||||
|
public
|
||||||
|
constructor Create(hWnd: THandle; nIDEvent: UINT_PTR; NotifyFunc: TTimerNotify);
|
||||||
|
procedure Start(Interval: LongWord);
|
||||||
|
procedure Stop;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TTimerList }
|
||||||
|
|
||||||
|
TTimerList = class
|
||||||
|
private
|
||||||
|
FMap: TMap;
|
||||||
|
public
|
||||||
|
constructor Create;
|
||||||
|
destructor Destroy; override;
|
||||||
|
procedure Delete(hWnd: THandle; nIDEvent: UINT_PTR);
|
||||||
|
function Find(hWnd: THandle; nIDEvent: UINT_PTR): TGtk2Timer;
|
||||||
|
function Get(hWnd: THandle; nIDEvent: UINT_PTR; NotifyFunc: TTimerNotify): TGtk2Timer;
|
||||||
|
end;
|
||||||
|
|
||||||
|
var
|
||||||
|
FTimerList: TTimerList;
|
||||||
|
|
||||||
|
function gtkWidgetDestroyCB(Widget: PGtkWidget; Timer: TGtk2Timer): GBoolean; cdecl;
|
||||||
|
begin
|
||||||
|
Result := GdkFalse;
|
||||||
|
Timer.Stop;
|
||||||
|
FTimerList.Delete(Timer.FHandle, Timer.FId);
|
||||||
|
Timer.Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function gtkTimerCB(Timer: TGtk2Timer): gBoolean; cdecl;
|
||||||
|
begin
|
||||||
|
Result := GdkFalse; // assume: timer will stop
|
||||||
|
//DebugLn('gtkTimerCalled for TimerHandle: %d',[TimerHandle]);
|
||||||
|
if Timer.FNotify <> nil then
|
||||||
|
begin
|
||||||
|
Timer.FNotify(Timer.FId);
|
||||||
|
Result := GdkTrue;
|
||||||
|
end
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
if Timer.FControl <> nil then
|
||||||
|
begin
|
||||||
|
LCLSendTimerMsg(Timer.FControl, Timer.FId, 0);
|
||||||
|
Result := GdkTrue;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TGtk2TimerInfo }
|
||||||
|
|
||||||
|
constructor TGtk2Timer.Create(hWnd: THandle; nIDEvent: UINT_PTR;
|
||||||
|
NotifyFunc: TTimerNotify);
|
||||||
|
begin
|
||||||
|
//todo: make a custom GetLCLObject
|
||||||
|
if hWnd <> 0 then
|
||||||
|
begin
|
||||||
|
FControl := TControl(GetLCLObject(PGtkWidget(hWnd)));
|
||||||
|
g_signal_connect(PGObject(hWnd), 'destroy', gtk_Signal_Func(@gtkWidgetDestroyCB), Self);
|
||||||
|
end
|
||||||
|
else
|
||||||
|
FControl := nil;
|
||||||
|
FHandle := hWnd;
|
||||||
|
FId := nIDEvent;
|
||||||
|
FNotify := NotifyFunc;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TGtk2Timer.Start(Interval: LongWord);
|
||||||
|
begin
|
||||||
|
//restart
|
||||||
|
if FTimerHandle <> 0 then
|
||||||
|
g_source_remove(FTimerHandle);
|
||||||
|
FTimerHandle := g_timeout_add(Interval, TGSourceFunc(@gtkTimerCB), Self);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TGtk2Timer.Stop;
|
||||||
|
begin
|
||||||
|
if FTimerHandle <> 0 then
|
||||||
|
begin
|
||||||
|
g_source_remove(FTimerHandle);
|
||||||
|
FTimerHandle := 0;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TTimerList }
|
||||||
|
|
||||||
|
constructor TTimerList.Create;
|
||||||
|
begin
|
||||||
|
FMap := TMap.Create({$ifdef CPU64}itu16{$else}itu8{$endif}, SizeOf(TGtk2Timer));
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TTimerList.Destroy;
|
||||||
|
var
|
||||||
|
Iterator: TMapIterator;
|
||||||
|
TimerInfo: TGtk2Timer;
|
||||||
|
begin
|
||||||
|
Iterator := TMapIterator.Create(FMap);
|
||||||
|
with Iterator do
|
||||||
|
begin
|
||||||
|
while not EOM do
|
||||||
|
begin
|
||||||
|
GetData(TimerInfo);
|
||||||
|
TimerInfo.Free;
|
||||||
|
Next;
|
||||||
|
end;
|
||||||
|
Destroy;
|
||||||
|
end;
|
||||||
|
FMap.Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TTimerList.Delete(hWnd: THandle; nIDEvent: UINT_PTR);
|
||||||
|
var
|
||||||
|
TimerID: TTimerID;
|
||||||
|
begin
|
||||||
|
TimerID.hWnd := hWnd;
|
||||||
|
TimerID.nIDEvent := nIDEvent;
|
||||||
|
FMap.Delete(TimerID);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TTimerList.Get(hWnd: THandle; nIDEvent: UINT_PTR; NotifyFunc: TTimerNotify): TGtk2Timer;
|
||||||
|
var
|
||||||
|
TimerID: TTimerID;
|
||||||
|
begin
|
||||||
|
TimerID.hWnd := hWnd;
|
||||||
|
TimerID.nIDEvent := nIDEvent;
|
||||||
|
with FMap do
|
||||||
|
begin
|
||||||
|
if HasId(TimerID) then
|
||||||
|
begin
|
||||||
|
// DebugLn('Reset timer for HWnd: %d ID: %d AID: %d', [hWnd, ID, TimerID]);
|
||||||
|
GetData(TimerID, Result);
|
||||||
|
Result.FNotify := NotifyFunc;
|
||||||
|
end
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
// DebugLn('Create timer for HWnd: %d ID: %d AID: %d', [hWnd, ID, TimerID]);
|
||||||
|
Result := TGtk2Timer.Create(hWnd, nIDEvent, NotifyFunc);
|
||||||
|
if hWnd = 0 then
|
||||||
|
begin
|
||||||
|
TimerID.nIDEvent := PtrUInt(Result);
|
||||||
|
Result.FId := PtrUInt(Result);
|
||||||
|
end;
|
||||||
|
Add(TimerID, Result);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TTimerList.Find(hWnd: THandle; nIDEvent: UINT_PTR): TGtk2Timer;
|
||||||
|
var
|
||||||
|
DataPtr: ^TGtk2Timer;
|
||||||
|
TimerID: TTimerID;
|
||||||
|
begin
|
||||||
|
Result := nil;
|
||||||
|
TimerID.hWnd := hWnd;
|
||||||
|
TimerID.nIDEvent := nIDEvent;
|
||||||
|
// DebugLn('GetTimerInfo for HWnd: %d ID: %d AID: %d', [hWnd, ID, TimerID]);
|
||||||
|
DataPtr := FMap.GetDataPtr(TimerID);
|
||||||
|
if DataPtr <> nil then
|
||||||
|
Result := DataPtr^;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function SetTimer(hWnd: THandle; nIDEvent: UINT_PTR; uElapse: LongWord; lpTimerFunc: TTimerNotify): UINT_PTR;
|
||||||
|
var
|
||||||
|
Timer: TGtk2Timer;
|
||||||
|
begin
|
||||||
|
Timer := FTimerList.Get(hWnd, nIDEvent, lpTimerFunc);
|
||||||
|
try
|
||||||
|
Timer.Start(uElapse);
|
||||||
|
if hWnd = 0 then
|
||||||
|
Result := PtrUInt(Timer)
|
||||||
|
else
|
||||||
|
Result := nIdEvent;
|
||||||
|
except
|
||||||
|
Result := 0;
|
||||||
|
end;
|
||||||
|
//DebugLn('SetTimer HWnd: %d ID: %d TimerHandle: %d',[hWnd,nIDEvent,Timer.FTimerHandle]);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function KillTimer(hWnd:THandle; nIDEvent: UINT_PTR): Boolean;
|
||||||
|
var
|
||||||
|
Timer: TGtk2Timer;
|
||||||
|
begin
|
||||||
|
//todo: investigate how to set result
|
||||||
|
Result := True;
|
||||||
|
Timer := FTimerList.Find(hWnd, nIDEvent);
|
||||||
|
//DebugLn('KillTimer HWnd: %d ID: %d TimerHandle: %d',[hWnd,nIDEvent,Timer^.TimerHandle]);
|
||||||
|
if Timer <> nil then
|
||||||
|
Timer.Stop;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
22
components/lclextensions/include/gtk2/lclext.inc
Executable file
22
components/lclextensions/include/gtk2/lclext.inc
Executable file
@ -0,0 +1,22 @@
|
|||||||
|
function CreateBitmapMask(BitmapDC: HDC; Width, Height: Integer; TransparentColor: TColor): HBITMAP;
|
||||||
|
begin
|
||||||
|
//todo
|
||||||
|
Result := 0;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function DirectMaskBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc: Integer; Mask: HBITMAP): Boolean;
|
||||||
|
begin
|
||||||
|
//todo: see if is possible todo it faster
|
||||||
|
Result := GTK2WidgetSet.StretchCopyArea(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, Width, Height,
|
||||||
|
Mask, XSrc, YSrc, SRCCOPY);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function OptimalPixelFormat: TPixelFormat;
|
||||||
|
begin
|
||||||
|
Result := pfDevice;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function OSSupportsUTF16: Boolean;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
end;
|
||||||
2
components/lclextensions/include/gtk2/uses.inc
Executable file
2
components/lclextensions/include/gtk2/uses.inc
Executable file
@ -0,0 +1,2 @@
|
|||||||
|
|
||||||
|
LCLIntf, Graphics, Gtk2Def, gdk2, gtk2, Gtk2Proc, Gtk2Int, pango, glib2, math,
|
||||||
2
components/lclextensions/include/gtk2/uses_lclext.inc
Executable file
2
components/lclextensions/include/gtk2/uses_lclext.inc
Executable file
@ -0,0 +1,2 @@
|
|||||||
|
uses
|
||||||
|
Gtk2Int;
|
||||||
404
components/lclextensions/include/qt/delphicompat.inc
Executable file
404
components/lclextensions/include/qt/delphicompat.inc
Executable file
@ -0,0 +1,404 @@
|
|||||||
|
|
||||||
|
{
|
||||||
|
Qt Interface
|
||||||
|
|
||||||
|
Initial implementation by Zeljan Rikalo
|
||||||
|
|
||||||
|
SetTimer/KillTimer implementation by Luiz Americo
|
||||||
|
}
|
||||||
|
|
||||||
|
function CF_UNICODETEXT: TClipboardFormat;
|
||||||
|
begin
|
||||||
|
//todo
|
||||||
|
Result := TClipboardFormat(0);
|
||||||
|
end;
|
||||||
|
|
||||||
|
{$define HAS_GETBKCOLOR}
|
||||||
|
{$define HAS_GETCURRENTOBJECT}
|
||||||
|
{$define HAS_INVERTRECT}
|
||||||
|
{$define HAS_GETTEXTEXTENTEXPOINT}
|
||||||
|
{$define HAS_GETDOUBLECLICKTIME}
|
||||||
|
{$define HAS_GETTEXTALIGN}
|
||||||
|
{$define HAS_GETWINDOWDC}
|
||||||
|
{$define HAS_OFFSETRGN}
|
||||||
|
{$define HAS_REDRAWWINDOW}
|
||||||
|
{$define HAS_SCROLLWINDOW}
|
||||||
|
{$define HAS_SETBRUSHORGEX}
|
||||||
|
|
||||||
|
|
||||||
|
{$i ../generic/stubs.inc}
|
||||||
|
{$i ../generic/independentfunctions.inc}
|
||||||
|
{$i ../generic/unicodefunctions.inc}
|
||||||
|
|
||||||
|
function GetBkColor(DC:HDC):COLORREF;
|
||||||
|
var
|
||||||
|
Color: PQColor;
|
||||||
|
begin
|
||||||
|
if QtWidgetSet.IsValidDC(DC) then
|
||||||
|
begin
|
||||||
|
Color := TQtDeviceContext(DC).BackgroundBrush.getColor;
|
||||||
|
TQColorToColorRef(Color^, Result);
|
||||||
|
end else
|
||||||
|
Result := CLR_INVALID;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function 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 GetCurrentObject(hdc: HDC; uObjectType: UINT): HGDIOBJ;
|
||||||
|
begin
|
||||||
|
Result := 0;
|
||||||
|
if QtWidgetSet.IsValidDC(hdc) then
|
||||||
|
with TQtDeviceContext(hdc) do
|
||||||
|
begin {TODO: FIXME}
|
||||||
|
case uObjectType of
|
||||||
|
OBJ_BITMAP: Result := HGDIOBJ(vImage);
|
||||||
|
OBJ_BRUSH: Result := HGDIOBJ(vBrush);
|
||||||
|
OBJ_FONT: Result := HGDIOBJ(vFont);
|
||||||
|
OBJ_PEN: Result := HGDIOBJ(vPen);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetDoubleClickTime: UINT;
|
||||||
|
begin
|
||||||
|
Result := QApplication_doubleClickInterval;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetTextExtentExPoint(DC: HDC; Str: PChar;
|
||||||
|
Count, MaxWidth: Integer; MaxCount, PartialWidths: PInteger;
|
||||||
|
var Size: TSize): BOOL;
|
||||||
|
begin
|
||||||
|
Result := QtWidgetSet.GetTextExtentExPoint(DC, Str, Count, MaxWidth, MaxCount, PartialWidths, Size);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetTextAlign(hDC:HDC): LongWord;
|
||||||
|
var
|
||||||
|
QtDC: TQtDeviceContext;
|
||||||
|
QtFontMetrics: QFontMetricsH;
|
||||||
|
QtFont: QFontH;
|
||||||
|
begin
|
||||||
|
Result := 0;
|
||||||
|
if not QtWidgetSet.IsValidDC(hdC) then
|
||||||
|
Exit;
|
||||||
|
QtDC := TQtDeviceContext(hDC);
|
||||||
|
QtFont := QtDC.vFont.FHandle;
|
||||||
|
QtFontMetrics := QFontMetrics_create(QtFont);
|
||||||
|
try
|
||||||
|
{TODO: FIXME we should save somehow text flags into QtDC
|
||||||
|
cause we don't have any function which returns current flags !}
|
||||||
|
finally
|
||||||
|
QFontMetrics_destroy(QtFontMetrics);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetWindowDC(hWnd:THandle): HDC;
|
||||||
|
begin
|
||||||
|
Result := LCLIntf.GetDC(hWnd);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function InvertRect(DC: HDC; const lprc: TRect): Boolean;
|
||||||
|
var
|
||||||
|
DCOrigin: TQtPoint;
|
||||||
|
begin
|
||||||
|
//todo: see the windows result when rect is invalid
|
||||||
|
Result := QtWidgetSet.IsValidDC(DC) and (lprc.Bottom > lprc.Top)
|
||||||
|
and (lprc.Right > lprc.Left);
|
||||||
|
if Result then
|
||||||
|
begin
|
||||||
|
with lprc do
|
||||||
|
Result := BitBlt(DC, Left, Top, Right - Left, Bottom-Top,
|
||||||
|
DC, Left, Top, LongWord(QPainterCompositionMode_DestinationOver));
|
||||||
|
{TODO: FIXME !}
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function OffsetRgn(hrgn:HRGN; nxOffset, nYOffset:longint):longint;
|
||||||
|
var
|
||||||
|
Region: TQtRegion;
|
||||||
|
begin
|
||||||
|
Region := TQtRegion(hrgn);
|
||||||
|
QRegion_translate(Region.FHandle, nxOffset, nYOffset);
|
||||||
|
Result := Region.GetRegionType;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function RedrawWindow(hWnd:THandle; lprcUpdate:PRECT; hrgnUpdate:HRGN; flags:LongWord):BOOLEAN;
|
||||||
|
begin
|
||||||
|
Result := QtWidgetSet.RedrawWindow(hWnd, lprcUpdate, hrgnUpdate, flags);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function ScrollWindow(hWnd:THandle; XAmount, YAmount:longint;lpRect:PRECT; lpClipRect:PRECT): Boolean;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
if hWnd = 0 then
|
||||||
|
Exit;
|
||||||
|
QWidget_scroll(TQtWidget(hWnd).Widget, XAmount, YAmount, lpRect);
|
||||||
|
Result := True;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function SetBrushOrgEx(DC:HDC; nXOrg, nYOrg:longint; lppt:PPOINT):Boolean;
|
||||||
|
var
|
||||||
|
QtDC: TQtDeviceContext;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
if not QtWidgetSet.IsValidDC(DC) then
|
||||||
|
Exit;
|
||||||
|
QtDC := TQtDeviceContext(DC);
|
||||||
|
if lppt <> nil then
|
||||||
|
QtDC.getBrushOrigin(lppt);
|
||||||
|
QtDC.setBrushOrigin(nXorg, nYOrg);
|
||||||
|
Result := True;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
type
|
||||||
|
|
||||||
|
TTimerID = record
|
||||||
|
hWnd: THandle;
|
||||||
|
nIDEvent: UINT_PTR;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TQtTimerEx }
|
||||||
|
|
||||||
|
TQtTimerEx = class(TQtObject)
|
||||||
|
private
|
||||||
|
FTimerHook: QTimer_hookH;
|
||||||
|
FWidgetHook: QObject_hookH;
|
||||||
|
FCallbackFunc: TTimerNotify;
|
||||||
|
FID: UINT_PTR;
|
||||||
|
FHandle: THandle;
|
||||||
|
FControl: TWinControl;
|
||||||
|
public
|
||||||
|
constructor Create(hWnd: THandle; nIDEvent: UINT_PTR; TimerFunc: TTimerNotify);
|
||||||
|
destructor Destroy; override;
|
||||||
|
procedure AttachEvents; override;
|
||||||
|
procedure DetachEvents; override;
|
||||||
|
procedure signalWidgetDestroyed; cdecl;
|
||||||
|
procedure signalTimeout; cdecl;
|
||||||
|
public
|
||||||
|
function EventFilter(Sender: QObjectH; Event: QEventH): Boolean; cdecl; override;
|
||||||
|
procedure Start(Interval: Integer);
|
||||||
|
procedure Stop;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
{ TTimerList }
|
||||||
|
|
||||||
|
TTimerList = class
|
||||||
|
private
|
||||||
|
FMap: TMap;
|
||||||
|
public
|
||||||
|
constructor Create;
|
||||||
|
destructor Destroy; override;
|
||||||
|
procedure Delete(hWnd: THandle; nIDEvent: UINT_PTR);
|
||||||
|
function Find(hWnd: THandle; nIDEvent: UINT_PTR): TQtTimerEx;
|
||||||
|
function Get(hWnd: THandle; nIDEvent: UINT_PTR; NotifyFunc: TTimerNotify): TQtTimerEx;
|
||||||
|
end;
|
||||||
|
|
||||||
|
TQtWidgetSetHack = Class(TWidgetSet)
|
||||||
|
private
|
||||||
|
App: QApplicationH;
|
||||||
|
end;
|
||||||
|
|
||||||
|
var
|
||||||
|
FTimerList: TTimerList;
|
||||||
|
|
||||||
|
{ TQtTimerEx }
|
||||||
|
|
||||||
|
constructor TQtTimerEx.Create(hWnd: THandle; nIDEvent: UINT_PTR; TimerFunc: TTimerNotify);
|
||||||
|
var
|
||||||
|
AName: WideString;
|
||||||
|
begin
|
||||||
|
inherited Create;
|
||||||
|
FDeleteLater := True;
|
||||||
|
FCallbackFunc := TimerFunc;
|
||||||
|
FID := nIDEvent;
|
||||||
|
FControl := FindControl(hWnd);
|
||||||
|
FHandle := hWnd;
|
||||||
|
if hWnd <> 0 then
|
||||||
|
begin
|
||||||
|
FWidgetHook := QObject_hook_create(TQtWidget(hWnd).TheObject);
|
||||||
|
QObject_hook_hook_destroyed(FWidgetHook, @signalWidgetDestroyed);
|
||||||
|
end;
|
||||||
|
//very big ultra extreme hack to get the app from QtWidgetset
|
||||||
|
TheObject := QTimer_create(TQtWidgetSetHack(QtWidgetSet).App);
|
||||||
|
AName := 'tqttimerex';
|
||||||
|
QObject_setObjectName(TheObject, @AName);
|
||||||
|
|
||||||
|
AttachEvents;
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TQtTimerEx.Destroy;
|
||||||
|
begin
|
||||||
|
if FWidgetHook <> nil then
|
||||||
|
QObject_hook_destroy(FWidgetHook);
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TQtTimerEx.AttachEvents;
|
||||||
|
begin
|
||||||
|
FTimerHook := QTimer_hook_create(QTimerH(TheObject));
|
||||||
|
QTimer_hook_hook_timeout(FTimerHook, @signalTimeout);
|
||||||
|
inherited AttachEvents;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TQtTimerEx.DetachEvents;
|
||||||
|
begin
|
||||||
|
QTimer_stop(QTimerH(TheObject));
|
||||||
|
if FTimerHook <> nil then
|
||||||
|
QTimer_hook_destroy(FTimerHook);
|
||||||
|
inherited DetachEvents;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TQtTimerEx.signalWidgetDestroyed; cdecl;
|
||||||
|
begin
|
||||||
|
Stop;
|
||||||
|
FTimerList.Delete(FHandle, FID);
|
||||||
|
Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TQtTimerEx.signalTimeout; cdecl;
|
||||||
|
begin
|
||||||
|
if Assigned(FCallbackFunc) then
|
||||||
|
FCallbackFunc(FID)
|
||||||
|
else if Assigned(FControl) then
|
||||||
|
begin
|
||||||
|
if ([csLoading, csDestroying] * FControl.ComponentState = []) and not
|
||||||
|
(csDestroyingHandle in FControl.ControlState) then
|
||||||
|
begin
|
||||||
|
LCLSendTimerMsg(FControl, FID, 0);
|
||||||
|
end;
|
||||||
|
end
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
//orphan timer. Stop.
|
||||||
|
//todo: better to remove from the list?
|
||||||
|
Stop;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TQtTimerEx.EventFilter(Sender: QObjectH; Event: QEventH): Boolean; cdecl;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
QEvent_accept(Event);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TQtTimerEx.Start(Interval: Integer);
|
||||||
|
begin
|
||||||
|
QTimer_start(QTimerH(TheObject), Interval);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TQtTimerEx.Stop;
|
||||||
|
begin
|
||||||
|
QTimer_stop(QTimerH(TheObject));
|
||||||
|
end;
|
||||||
|
|
||||||
|
function KillTimer(hWnd: THandle; nIDEvent: UINT_PTR): Boolean;
|
||||||
|
var
|
||||||
|
TimerObject: TQtTimerEx;
|
||||||
|
begin
|
||||||
|
Result := True;
|
||||||
|
TimerObject := FTimerList.Find(hWnd, nIDEvent);
|
||||||
|
if TimerObject <> nil then
|
||||||
|
begin
|
||||||
|
// DebugLn('KillTimer HWnd: %d ID: %d TimerObject: %d',[hWnd, nIDEvent, PtrInt(TimerObject)]);
|
||||||
|
TimerObject.Stop;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function SetTimer(hWnd: THandle; nIDEvent: UINT_PTR; uElapse: LongWord; lpTimerFunc: TTimerNotify): UINT_PTR;
|
||||||
|
var
|
||||||
|
TimerObject: TQtTimerEx;
|
||||||
|
begin
|
||||||
|
TimerObject := FTimerList.Get(hWnd, nIDEvent, lpTimerFunc);
|
||||||
|
try
|
||||||
|
TimerObject.Start(uElapse);
|
||||||
|
if hWnd = 0 then
|
||||||
|
Result := PtrInt(TimerObject)
|
||||||
|
else
|
||||||
|
Result := nIdEvent;
|
||||||
|
except
|
||||||
|
Result := 0;
|
||||||
|
end;
|
||||||
|
//DebugLn('SetTimer HWnd: %d ID: %d TimerObject: %d',[hWnd, nIDEvent, PtrInt(TimerObject)]);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TTimerList.Get(hWnd: THandle; nIDEvent: UINT_PTR; NotifyFunc: TTimerNotify): TQtTimerEx;
|
||||||
|
var
|
||||||
|
AID: TTimerID;
|
||||||
|
begin
|
||||||
|
AID.hWnd := hWnd;
|
||||||
|
AID.nIDEvent := nIDEvent;
|
||||||
|
with FMap do
|
||||||
|
begin
|
||||||
|
if HasId(AID) then
|
||||||
|
begin
|
||||||
|
// DebugLn('Reset timer for HWnd: %d ID: %d AID: %d', [hWnd, ID, AID]);
|
||||||
|
GetData(AID, Result);
|
||||||
|
Result.FCallbackFunc := NotifyFunc;
|
||||||
|
end
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
// DebugLn('Create timer for HWnd: %d ID: %d AID: %d', [hWnd, ID, AID]);
|
||||||
|
Result := TQtTimerEx.Create(hWnd, nIDEvent, NotifyFunc);
|
||||||
|
if hWnd = 0 then
|
||||||
|
begin
|
||||||
|
AID.nIDEvent := PtrUInt(Result);
|
||||||
|
Result.FID := PtrUInt(Result);
|
||||||
|
end;
|
||||||
|
Add(AID, Result);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor TTimerList.Create;
|
||||||
|
begin
|
||||||
|
FMap := TMap.Create({$ifdef CPU64}itu16{$else}itu8{$endif}, SizeOf(TQtTimerEx));
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TTimerList.Destroy;
|
||||||
|
var
|
||||||
|
Iterator: TMapIterator;
|
||||||
|
TimerObject: TQtTimerEx;
|
||||||
|
begin
|
||||||
|
Iterator := TMapIterator.Create(FMap);
|
||||||
|
with Iterator do
|
||||||
|
begin
|
||||||
|
while not EOM do
|
||||||
|
begin
|
||||||
|
GetData(TimerObject);
|
||||||
|
TimerObject.Free;
|
||||||
|
Next;
|
||||||
|
end;
|
||||||
|
Destroy;
|
||||||
|
end;
|
||||||
|
FMap.Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TTimerList.Delete(hWnd: THandle; nIDEvent: UINT_PTR);
|
||||||
|
var
|
||||||
|
TimerID: TTimerID;
|
||||||
|
begin
|
||||||
|
TimerID.hWnd := hWnd;
|
||||||
|
TimerID.nIDEvent := nIDEvent;
|
||||||
|
FMap.Delete(TimerID);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TTimerList.Find(hWnd: THandle; nIDEvent: UINT_PTR): TQtTimerEx;
|
||||||
|
var
|
||||||
|
DataPtr: ^TQtTimerEx;
|
||||||
|
TimerID: TTimerID;
|
||||||
|
begin
|
||||||
|
Result := nil;
|
||||||
|
TimerID.hWnd := hWnd;
|
||||||
|
TimerID.nIDEvent := nIDEvent;
|
||||||
|
// DebugLn('GetTimerObject for HWnd: %d ID: %d AID: %d', [hWnd, nIDEvent, TimerID]);
|
||||||
|
DataPtr := FMap.GetDataPtr(TimerID);
|
||||||
|
if DataPtr <> nil then
|
||||||
|
Result := DataPtr^;
|
||||||
|
end;
|
||||||
|
|
||||||
24
components/lclextensions/include/qt/lclext.inc
Executable file
24
components/lclextensions/include/qt/lclext.inc
Executable file
@ -0,0 +1,24 @@
|
|||||||
|
|
||||||
|
|
||||||
|
function CreateBitmapMask(BitmapDC: HDC; Width, Height: Integer; TransparentColor: TColor): HBITMAP;
|
||||||
|
begin
|
||||||
|
//todo
|
||||||
|
Result := 0;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function DirectMaskBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc: Integer; Mask: HBITMAP): Boolean;
|
||||||
|
begin
|
||||||
|
//todo: see if is possible todo it faster
|
||||||
|
Result := StretchMaskBlt(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, Width, Height,
|
||||||
|
Mask, 0, 0, SRCCOPY);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function OptimalPixelFormat: TPixelFormat;
|
||||||
|
begin
|
||||||
|
Result := pfDevice;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function OSSupportsUTF16: Boolean;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
end;
|
||||||
1
components/lclextensions/include/qt/uses.inc
Executable file
1
components/lclextensions/include/qt/uses.inc
Executable file
@ -0,0 +1 @@
|
|||||||
|
InterfaceBase, LCLIntf, Graphics, qt4, qtint, qtobjects, qtwidgets, Math,
|
||||||
2
components/lclextensions/include/qt/uses_lclext.inc
Executable file
2
components/lclextensions/include/qt/uses_lclext.inc
Executable file
@ -0,0 +1,2 @@
|
|||||||
|
uses
|
||||||
|
LclIntf;
|
||||||
398
components/lclextensions/include/win32/delphicompat.inc
Executable file
398
components/lclextensions/include/win32/delphicompat.inc
Executable file
@ -0,0 +1,398 @@
|
|||||||
|
|
||||||
|
{ This file is part of Delphi Compatibility Unit
|
||||||
|
|
||||||
|
Copyright (C) 2007 Luiz Américo Pereira Câmara
|
||||||
|
pascalive@bol.com.br
|
||||||
|
|
||||||
|
This library is free software; you can redistribute it and/or modify it
|
||||||
|
under the terms of the GNU Library General Public License as published by
|
||||||
|
the Free Software Foundation; either version 2 of the License, or (at your
|
||||||
|
option) any later version with the following modification:
|
||||||
|
|
||||||
|
As a special exception, the copyright holders of this library give you
|
||||||
|
permission to link this library with independent modules to produce an
|
||||||
|
executable, regardless of the license terms of these independent modules,and
|
||||||
|
to copy and distribute the resulting executable under terms of your choice,
|
||||||
|
provided that you also meet, for each linked independent module, the terms
|
||||||
|
and conditions of the license of that module. An independent module is a
|
||||||
|
module which is not derived from or based on this library. If you modify
|
||||||
|
this library, you may extend this exception to your version of the library,
|
||||||
|
but you are not obligated to do so. If you do not wish to do so, delete this
|
||||||
|
exception statement from your version.
|
||||||
|
|
||||||
|
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. See the GNU Library General Public License
|
||||||
|
for more details.
|
||||||
|
|
||||||
|
You should have received a copy of the GNU Library General Public License
|
||||||
|
along with this library; if not, write to the Free Software Foundation,
|
||||||
|
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
|
function BeginDeferWindowPos(nNumWindows: longint): THandle;
|
||||||
|
begin
|
||||||
|
Result:=Windows.BeginDeferWindowPos(nNumWindows);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function BitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc,
|
||||||
|
YSrc: Integer; Rop: DWORD): Boolean;
|
||||||
|
begin
|
||||||
|
Result := Windows.BitBlt(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, Rop);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function CF_UNICODETEXT: TClipboardFormat;
|
||||||
|
begin
|
||||||
|
Result:=Windows.CF_UNICODETEXT;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function CopyImage(hImage: THANDLE; uType: LongWord; cxDesired,
|
||||||
|
cyDesired: LongInt; fuFlags: LongWord): THandle;
|
||||||
|
begin
|
||||||
|
Result := Windows.CopyImage(hImage,uType,cxDesired,cyDesired,fuFlags);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function CreatePatternBrush(hbmp: HBITMAP): HBRUSH;
|
||||||
|
begin
|
||||||
|
Result := Windows.CreatePatternBrush(hbmp);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function DeferWindowPos(hWinPosInfo, hWnd, hWndInsertAfter: THandle;
|
||||||
|
x, y, cx, cy: longint; uFlags: LongWord): THandle;
|
||||||
|
begin
|
||||||
|
Result := Windows.DeferWindowPos(hWinPosInfo,hWnd,hWndInsertAfter,x,y,cx,cy,uFlags);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function DrawFrameControl(DC: HDC; const Rect: TRect; uType, uState: LongWord): Boolean;
|
||||||
|
begin
|
||||||
|
Result := Windows.DrawFrameControl(DC,Rect,uType,uState);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function DrawTextW(hDC: HDC; lpString: PWideChar; nCount: Integer;
|
||||||
|
var lpRect: TRect; uFormat: LongWord): Integer;
|
||||||
|
begin
|
||||||
|
Result := Windows.DrawTextW(hDC,lpString,nCount,lpRect,uFormat);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function EndDeferWindowPos(hWinPosInfo: THandle): Boolean;
|
||||||
|
begin
|
||||||
|
Result:=Windows.EndDeferWindowPos(hWinPosInfo);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function ExtTextOutW(DC: LCLType.HDC; X, Y: Integer; Options: LongInt; Rect: Types.PRect;
|
||||||
|
Str: PWideChar; Count: LongInt; Dx: ObjPas.PInteger): Boolean;
|
||||||
|
begin
|
||||||
|
Result := Windows.ExtTextOutW(DC, X, Y, Options, Rect,Str, Count, Dx);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GdiFlush: Boolean;
|
||||||
|
begin
|
||||||
|
Result := Windows.GdiFlush;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetACP: LongWord;
|
||||||
|
begin
|
||||||
|
Result := Windows.GetACP;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetBkColor(DC: HDC): LCLType.COLORREF;
|
||||||
|
begin
|
||||||
|
Result := Windows.GetBkColor(DC);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetCurrentObject(hdc: HDC; uObjectType: UINT): HGDIOBJ;
|
||||||
|
begin
|
||||||
|
Result := Windows.GetCurrentObject(hdc, uObjectType);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetDCEx(hWnd: THandle; hrgnClip: HRGN; flags: DWORD): HDC;
|
||||||
|
begin
|
||||||
|
Result := Windows.GetDCEx(hWnd,hrgnClip,flags);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetDoubleClickTime: UINT;
|
||||||
|
begin
|
||||||
|
Result := Windows.GetDoubleClickTime;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetKeyboardLayout(dwLayout: DWORD): THandle;
|
||||||
|
begin
|
||||||
|
Result := Windows.GetKeyboardLayout(dwLayout);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetKeyboardState(lpKeyState: PBYTE): BOOLEAN;
|
||||||
|
begin
|
||||||
|
Result := Windows.GetKeyboardState(lpKeyState);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetLocaleInfo(Locale, LCType: LongWord; lpLCData: PChar;
|
||||||
|
cchData: longint): longint;
|
||||||
|
begin
|
||||||
|
Result := Windows.GetLocaleInfo(Locale,LCType,lpLCData,cchData);
|
||||||
|
end;
|
||||||
|
|
||||||
|
{$if lcl_release < 29}
|
||||||
|
function GetMapMode(DC: HDC): LongInt;
|
||||||
|
begin
|
||||||
|
Result := Windows.GetMapMode(DC);
|
||||||
|
end;
|
||||||
|
{$endif}
|
||||||
|
|
||||||
|
function GetRandomRgn(DC: HDC; Rgn: HRGN; iNum: Integer): Integer; stdcall; external 'GDI32.DLL';
|
||||||
|
|
||||||
|
function GetTextAlign(hDC: HDC): LongWord;
|
||||||
|
begin
|
||||||
|
Result := Windows.GetTextAlign(hDC);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetTextExtentExPoint(DC: LCLType.HDC; Str: PChar;
|
||||||
|
Count, MaxWidth: Integer; MaxCount, PartialWidths: ObjPas.PInteger;
|
||||||
|
var Size: TSize): BOOL;
|
||||||
|
begin
|
||||||
|
Result := Windows.GetTextExtentExPoint(DC, Str, Count, MaxWidth, MaxCount, PartialWidths, Size);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetTextExtentExPointW(DC: LCLType.HDC; Str: PWideChar;
|
||||||
|
Count, MaxWidth: Integer; MaxCount, PartialWidths: ObjPas.PInteger;
|
||||||
|
var Size: Types.TSize): BOOL;
|
||||||
|
begin
|
||||||
|
Result := Windows.GetTextExtentExPointW(DC, Str, Count, MaxWidth, MaxCount, PartialWidths, Size);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetTextExtentPoint32W(DC: HDC; Str: PWideChar; Count: Integer; out Size: TSize): Boolean;
|
||||||
|
begin
|
||||||
|
Result := Windows.GetTextExtentPointW(DC, Str, Count, Size);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetTextExtentPointW(DC: HDC; Str: PWideChar; Count: Integer; out Size: TSize): Boolean;
|
||||||
|
begin
|
||||||
|
Result := Windows.GetTextExtentPointW(DC, Str, Count, Size);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetWindowDC(hWnd: THandle): HDC;
|
||||||
|
begin
|
||||||
|
Result := Windows.GetWindowDC(hWnd);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function ImageList_DragShowNolock(fShow: Boolean): Boolean;
|
||||||
|
begin
|
||||||
|
Result := CommCtrl.ImageList_DragShowNolock(fShow);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function InvertRect(DC: HDC; const lprc: TRect): Boolean;
|
||||||
|
begin
|
||||||
|
Result := Windows.InvertRect(DC, PRect(@lprc)^);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function LPtoDP(DC: HDC; var Points; Count: Integer): BOOLEAN;
|
||||||
|
begin
|
||||||
|
Result := Windows.LPToDP(DC,Points,Count);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function MapWindowPoints(hWndFrom, hWndTo: HWND; var lpPoints; cPoints: UINT
|
||||||
|
): Integer;
|
||||||
|
begin
|
||||||
|
Result:=Windows.MapWindowPoints(hWndFrom,hWndTo,lpPoints,cPoints);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function MultiByteToWideChar(CodePage, dwFlags: DWORD; lpMultiByteStr: PChar;
|
||||||
|
cchMultiByte: longint; lpWideCharStr: PWideChar; cchWideChar: longint
|
||||||
|
): longint;
|
||||||
|
begin
|
||||||
|
Result := Windows.MultiByteToWideChar(CodePage,dwFlags,lpMultiByteStr,cchMultiByte,lpWideCharStr,cchWideChar);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function OffsetRgn(hrgn: HRGN; nxOffset, nYOffset: longint): longint;
|
||||||
|
begin
|
||||||
|
Result := Windows.OffsetRgn(hrgn,nxOffset,nYOffset);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function RedrawWindow(hWnd: THandle; lprcUpdate: Types.PRECT; hrgnUpdate: HRGN;
|
||||||
|
flags: LongWord): BOOLEAN;
|
||||||
|
begin
|
||||||
|
Result := Windows.RedrawWindow(hWnd,lprcUpdate,hrgnUpdate,flags);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function SetBrushOrgEx(DC: LCLType.HDC; nXOrg, nYOrg: longint; lppt: Types.PPoint): Boolean;
|
||||||
|
begin
|
||||||
|
Result := Windows.SetBrushOrgEx(DC,nXOrg,nYOrg,lppt);
|
||||||
|
end;
|
||||||
|
|
||||||
|
{$if lcl_release < 29}
|
||||||
|
function SetMapMode(DC: HDC; fnMapMode: LongInt): LongInt;
|
||||||
|
begin
|
||||||
|
Result := Windows.SetMapMode(DC, fnMapMode);
|
||||||
|
end;
|
||||||
|
{$endif}
|
||||||
|
|
||||||
|
function ScrollDC(DC: LCLType.HDC; dx: longint; dy: longint; var lprcScroll: Types.TRect;
|
||||||
|
var lprcClip: Types.TRect; hrgnUpdate: LCLType.HRGN; lprcUpdate: Types.PRect): Boolean;
|
||||||
|
begin
|
||||||
|
Result := Windows.ScrollDC(DC, dx, dy, lprcScroll, lprcClip, hrgnUpdate, lprcUpdate);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function ScrollWindow(hWnd: THandle; XAmount, YAmount: longint; lpRect: Types.PRect;
|
||||||
|
lpClipRect: Types.PRect): Boolean;
|
||||||
|
begin
|
||||||
|
Result := Windows.ScrollWindow(hWnd,XAmount,YAmount,lpRect,lpClipRect);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function SubtractRect(var lprcDst: TRect; const lprcSrc1, lprcSrc2: TRect
|
||||||
|
): BOOLEAN;
|
||||||
|
begin
|
||||||
|
Result := Windows.SubtractRect(lprcDst,lprcSrc1,lprcSrc2);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TextOutW(DC: HDC; X,Y : Integer; Str : PWideChar; Count: Integer) : Boolean;
|
||||||
|
begin
|
||||||
|
Result := Windows.TextOutW(DC,X,Y,Str,Count);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function ToAscii(uVirtKey, uScanCode: LongWord; lpKeyState: PBYTE;
|
||||||
|
lpChar: PWORD; uFlags: LongWord): longint;
|
||||||
|
begin
|
||||||
|
Result := Windows.ToAscii(uVirtKey,uScanCode,lpKeyState,lpChar,uFlags);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function UpdateWindow(Handle: HWND): Boolean;
|
||||||
|
begin
|
||||||
|
Result := Windows.UpdateWindow(Handle);
|
||||||
|
end;
|
||||||
|
|
||||||
|
type
|
||||||
|
TTimerID = record
|
||||||
|
hWnd: THandle;
|
||||||
|
nIDEvent: UINT_PTR;
|
||||||
|
end;
|
||||||
|
|
||||||
|
TTimerRecord = record
|
||||||
|
Control: TControl;
|
||||||
|
Notify: TTimerNotify;
|
||||||
|
end;
|
||||||
|
|
||||||
|
PTimerRecord = ^TTimerRecord;
|
||||||
|
|
||||||
|
{ TTimerList }
|
||||||
|
|
||||||
|
TTimerList = class
|
||||||
|
private
|
||||||
|
FMap: TMap;
|
||||||
|
public
|
||||||
|
constructor Create;
|
||||||
|
destructor Destroy; override;
|
||||||
|
procedure Add(hWnd: THandle; nIDEvent: UINT_PTR; NotifyFunc: TTimerNotify; Control: TControl);
|
||||||
|
function GetTimerInfo(hWnd: THandle; nIDEvent: UINT_PTR; out TimerInfo: TTimerRecord):Boolean;
|
||||||
|
function GetTimerInfoPtr(hWnd: THandle; nIDEvent: UINT_PTR): PTimerRecord;
|
||||||
|
end;
|
||||||
|
|
||||||
|
var
|
||||||
|
FTimerList: TTimerList;
|
||||||
|
|
||||||
|
{ TTimerList }
|
||||||
|
|
||||||
|
constructor TTimerList.Create;
|
||||||
|
begin
|
||||||
|
FMap := TMap.Create({$ifdef CPU64}itu16{$else}itu8{$endif}, SizeOf(TTimerRecord));
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TTimerList.Destroy;
|
||||||
|
begin
|
||||||
|
FMap.Destroy;
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TTimerList.Add(hWnd: THandle; nIDEvent: UINT_PTR; NotifyFunc: TTimerNotify; Control: TControl);
|
||||||
|
var
|
||||||
|
TimerID: TTimerID;
|
||||||
|
TimerRec: TTimerRecord;
|
||||||
|
begin
|
||||||
|
TimerRec.Notify := NotifyFunc;
|
||||||
|
TimerRec.Control := Control;
|
||||||
|
TimerID.hWnd := hWnd;
|
||||||
|
TimerID.nIDEvent := nIDEvent;
|
||||||
|
with FMap do
|
||||||
|
begin
|
||||||
|
if HasId(TimerID) then
|
||||||
|
SetData(TimerID, TimerRec)
|
||||||
|
else
|
||||||
|
Add(TimerID, TimerRec);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TTimerList.GetTimerInfo(hWnd: THandle; nIDEvent: UINT_PTR;
|
||||||
|
out TimerInfo: TTimerRecord): Boolean;
|
||||||
|
var
|
||||||
|
TimerID: TTimerID;
|
||||||
|
begin
|
||||||
|
TimerID.hWnd := hWnd;
|
||||||
|
TimerID.nIDEvent := nIDEvent;
|
||||||
|
Result := FMap.GetData(TimerID, TimerInfo);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TTimerList.GetTimerInfoPtr(hWnd: THandle; nIDEvent: UINT_PTR): PTimerRecord;
|
||||||
|
var
|
||||||
|
TimerID: TTimerID;
|
||||||
|
begin
|
||||||
|
TimerID.hWnd := hWnd;
|
||||||
|
TimerID.nIDEvent := nIDEvent;
|
||||||
|
Result := FMap.GetDataPtr(TimerID);
|
||||||
|
end;
|
||||||
|
|
||||||
|
//workaround to buggy fpc header
|
||||||
|
type
|
||||||
|
TIMERPROC64 = procedure (hWnd: HWND; uMsg: UINT; idEvent: UINT_PTR; dwTime: DWORD); stdcall;
|
||||||
|
|
||||||
|
function SetTimer64(hWnd: HWND; nIDEvent: UINT_PTR; uElapse: UINT; lpTimerFunc: TIMERPROC64): UINT_PTR; stdcall external 'user32' name 'SetTimer';
|
||||||
|
function KillTimer64(hWnd: HWND; uIDEvent: UINT_PTR):WINBOOL; stdcall external 'user32' name 'KillTimer';
|
||||||
|
|
||||||
|
procedure TimerCallBack(Handle: hWnd; Msg: UINT; idEvent: UINT_PTR; dwTime: DWORD); stdcall;
|
||||||
|
var
|
||||||
|
TimerInfo: PTimerRecord;
|
||||||
|
begin
|
||||||
|
//DebugLn('Executing Timer to Handle %d - ID: %d',[Handle, idEvent]);
|
||||||
|
TimerInfo := FTimerList.GetTimerInfoPtr(Handle, idEvent);
|
||||||
|
if TimerInfo <> nil then
|
||||||
|
with TimerInfo^ do
|
||||||
|
begin
|
||||||
|
if Notify <> nil then
|
||||||
|
Notify(idEvent)
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
if Control <> nil then
|
||||||
|
LCLSendTimerMsg(Control,idEvent,0);
|
||||||
|
end;
|
||||||
|
end
|
||||||
|
else
|
||||||
|
DebugLn('Warning - No TimerInfo found for Hwnd: %d Id: %d',[Handle,idEvent]);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function SetTimer(hWnd: THandle; nIDEvent: UINT_PTR; uElapse:LongWord; lpTimerFunc: TTimerNotify):UINT_PTR;
|
||||||
|
var
|
||||||
|
WinInfo: PWin32WindowInfo;
|
||||||
|
begin
|
||||||
|
if hWnd <> 0 then
|
||||||
|
begin
|
||||||
|
WinInfo := GetWin32WindowInfo(hWnd);
|
||||||
|
FTimerList.Add(hWnd,nIDEvent,lpTimerFunc,WinInfo^.WinControl);
|
||||||
|
Result := SetTimer64(hWnd,nIDEvent,uElapse,@TimerCallBack);
|
||||||
|
end
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
//if handle is 0, the callback is mandatory otherwise we get a zombie timer
|
||||||
|
if lpTimerFunc <> nil then
|
||||||
|
begin
|
||||||
|
Result := SetTimer64(hWnd,nIDEvent,uElapse,@TimerCallBack);
|
||||||
|
FTimerList.Add(hWnd,Result,lpTimerFunc,nil);
|
||||||
|
end
|
||||||
|
else
|
||||||
|
Result := 0;
|
||||||
|
end;
|
||||||
|
//DebugLn('SetTimer - Handle %d - ID: %d - Result: %d',[hWnd,nIDEvent,Result]);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function KillTimer(hWnd: THandle; nIDEvent: UINT_PTR):Boolean;
|
||||||
|
begin
|
||||||
|
Result := KillTimer64(hWnd,nIDEvent);
|
||||||
|
//DebugLn('KillTimer - Handle %d - ID: %d',[hWnd,nIDEvent]);
|
||||||
|
end;
|
||||||
61
components/lclextensions/include/win32/lclext.inc
Executable file
61
components/lclextensions/include/win32/lclext.inc
Executable file
@ -0,0 +1,61 @@
|
|||||||
|
|
||||||
|
|
||||||
|
function CreateBitmapMask(BitmapDC: HDC; Width, Height: Integer; TransparentColor: TColor): HBITMAP;
|
||||||
|
var
|
||||||
|
OldColor: COLORREF;
|
||||||
|
OldObj: HBITMAP;
|
||||||
|
MaskDC: HDC;
|
||||||
|
begin
|
||||||
|
Result := Windows.CreateBitmap(Width,Height,1,1,nil);
|
||||||
|
MaskDC := Windows.CreateCompatibleDC(BitmapDC);
|
||||||
|
|
||||||
|
OldObj := Windows.SelectObject(MaskDC,Result);
|
||||||
|
OldColor := Windows.SetBkColor(BitmapDC, Windows.COLORREF(ColorToRGB(TransparentColor)));
|
||||||
|
|
||||||
|
Windows.BitBlt(MaskDC,0,0,Width,Height,BitmapDC,0,0,SRCCOPY);
|
||||||
|
|
||||||
|
Windows.SetBkColor(BitmapDC,OldColor);
|
||||||
|
Windows.SelectObject(MaskDC,OldObj);
|
||||||
|
Windows.DeleteDC(MaskDC);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function DirectMaskBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc: Integer; Mask: HBITMAP): Boolean;
|
||||||
|
var
|
||||||
|
MaskDC: HDC;
|
||||||
|
MaskObj: HGDIOBJ;
|
||||||
|
PrevTextColor, PrevBkColor: COLORREF;
|
||||||
|
begin
|
||||||
|
//this is a stripped version of LCL.StretchMaskBlt
|
||||||
|
if Mask <> 0 then
|
||||||
|
begin
|
||||||
|
MaskDC := Windows.CreateCompatibleDC(DestDC);
|
||||||
|
MaskObj := Windows.SelectObject(MaskDC, Mask);
|
||||||
|
|
||||||
|
PrevTextColor := Windows.SetTextColor(DestDC, $00000000);
|
||||||
|
PrevBkColor := Windows.SetBkColor(DestDC, $00FFFFFF);
|
||||||
|
|
||||||
|
Windows.BitBlt(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, SRCINVERT);
|
||||||
|
Windows.BitBlt(DestDC, X, Y, Width, Height, MaskDC, XSrc, YSrc, SRCAND);
|
||||||
|
Windows.BitBlt(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, SRCINVERT);
|
||||||
|
|
||||||
|
Windows.SetTextColor(DestDC, PrevTextColor);
|
||||||
|
Windows.SetBkColor(DestDC, PrevBkColor);
|
||||||
|
Windows.SelectObject(MaskDC, MaskObj);
|
||||||
|
Windows.DeleteDC(MaskDC);
|
||||||
|
end
|
||||||
|
else
|
||||||
|
Result := Windows.BitBlt(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, SRCCOPY);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function OptimalPixelFormat: TPixelFormat;
|
||||||
|
begin
|
||||||
|
if ScreenInfo.ColorDepth = 32 then
|
||||||
|
Result := pf32bit
|
||||||
|
else
|
||||||
|
Result := pfDevice;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function OSSupportsUTF16: Boolean;
|
||||||
|
begin
|
||||||
|
Result := Win32Platform = VER_PLATFORM_WIN32_NT;
|
||||||
|
end;
|
||||||
3
components/lclextensions/include/win32/uses.inc
Executable file
3
components/lclextensions/include/win32/uses.inc
Executable file
@ -0,0 +1,3 @@
|
|||||||
|
|
||||||
|
Windows, win32proc, CommCtrl,
|
||||||
|
|
||||||
2
components/lclextensions/include/win32/uses_lclext.inc
Executable file
2
components/lclextensions/include/win32/uses_lclext.inc
Executable file
@ -0,0 +1,2 @@
|
|||||||
|
uses
|
||||||
|
Windows;
|
||||||
58
components/lclextensions/lclext.pas
Executable file
58
components/lclextensions/lclext.pas
Executable file
@ -0,0 +1,58 @@
|
|||||||
|
unit LclExt;
|
||||||
|
|
||||||
|
{ LCL Extension Unit
|
||||||
|
|
||||||
|
Copyright (C) 2007 Luiz Américo Pereira Câmara
|
||||||
|
pascalive@bol.com.br
|
||||||
|
|
||||||
|
This library is free software; you can redistribute it and/or modify it
|
||||||
|
under the terms of the GNU Library General Public License as published by
|
||||||
|
the Free Software Foundation; either version 2 of the License, or (at your
|
||||||
|
option) any later version with the following modification:
|
||||||
|
|
||||||
|
As a special exception, the copyright holders of this library give you
|
||||||
|
permission to link this library with independent modules to produce an
|
||||||
|
executable, regardless of the license terms of these independent modules,and
|
||||||
|
to copy and distribute the resulting executable under terms of your choice,
|
||||||
|
provided that you also meet, for each linked independent module, the terms
|
||||||
|
and conditions of the license of that module. An independent module is a
|
||||||
|
module which is not derived from or based on this library. If you modify
|
||||||
|
this library, you may extend this exception to your version of the library,
|
||||||
|
but you are not obligated to do so. If you do not wish to do so, delete this
|
||||||
|
exception statement from your version.
|
||||||
|
|
||||||
|
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. See the GNU Library General Public License
|
||||||
|
for more details.
|
||||||
|
|
||||||
|
You should have received a copy of the GNU Library General Public License
|
||||||
|
along with this library; if not, write to the Free Software Foundation,
|
||||||
|
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
|
{$mode objfpc}{$H+}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes, SysUtils, LCLType, Graphics;
|
||||||
|
|
||||||
|
function CreateBitmapMask(BitmapDC: HDC; Width, Height: Integer; TransparentColor: TColor): HBITMAP;
|
||||||
|
|
||||||
|
function DirectMaskBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc: Integer; Mask: HBITMAP): Boolean;
|
||||||
|
|
||||||
|
function OptimalPixelFormat: TPixelFormat;
|
||||||
|
|
||||||
|
function OSSupportsUTF16: Boolean;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
{$i uses_lclext.inc}
|
||||||
|
|
||||||
|
|
||||||
|
{$i lclext.inc}
|
||||||
|
|
||||||
|
end.
|
||||||
|
|
||||||
55
components/lclextensions/lclextensions_package.lpk
Executable file
55
components/lclextensions/lclextensions_package.lpk
Executable file
@ -0,0 +1,55 @@
|
|||||||
|
<?xml version="1.0"?>
|
||||||
|
<CONFIG>
|
||||||
|
<Package Version="4">
|
||||||
|
<Name Value="lclextensions_package"/>
|
||||||
|
<AddToProjectUsesSection Value="True"/>
|
||||||
|
<Author Value="Luiz Americo Pereira Câmara"/>
|
||||||
|
<CompilerOptions>
|
||||||
|
<Version Value="11"/>
|
||||||
|
<SearchPaths>
|
||||||
|
<IncludeFiles Value="include/$(LCLWidgetType)"/>
|
||||||
|
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)-$(LCLWidgetType)"/>
|
||||||
|
</SearchPaths>
|
||||||
|
<Parsing>
|
||||||
|
<SyntaxOptions>
|
||||||
|
<UseAnsiStrings Value="False"/>
|
||||||
|
</SyntaxOptions>
|
||||||
|
</Parsing>
|
||||||
|
<Other>
|
||||||
|
<CompilerPath Value="$(CompPath)"/>
|
||||||
|
</Other>
|
||||||
|
</CompilerOptions>
|
||||||
|
<Description Value="LCL Extensions provides additional functions to be used together with LCL
|
||||||
|
"/>
|
||||||
|
<License Value="Modified LGPL
|
||||||
|
"/>
|
||||||
|
<Version Minor="5" Release="1"/>
|
||||||
|
<Files Count="3">
|
||||||
|
<Item1>
|
||||||
|
<Filename Value="delphicompat.pas"/>
|
||||||
|
<UnitName Value="DelphiCompat"/>
|
||||||
|
</Item1>
|
||||||
|
<Item2>
|
||||||
|
<Filename Value="oleutils.pas"/>
|
||||||
|
<UnitName Value="oleutils"/>
|
||||||
|
</Item2>
|
||||||
|
<Item3>
|
||||||
|
<Filename Value="lclext.pas"/>
|
||||||
|
<UnitName Value="LclExt"/>
|
||||||
|
</Item3>
|
||||||
|
</Files>
|
||||||
|
<Type Value="RunAndDesignTime"/>
|
||||||
|
<RequiredPkgs Count="1">
|
||||||
|
<Item1>
|
||||||
|
<PackageName Value="LCL"/>
|
||||||
|
</Item1>
|
||||||
|
</RequiredPkgs>
|
||||||
|
<UsageOptions>
|
||||||
|
<UnitPath Value="$(PkgOutDir)"/>
|
||||||
|
</UsageOptions>
|
||||||
|
<PublishOptions>
|
||||||
|
<Version Value="2"/>
|
||||||
|
<IgnoreBinaries Value="False"/>
|
||||||
|
</PublishOptions>
|
||||||
|
</Package>
|
||||||
|
</CONFIG>
|
||||||
20
components/lclextensions/lclextensions_package.pas
Executable file
20
components/lclextensions/lclextensions_package.pas
Executable file
@ -0,0 +1,20 @@
|
|||||||
|
{ This file was automatically created by Lazarus. Do not edit!
|
||||||
|
This source is only used to compile and install the package.
|
||||||
|
}
|
||||||
|
|
||||||
|
unit lclextensions_package;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
DelphiCompat, oleutils, LclExt, LazarusPackageIntf;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
procedure Register;
|
||||||
|
begin
|
||||||
|
end;
|
||||||
|
|
||||||
|
initialization
|
||||||
|
RegisterPackage('lclextensions_package', @Register);
|
||||||
|
end.
|
||||||
149
components/lclextensions/oleutils.pas
Executable file
149
components/lclextensions/oleutils.pas
Executable file
@ -0,0 +1,149 @@
|
|||||||
|
unit oleutils;
|
||||||
|
|
||||||
|
{ OLE helper functions
|
||||||
|
|
||||||
|
Copyright (C) 2007 Luiz Am�rico Pereira C�mara
|
||||||
|
pascalive@bol.com.br
|
||||||
|
|
||||||
|
This library is free software; you can redistribute it and/or modify it
|
||||||
|
under the terms of the GNU Library General Public License as published by
|
||||||
|
the Free Software Foundation; either version 2 of the License, or (at your
|
||||||
|
option) any later version with the following modification:
|
||||||
|
|
||||||
|
As a special exception, the copyright holders of this library give you
|
||||||
|
permission to link this library with independent modules to produce an
|
||||||
|
executable, regardless of the license terms of these independent modules,and
|
||||||
|
to copy and distribute the resulting executable under terms of your choice,
|
||||||
|
provided that you also meet, for each linked independent module, the terms
|
||||||
|
and conditions of the license of that module. An independent module is a
|
||||||
|
module which is not derived from or based on this library. If you modify
|
||||||
|
this library, you may extend this exception to your version of the library,
|
||||||
|
but you are not obligated to do so. If you do not wish to do so, delete this
|
||||||
|
exception statement from your version.
|
||||||
|
|
||||||
|
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. See the GNU Library General Public License
|
||||||
|
for more details.
|
||||||
|
|
||||||
|
You should have received a copy of the GNU Library General Public License
|
||||||
|
along with this library; if not, write to the Free Software Foundation,
|
||||||
|
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
//todo: add error handling
|
||||||
|
|
||||||
|
{$mode objfpc}{$H+}
|
||||||
|
|
||||||
|
interface
|
||||||
|
{$ifdef Windows}
|
||||||
|
uses
|
||||||
|
Windows, Classes, SysUtils, ActiveX;
|
||||||
|
|
||||||
|
type
|
||||||
|
|
||||||
|
{ TOLEStream }
|
||||||
|
|
||||||
|
TOLEStream = class (TStream)
|
||||||
|
private
|
||||||
|
FSrcStream: IStream;
|
||||||
|
procedure InternalSetSize(NewSize: LARGE_INTEGER);
|
||||||
|
public
|
||||||
|
constructor Create(const Stream: IStream);
|
||||||
|
function Read(var Buffer; Count: Integer): Integer; override;
|
||||||
|
function Seek(Offset: Integer; Origin: Word): Integer; overload; override;
|
||||||
|
procedure SetSize(const NewSize: Int64); override;
|
||||||
|
procedure SetSize(NewSize: Longint); override;
|
||||||
|
function Write(const Buffer; Count: Integer): Integer; override;
|
||||||
|
end;
|
||||||
|
{$endif}
|
||||||
|
implementation
|
||||||
|
{$ifdef Windows}
|
||||||
|
|
||||||
|
function ErrorString(Error: HRESULT): String;
|
||||||
|
begin
|
||||||
|
case Error of
|
||||||
|
E_PENDING: Result:='E_PENDING';
|
||||||
|
S_FALSE: Result:='S_FALSE';
|
||||||
|
STG_E_MEDIUMFULL: Result:='STG_E_MEDIUMFULL';
|
||||||
|
STG_E_ACCESSDENIED: Result:= 'STG_E_ACCESSDENIED';
|
||||||
|
STG_E_CANTSAVE: Result:='STG_E_CANTSAVE';
|
||||||
|
STG_E_INVALIDPOINTER: Result:='STG_E_INVALIDPOINTER';
|
||||||
|
STG_E_REVERTED: Result:='STG_E_REVERTED';
|
||||||
|
STG_E_WRITEFAULT: Result:='STG_E_WRITEFAULT';
|
||||||
|
STG_E_INVALIDFUNCTION: Result:='STG_E_INVALIDFUNCTION';
|
||||||
|
else
|
||||||
|
Result:='Unknow error';
|
||||||
|
end;
|
||||||
|
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TOLEStream }
|
||||||
|
|
||||||
|
constructor TOLEStream.Create(const Stream: IStream);
|
||||||
|
begin
|
||||||
|
inherited Create;
|
||||||
|
FSrcStream:=Stream;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TOLEStream.Read(var Buffer; Count: Integer): Integer;
|
||||||
|
var
|
||||||
|
Res: HRESULT;
|
||||||
|
begin
|
||||||
|
Res:=FSrcStream.Read(@Buffer, Count, @Result);
|
||||||
|
if Res <> S_OK then
|
||||||
|
Raise Exception.Create('TOLEStream - Error while reading: '+ErrorString(Res));
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TOLEStream.Seek(Offset: Integer; Origin: Word): Integer;
|
||||||
|
var
|
||||||
|
liResult, liOffset : LARGE_INTEGER;
|
||||||
|
Res: HRESULT;
|
||||||
|
begin
|
||||||
|
//soFrom* constants are equal to STREAM_SEEK_* constants. Assume it here
|
||||||
|
liOffset.LowPart:=Offset;
|
||||||
|
liOffset.HighPart:=0;
|
||||||
|
Res:=FSrcStream.Seek(Int64(liOffset), Origin, Int64(liResult));
|
||||||
|
Result:=liResult.LowPart;
|
||||||
|
if Res <> S_OK then
|
||||||
|
Raise Exception.Create('TOLEStream - Error while seeking: '+ErrorString(Res));
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TOLEStream.SetSize(NewSize: Longint);
|
||||||
|
var
|
||||||
|
liSize: LARGE_INTEGER;
|
||||||
|
begin
|
||||||
|
liSize.LowPart:=NewSize;
|
||||||
|
liSize.HighPart:=0;
|
||||||
|
InternalSetSize(liSize);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TOLEStream.SetSize(const NewSize: Int64);
|
||||||
|
var
|
||||||
|
liSize: LARGE_INTEGER;
|
||||||
|
begin
|
||||||
|
liSize.QuadPart:=NewSize;
|
||||||
|
InternalSetSize(liSize);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TOLEStream.InternalSetSize(NewSize: LARGE_INTEGER);
|
||||||
|
var
|
||||||
|
Res:HRESULT;
|
||||||
|
begin
|
||||||
|
Res:=FSrcStream.SetSize(Int64(NewSize));
|
||||||
|
if Res <> S_OK then
|
||||||
|
Raise Exception.Create('TOLEStream - Error while setting size: '+ErrorString(Res));
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TOLEStream.Write(const Buffer; Count: Integer): Integer;
|
||||||
|
var
|
||||||
|
Res: HRESULT;
|
||||||
|
begin
|
||||||
|
Res:=FSrcStream.Write(@Buffer,Count,@Result);
|
||||||
|
if Res <> S_OK then
|
||||||
|
Raise Exception.Create('TOLEStream - Error while writing: '+ErrorString(Res));
|
||||||
|
end;
|
||||||
|
{$endif}
|
||||||
|
end.
|
||||||
|
|
||||||
135
components/lclextensions/tests/settimer/Unit1.lfm
Executable file
135
components/lclextensions/tests/settimer/Unit1.lfm
Executable file
@ -0,0 +1,135 @@
|
|||||||
|
object MainForm: TMainForm
|
||||||
|
Left = 409
|
||||||
|
Height = 448
|
||||||
|
Top = 218
|
||||||
|
Width = 613
|
||||||
|
HorzScrollBar.Page = 559
|
||||||
|
VertScrollBar.Page = 447
|
||||||
|
ActiveControl = ListBox1
|
||||||
|
Caption = 'Test SetTimer'
|
||||||
|
ClientHeight = 448
|
||||||
|
ClientWidth = 613
|
||||||
|
Position = poScreenCenter
|
||||||
|
LCLVersion = '1.1'
|
||||||
|
object ListBox1: TListBox
|
||||||
|
Left = 8
|
||||||
|
Height = 403
|
||||||
|
Top = 8
|
||||||
|
Width = 320
|
||||||
|
Anchors = [akTop, akLeft, akBottom]
|
||||||
|
ItemHeight = 0
|
||||||
|
ScrollWidth = 318
|
||||||
|
TabOrder = 0
|
||||||
|
TopIndex = -1
|
||||||
|
end
|
||||||
|
object Button1: TButton
|
||||||
|
Left = 240
|
||||||
|
Height = 30
|
||||||
|
Top = 414
|
||||||
|
Width = 88
|
||||||
|
Anchors = [akLeft, akBottom]
|
||||||
|
BorderSpacing.InnerBorder = 4
|
||||||
|
Caption = 'Clear'
|
||||||
|
OnClick = Button1Click
|
||||||
|
TabOrder = 1
|
||||||
|
end
|
||||||
|
object SetTimer1Button: TButton
|
||||||
|
Left = 345
|
||||||
|
Height = 28
|
||||||
|
Top = 8
|
||||||
|
Width = 120
|
||||||
|
BorderSpacing.InnerBorder = 4
|
||||||
|
Caption = 'Set Timer 1'
|
||||||
|
OnClick = SetTimer1ButtonClick
|
||||||
|
TabOrder = 2
|
||||||
|
end
|
||||||
|
object SetTimer2Button: TButton
|
||||||
|
Left = 345
|
||||||
|
Height = 28
|
||||||
|
Top = 48
|
||||||
|
Width = 120
|
||||||
|
BorderSpacing.InnerBorder = 4
|
||||||
|
Caption = 'Set Timer 2'
|
||||||
|
OnClick = SetTimer2ButtonClick
|
||||||
|
TabOrder = 3
|
||||||
|
end
|
||||||
|
object SetTimer3Button: TButton
|
||||||
|
Left = 345
|
||||||
|
Height = 28
|
||||||
|
Top = 88
|
||||||
|
Width = 120
|
||||||
|
BorderSpacing.InnerBorder = 4
|
||||||
|
Caption = 'Set Timer 3'
|
||||||
|
OnClick = SetTimer3ButtonClick
|
||||||
|
TabOrder = 4
|
||||||
|
end
|
||||||
|
object KillTimer1Button: TButton
|
||||||
|
Left = 481
|
||||||
|
Height = 28
|
||||||
|
Top = 8
|
||||||
|
Width = 120
|
||||||
|
BorderSpacing.InnerBorder = 4
|
||||||
|
Caption = 'Kill'
|
||||||
|
OnClick = KillTimer1ButtonClick
|
||||||
|
TabOrder = 5
|
||||||
|
end
|
||||||
|
object KillTimer2Button: TButton
|
||||||
|
Left = 481
|
||||||
|
Height = 28
|
||||||
|
Top = 48
|
||||||
|
Width = 120
|
||||||
|
BorderSpacing.InnerBorder = 4
|
||||||
|
Caption = 'Kill'
|
||||||
|
OnClick = KillTimer2ButtonClick
|
||||||
|
TabOrder = 6
|
||||||
|
end
|
||||||
|
object KillTimer3Button: TButton
|
||||||
|
Left = 481
|
||||||
|
Height = 60
|
||||||
|
Top = 88
|
||||||
|
Width = 120
|
||||||
|
BorderSpacing.InnerBorder = 4
|
||||||
|
Caption = 'Kill'
|
||||||
|
OnClick = KillTimer3ButtonClick
|
||||||
|
TabOrder = 7
|
||||||
|
end
|
||||||
|
object SetTimer3bButton: TButton
|
||||||
|
Left = 345
|
||||||
|
Height = 28
|
||||||
|
Top = 120
|
||||||
|
Width = 120
|
||||||
|
BorderSpacing.InnerBorder = 4
|
||||||
|
Caption = 'Set Timer 3b'
|
||||||
|
OnClick = SetTimer3bButtonClick
|
||||||
|
TabOrder = 8
|
||||||
|
end
|
||||||
|
object SetTimerDestroyButton: TButton
|
||||||
|
Left = 345
|
||||||
|
Height = 28
|
||||||
|
Top = 224
|
||||||
|
Width = 256
|
||||||
|
Caption = 'Set Timer and Destroy'
|
||||||
|
OnClick = SetTimerDestroyButtonClick
|
||||||
|
TabOrder = 9
|
||||||
|
end
|
||||||
|
object SetGlobalTimerButton: TButton
|
||||||
|
Left = 345
|
||||||
|
Height = 28
|
||||||
|
Top = 160
|
||||||
|
Width = 120
|
||||||
|
BorderSpacing.InnerBorder = 4
|
||||||
|
Caption = 'Set Global Timer'
|
||||||
|
OnClick = SetGlobalTimerButtonClick
|
||||||
|
TabOrder = 10
|
||||||
|
end
|
||||||
|
object KillGlobalTimerButton1: TButton
|
||||||
|
Left = 481
|
||||||
|
Height = 28
|
||||||
|
Top = 160
|
||||||
|
Width = 120
|
||||||
|
BorderSpacing.InnerBorder = 4
|
||||||
|
Caption = 'Kill'
|
||||||
|
OnClick = KillGlobalTimerButton1Click
|
||||||
|
TabOrder = 11
|
||||||
|
end
|
||||||
|
end
|
||||||
183
components/lclextensions/tests/settimer/Unit1.pas
Executable file
183
components/lclextensions/tests/settimer/Unit1.pas
Executable file
@ -0,0 +1,183 @@
|
|||||||
|
unit Unit1;
|
||||||
|
|
||||||
|
{$mode objfpc}{$H+}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls,
|
||||||
|
Buttons, delphicompat, LMessages, LCLType;
|
||||||
|
|
||||||
|
type
|
||||||
|
|
||||||
|
{ TMainForm }
|
||||||
|
|
||||||
|
TMainForm = class(TForm)
|
||||||
|
Button1: TButton;
|
||||||
|
KillGlobalTimerButton1: TButton;
|
||||||
|
SetGlobalTimerButton: TButton;
|
||||||
|
SetTimerDestroyButton: TButton;
|
||||||
|
SetTimer1Button: TButton;
|
||||||
|
SetTimer2Button: TButton;
|
||||||
|
SetTimer3Button: TButton;
|
||||||
|
KillTimer1Button: TButton;
|
||||||
|
KillTimer2Button: TButton;
|
||||||
|
KillTimer3Button: TButton;
|
||||||
|
SetTimer3bButton: TButton;
|
||||||
|
ListBox1: TListBox;
|
||||||
|
procedure Button1Click(Sender: TObject);
|
||||||
|
procedure KillGlobalTimerButton1Click(Sender: TObject);
|
||||||
|
procedure SetGlobalTimerButtonClick(Sender: TObject);
|
||||||
|
procedure SetTimer1ButtonClick(Sender: TObject);
|
||||||
|
procedure SetTimer2ButtonClick(Sender: TObject);
|
||||||
|
procedure SetTimer3ButtonClick(Sender: TObject);
|
||||||
|
procedure KillTimer1ButtonClick(Sender: TObject);
|
||||||
|
procedure KillTimer2ButtonClick(Sender: TObject);
|
||||||
|
procedure KillTimer3ButtonClick(Sender: TObject);
|
||||||
|
procedure SetTimer3bButtonClick(Sender: TObject);
|
||||||
|
procedure SetTimerDestroyButtonClick(Sender: TObject);
|
||||||
|
protected
|
||||||
|
procedure WMTimer(var Message: TLMTimer); message LM_TIMER;
|
||||||
|
private
|
||||||
|
FGlobalTimer: PtrUInt;
|
||||||
|
procedure TimerCallback(AId: PtrUInt);
|
||||||
|
procedure TimerCallbackGlobal(AId: PtrUInt);
|
||||||
|
procedure TimerCallbackOther(AId: PtrUInt);
|
||||||
|
{ private declarations }
|
||||||
|
public
|
||||||
|
{ public declarations }
|
||||||
|
end;
|
||||||
|
|
||||||
|
var
|
||||||
|
MainForm: TMainForm;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
strutils;
|
||||||
|
|
||||||
|
const
|
||||||
|
Timer1 = 1;
|
||||||
|
Timer2 = 2;
|
||||||
|
Timer3 = 3;
|
||||||
|
|
||||||
|
{ TMainForm }
|
||||||
|
|
||||||
|
procedure TMainForm.Button1Click(Sender: TObject);
|
||||||
|
begin
|
||||||
|
ListBox1.Clear;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TMainForm.KillGlobalTimerButton1Click(Sender: TObject);
|
||||||
|
begin
|
||||||
|
if FGlobalTimer <> 0 then
|
||||||
|
begin
|
||||||
|
KillTimer(0, FGlobalTimer);
|
||||||
|
FGlobalTimer := 0;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TMainForm.SetGlobalTimerButtonClick(Sender: TObject);
|
||||||
|
begin
|
||||||
|
FGlobalTimer := SetTimer(0,FGlobalTimer,2000,@TimerCallbackGlobal);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TMainForm.SetTimer1ButtonClick(Sender: TObject);
|
||||||
|
begin
|
||||||
|
SetTimer(Handle,Timer1,1000,nil);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TMainForm.SetTimer2ButtonClick(Sender: TObject);
|
||||||
|
begin
|
||||||
|
SetTimer(Handle,Timer2,2000,nil);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TMainForm.SetTimer3ButtonClick(Sender: TObject);
|
||||||
|
begin
|
||||||
|
SetTimer(Handle,Timer3,3000,@TimerCallback);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TMainForm.KillTimer1ButtonClick(Sender: TObject);
|
||||||
|
begin
|
||||||
|
KillTimer(Handle,Timer1);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TMainForm.KillTimer2ButtonClick(Sender: TObject);
|
||||||
|
begin
|
||||||
|
KillTimer(Handle,Timer2);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TMainForm.KillTimer3ButtonClick(Sender: TObject);
|
||||||
|
begin
|
||||||
|
KillTimer(Handle,Timer3);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TMainForm.SetTimer3bButtonClick(Sender: TObject);
|
||||||
|
begin
|
||||||
|
SetTimer(Handle,Timer3,3000,@TimerCallbackOther);
|
||||||
|
end;
|
||||||
|
|
||||||
|
type
|
||||||
|
|
||||||
|
{ TMyButton }
|
||||||
|
|
||||||
|
TMyButton = class(TButton)
|
||||||
|
protected
|
||||||
|
procedure WMTimer(var Message: TLMTimer); message LM_TIMER;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TMyButton }
|
||||||
|
|
||||||
|
procedure TMyButton.WMTimer(var Message: TLMTimer);
|
||||||
|
begin
|
||||||
|
MainForm.ListBox1.Items.Add('WMTimer - Released Button (Should Not Be Fired)');
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TMainForm.SetTimerDestroyButtonClick(Sender: TObject);
|
||||||
|
var
|
||||||
|
Button: TButton;
|
||||||
|
begin
|
||||||
|
Button := TButton.Create(nil);
|
||||||
|
try
|
||||||
|
Button.Parent := Self;
|
||||||
|
Button.Visible := True;
|
||||||
|
SetTimer(Button.Handle, Timer3, 1000, nil);
|
||||||
|
finally
|
||||||
|
Button.Destroy;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TMainForm.WMTimer(var Message: TLMTimer);
|
||||||
|
var
|
||||||
|
AStr: String;
|
||||||
|
begin
|
||||||
|
case Message.TimerID of
|
||||||
|
Timer1: AStr:='Timer1 called';
|
||||||
|
Timer2: AStr:='Timer2 called';
|
||||||
|
Timer3: AStr:='Timer3 called';
|
||||||
|
else
|
||||||
|
AStr:='TimerID not identified: '+IntToStr(Message.TimerID);
|
||||||
|
end;
|
||||||
|
ListBox1.Items.Add('WMTimer - '+AStr);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TMainForm.TimerCallback(AId: PtrUInt);
|
||||||
|
begin
|
||||||
|
ListBox1.Items.Add('TimerCallback called');
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TMainForm.TimerCallbackGlobal(AId: PtrUInt);
|
||||||
|
begin
|
||||||
|
ListBox1.Items.Add('TimerCallbackGlobal called' + IfThen(AId <> FGlobalTimer, ' ERROR: ID <> GlobalTimer'));
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TMainForm.TimerCallbackOther(AId: PtrUInt);
|
||||||
|
begin
|
||||||
|
ListBox1.Items.Add('TimerCallbackOther called');
|
||||||
|
end;
|
||||||
|
|
||||||
|
initialization
|
||||||
|
{$I Unit1.lrs}
|
||||||
|
|
||||||
|
end.
|
||||||
|
|
||||||
87
components/lclextensions/tests/settimer/project1.lpi
Executable file
87
components/lclextensions/tests/settimer/project1.lpi
Executable file
@ -0,0 +1,87 @@
|
|||||||
|
<?xml version="1.0"?>
|
||||||
|
<CONFIG>
|
||||||
|
<ProjectOptions>
|
||||||
|
<Version Value="9"/>
|
||||||
|
<General>
|
||||||
|
<Flags>
|
||||||
|
<LRSInOutputDirectory Value="False"/>
|
||||||
|
</Flags>
|
||||||
|
<SessionStorage Value="InProjectDir"/>
|
||||||
|
<MainUnit Value="0"/>
|
||||||
|
<UseXPManifest Value="True"/>
|
||||||
|
</General>
|
||||||
|
<VersionInfo>
|
||||||
|
<StringTable ProductVersion=""/>
|
||||||
|
</VersionInfo>
|
||||||
|
<BuildModes Count="1">
|
||||||
|
<Item1 Name="default" Default="True"/>
|
||||||
|
</BuildModes>
|
||||||
|
<PublishOptions>
|
||||||
|
<Version Value="2"/>
|
||||||
|
<IgnoreBinaries Value="False"/>
|
||||||
|
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
|
||||||
|
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
|
||||||
|
</PublishOptions>
|
||||||
|
<RunParams>
|
||||||
|
<local>
|
||||||
|
<FormatVersion Value="1"/>
|
||||||
|
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
|
||||||
|
</local>
|
||||||
|
</RunParams>
|
||||||
|
<RequiredPackages Count="2">
|
||||||
|
<Item1>
|
||||||
|
<PackageName Value="LCL"/>
|
||||||
|
</Item1>
|
||||||
|
<Item2>
|
||||||
|
<PackageName Value="lclextensions_package"/>
|
||||||
|
</Item2>
|
||||||
|
</RequiredPackages>
|
||||||
|
<Units Count="2">
|
||||||
|
<Unit0>
|
||||||
|
<Filename Value="project1.lpr"/>
|
||||||
|
<IsPartOfProject Value="True"/>
|
||||||
|
<UnitName Value="project1"/>
|
||||||
|
</Unit0>
|
||||||
|
<Unit1>
|
||||||
|
<Filename Value="Unit1.pas"/>
|
||||||
|
<IsPartOfProject Value="True"/>
|
||||||
|
<ComponentName Value="MainForm"/>
|
||||||
|
<HasResources Value="True"/>
|
||||||
|
<ResourceBaseClass Value="Form"/>
|
||||||
|
<UnitName Value="Unit1"/>
|
||||||
|
</Unit1>
|
||||||
|
</Units>
|
||||||
|
</ProjectOptions>
|
||||||
|
<CompilerOptions>
|
||||||
|
<Version Value="11"/>
|
||||||
|
<Target>
|
||||||
|
<Filename Value="testsettimer"/>
|
||||||
|
</Target>
|
||||||
|
<SearchPaths>
|
||||||
|
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
|
||||||
|
</SearchPaths>
|
||||||
|
<Parsing>
|
||||||
|
<SyntaxOptions>
|
||||||
|
<UseAnsiStrings Value="False"/>
|
||||||
|
</SyntaxOptions>
|
||||||
|
</Parsing>
|
||||||
|
<Linking>
|
||||||
|
<Debugging>
|
||||||
|
<UseHeaptrc Value="True"/>
|
||||||
|
</Debugging>
|
||||||
|
</Linking>
|
||||||
|
<Other>
|
||||||
|
<CompilerPath Value="$(CompPath)"/>
|
||||||
|
</Other>
|
||||||
|
</CompilerOptions>
|
||||||
|
<Debugging>
|
||||||
|
<Exceptions Count="2">
|
||||||
|
<Item1>
|
||||||
|
<Name Value="ECodetoolError"/>
|
||||||
|
</Item1>
|
||||||
|
<Item2>
|
||||||
|
<Name Value="EFOpenError"/>
|
||||||
|
</Item2>
|
||||||
|
</Exceptions>
|
||||||
|
</Debugging>
|
||||||
|
</CONFIG>
|
||||||
20
components/lclextensions/tests/settimer/project1.lpr
Executable file
20
components/lclextensions/tests/settimer/project1.lpr
Executable file
@ -0,0 +1,20 @@
|
|||||||
|
program project1;
|
||||||
|
|
||||||
|
{$mode objfpc}{$H+}
|
||||||
|
|
||||||
|
uses
|
||||||
|
{$IFDEF UNIX}{$IFDEF UseCThreads}
|
||||||
|
cthreads,
|
||||||
|
{$ENDIF}{$ENDIF}
|
||||||
|
Interfaces, // this includes the LCL widgetset
|
||||||
|
Forms
|
||||||
|
{ add your units here }, Unit1, lclextensions_package;
|
||||||
|
|
||||||
|
{$R *.res}
|
||||||
|
|
||||||
|
begin
|
||||||
|
Application.Initialize;
|
||||||
|
Application.CreateForm(TMainForm, MainForm);
|
||||||
|
Application.Run;
|
||||||
|
end.
|
||||||
|
|
||||||
Reference in New Issue
Block a user