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