mirrors/doublecmd
2
0
Fork 0
mirror of https://github.com/doublecmd/doublecmd.git synced 2026-06-21 09:58:13 +00:00
Code Issues Projects Releases Packages Wiki Activity

ADD: Alternative implementation of columns file view based on Virtual Tree View. To test need to add lclextensions, virtualtreeview packages and build with -dCOLUMNSFILEVIEW_VTV.

Browse source
This commit is contained in:
cobines 2012-03-13 02:54:14 +00:00
commit 1bf0d33905
84 changed files with 55585 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

168
components/lclextensions/delphicompat.pas Normal file
View 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, LCLType, Classes, 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: LongWord) 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: LongWord):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:LongWord; uElapse:LongWord; lpTimerFunc:TTimerNotify): LongWord;
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 Normal file
View 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: LongWord):Boolean;
begin
Result := LCLIntf.KillTimer(hWnd, nIDEvent);
end;
function SetTimer(hWnd: THandle; nIDEvent: LongWord; uElapse: LongWord; lpTimerFunc: TTimerNotify): LongWord;
begin
Result := LCLIntf.SetTimer(hWnd, nIDEvent, uElapse, nil{lpTimerFunc});
end;

24
components/lclextensions/include/carbon/lclext.inc Normal file
View 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 Normal file
View file

@ -0,0 +1 @@
InterfaceBase, LCLIntf, Graphics, CarbonInt, CarbonCanvas, Math,

2
components/lclextensions/include/carbon/uses_lclext.inc Normal file
View file

@ -0,0 +1,2 @@
uses
LclIntf;

17
components/lclextensions/include/generic/independentfunctions.inc Normal file
View file

@ -0,0 +1,17 @@
{$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}

171
components/lclextensions/include/generic/stubs.inc Normal file
View file

@ -0,0 +1,171 @@
function BeginDeferWindowPos(nNumWindows:longint):THandle;
begin
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
function CopyImage(hImage:THANDLE; uType:LongWord; cxDesired, cyDesired: LongInt; fuFlags:LongWord):THandle;
begin
{$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
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
function EndDeferWindowPos(hWinPosInfo:THandle):Boolean;
begin
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
function GdiFlush: Boolean;
begin
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
function GetACP:LongWord;
begin
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
{$ifndef HAS_GETBKCOLOR}
function GetBkColor(DC:HDC):COLORREF;
begin
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
{$endif}
{$ifndef HAS_GETCURRENTOBJECT}
function GetCurrentObject(hdc: HDC; uObjectType: UINT): HGDIOBJ;
begin
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
{$endif}
function GetDCEx(hWnd:THandle; hrgnClip:HRGN; flags:DWORD):HDC;
begin
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
function GetKeyboardLayout(dwLayout:DWORD):THandle;
begin
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
function GetKeyboardState(lpKeyState: System.PByte):BOOLEAN;
begin
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
function GetLocaleInfo(Locale, LCType:LongWord; lpLCData:PChar; cchData:longint):longint;
begin
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
{$if lcl_release < 29}
function GetMapMode(DC: HDC): LongInt;
begin
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
{$endif}
function GetRandomRgn(DC: HDC; Rgn: HRGN; iNum: Integer): Integer; stdcall;
begin
{$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
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
{$endif}
{$ifndef HAS_GETTEXTALIGN}
function GetTextAlign(hDC:HDC): LongWord;
begin
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
{$endif}
{$ifndef HAS_GETWINDOWDC}
function GetWindowDC(hWnd:THandle):HDC;
begin
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
{$endif}
function ImageList_DragShowNolock(fShow: Boolean): Boolean;
begin
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
{$ifndef HAS_INVERTRECT}
function InvertRect(DC: HDC; const lprc: TRect): Boolean;
begin
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
{$endif}
function MapWindowPoints(hWndFrom, hWndTo: HWND; var lpPoints; cPoints: UINT): Integer;
begin
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
function MultiByteToWideChar(CodePage, dwFlags:DWORD; lpMultiByteStr:PChar; cchMultiByte:longint; lpWideCharStr:PWideChar;cchWideChar:longint):longint;
begin
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
{$ifndef HAS_OFFSETRGN}
function OffsetRgn(hrgn:HRGN; nxOffset, nYOffset:longint):longint;
begin
{$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
{$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
{$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
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
{$endif}
{$if lcl_release < 29}
function SetMapMode(DC: HDC; fnMapMode: LongInt): LongInt;
begin
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
{$endif}
function SubtractRect(var lprcDst: TRect; const lprcSrc1, lprcSrc2: TRect): BOOLEAN;
begin
{$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
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
function UpdateWindow(Handle: HWND): Boolean;
begin
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;

8
components/lclextensions/include/generic/timerfunctions.inc Normal file
View 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 Normal file
View 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 Normal file
View 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 Normal file
View 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 Normal file
View file

@ -0,0 +1,3 @@
LCLIntf, Graphics, gtkdef, gdk, GTKProc, GtkInt, glib, gtk, Math,

2
components/lclextensions/include/gtk/uses_lclext.inc Normal file
View file

@ -0,0 +1,2 @@
uses
GtkInt;

316
components/lclextensions/include/gtk2/delphicompat.inc Normal file
View file

@ -0,0 +1,316 @@
{ 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_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
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): gBoolean; 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 := g_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]);
g_source_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;

22
components/lclextensions/include/gtk2/lclext.inc Normal file
View 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 Normal file
View file

@ -0,0 +1,2 @@
LCLIntf, Graphics, Gtk2Def, gdk2, gtk2, Gtk2Proc, Gtk2Int, pango, glib2, math,

2
components/lclextensions/include/gtk2/uses_lclext.inc Normal file
View file

@ -0,0 +1,2 @@
uses
Gtk2Int;

425
components/lclextensions/include/qt/delphicompat.inc Normal file
View file

@ -0,0 +1,425 @@
{
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;
var
lbearing, rbearing, ascent, descent: LongInt;
IsDBCSFont: Boolean;
NewCount, Accumulator, i: Integer;
AStr: WideString;
begin
//based in lcl code
Result := QtWidgetSet.IsValidDC(DC);
if Result then
with TQtDeviceContext(DC) do
begin
AStr := WideString(Str);
Ascent := Font.Metrics.ascent;
Descent := Font.Metrics.descent;
Size.cX := Font.Metrics.width(@AStr, Count);
Size.cY := Ascent + Descent;
if PartialWidths <> nil then
begin
Accumulator := 0;
for i:= 0 to Count - 1 do
begin
Inc(Accumulator, QFontMetrics_width(Font.Metrics.Widget, PWideChar((Str+i))));
PartialWidths[i] := Accumulator;
end;
end;
end;
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.Widget;
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.Widget, nxOffset, nYOffset);
Result := Region.GetRegionType;
end;
function RedrawWindow(hWnd:THandle; lprcUpdate:PRECT; hrgnUpdate:HRGN; flags:LongWord):BOOLEAN;
var
QtWidget: TQtWidget absolute hWnd;
Region: TQtRegion absolute hrgnUpdate;
begin
{TODO: Check msdn docs for flags ... this implementation could raise AV !}
if (lprcUpdate = nil) and (hrgnUpdate = 0) then
QWidget_update(QtWidget.Widget)
else
begin
if lprcUpdate <> nil then
InvalidateRect(hWnd, lprcUpdate, False)
else
QWidget_update(QtWidget.Widget, Region.Widget);
end;
end;
function ScrollWindow(hWnd:THandle; XAmount, YAmount:longint;lpRect:PRECT; lpClipRect:PRECT): Boolean;
begin
if hWnd = 0 then
Exit;
QWidget_scroll(TQtWidget(hWnd).Widget, XAmount, YAmount, lpRect);
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
{ TQtTimerEx }
TQtTimerEx = class(TQtObject)
private
FTimerHook: QTimer_hookH;
FCallbackFunc: TTimerNotify;
FUserId: LongWord;
FControl: TControl;
FAppObject: QObjectH;
public
constructor Create(TimerFunc: TTimerNotify;
UserId: LongWord; Control: TControl); virtual;
destructor Destroy; override;
procedure AttachEvents; override;
procedure DetachEvents; override;
procedure signalTimeout; cdecl;
public
function EventFilter(Sender: QObjectH; Event: QEventH): Boolean; cdecl; override;
procedure Reset(TimerFunc: TTimerNotify; UserId: LongWord; Control: TControl);
procedure Start(Interval: Integer);
procedure Stop;
end;
{ TTimerList }
TTimerList = class
private
FMap: TMap;
public
constructor Create;
destructor Destroy; override;
function Add(hWnd: THandle; ID: LongWord; NotifyFunc: TTimerNotify;
WinControl: TControl): TQtTimerEx;
function GetTimerObject(hWnd: THandle; ID: LongWord): TQtTimerEx;
end;
TQtWidgetSetHack = Class(TWidgetSet)
private
App: QApplicationH;
end;
{ TQtTimerEx }
constructor TQtTimerEx.Create(TimerFunc: TTimerNotify;
UserId: LongWord; Control: TControl);
var
AName: WideString;
begin
inherited Create;
FDeleteLater := True;
FAppObject := TQtWidgetSetHack(QtWidgetSet).App;
FCallbackFunc := TimerFunc;
FUserId := UserId;
FControl := Control;
//very big ultra extreme hack to get the app from QtWidgetset
TheObject := QTimer_create(FAppObject);
AName := 'tqttimerex';
QObject_setObjectName(TheObject, @AName);
AttachEvents;
end;
destructor TQtTimerEx.Destroy;
begin
FCallbackFunc := nil;
FControl := nil;
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.signalTimeout; cdecl;
var
FCheckHandle: Boolean;
begin
if Assigned(FCallbackFunc) then
FCallbackFunc(FUserID)
else
if Assigned(FControl) then
begin
if not (csLoading in FControl.ComponentState) then
if not (csDestroying in FControl.ComponentState) or not
(csDestroyingHandle in FControl.ControlState) then
begin
FCheckHandle := True;
LCLSendTimerMsg(FControl, FUserId, 0);
end;
end;
end;
function TQtTimerEx.EventFilter(Sender: QObjectH; Event: QEventH): Boolean; cdecl;
begin
Result := False;
QEvent_accept(Event);
end;
procedure TQtTimerEx.Reset(TimerFunc: TTimerNotify;
UserId: LongWord; Control: TControl);
begin
FControl := Control;
FCallbackFunc := TimerFunc;
FUserId := UserId;
end;
procedure TQtTimerEx.Start(Interval: Integer);
begin
QTimer_start(QTimerH(TheObject), Interval);
end;
procedure TQtTimerEx.Stop;
begin
QTimer_stop(QTimerH(TheObject));
end;
var
FTimerList: TTimerList;
function MakeQWord(d1, d2: dword): QWord; inline;
begin
Result := (QWord(d2) shl 32) or d1;
end;
function KillTimer(hWnd: THandle; nIDEvent: LongWord):Boolean;
var
TimerObject: TQtTimerEx;
begin
TimerObject := FTimerList.GetTimerObject(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: LongWord; uElapse: LongWord; lpTimerFunc: TTimerNotify): LongWord;
var
Control: TControl;
TimerObject: TQtTimerEx;
begin
if hWnd <> 0 then
Control := FindControl(hWnd)
else
Control := nil;
TimerObject := FTimerList.Add(hWnd, nIDEvent, lpTimerFunc, Control);
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.Add(hWnd: THandle; ID: LongWord; NotifyFunc: TTimerNotify; WinControl: TControl): TQtTimerEx;
var
AID: QWord;
begin
AID := MakeQWord(hWnd, ID);
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.Reset(NotifyFunc, ID, WinControl);
end
else
begin
// DebugLn('Create timer for HWnd: %d ID: %d AID: %d', [hWnd, ID, AID]);
Result := TQtTimerEx.Create(NotifyFunc, ID, WinControl);
Add(AID, Result);
end;
end;
end;
constructor TTimerList.Create;
begin
//todo: handle 64bit
FMap := TMap.Create(itu8, 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;
function TTimerList.GetTimerObject(hWnd: THandle; ID: LongWord): TQtTimerEx;
var
DataPtr: ^TQtTimerEx;
AID: QWord;
begin
Result := nil;
AID := MakeQWord(hWnd, ID);
// DebugLn('GetTimerObject for HWnd: %d ID: %d AID: %d', [hWnd, ID, AID]);
DataPtr := FMap.GetDataPtr(AID);
if DataPtr <> nil then
Result := DataPtr^;
end;

24
components/lclextensions/include/qt/lclext.inc Normal file
View 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 Normal file
View file

@ -0,0 +1 @@
InterfaceBase, LCLIntf, Graphics, qt4, qtint, qtobjects, qtwidgets, Math,

2
components/lclextensions/include/qt/uses_lclext.inc Normal file
View file

@ -0,0 +1,2 @@
uses
LclIntf;

371
components/lclextensions/include/win32/delphicompat.inc Normal file
View file

@ -0,0 +1,371 @@
{ 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
TTimerRecord = record
Control: TControl;
Notify: TTimerNotify;
end;
PTimerRecord = ^TTimerRecord;
{ TTimerList }
TTimerList = class
private
FList: TMap;
public
constructor Create;
destructor Destroy; override;
procedure Add(hWnd: THandle; ID: LongWord; NotifyFunc: TTimerNotify; WinControl: TControl);
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;
procedure TTimerList.Add(hWnd: THandle; ID: LongWord; NotifyFunc: TTimerNotify; WinControl: TControl);
var
AID: QWord;
ATimerRec: TTimerRecord;
begin
ATimerRec.Notify := NotifyFunc;
ATimerRec.Control := WinControl;
AId := MakeQWord(hWnd,ID);
with FList do
begin
if HasId(AID) then
SetData(AID, ATimerRec)
else
Add(AID, ATimerRec);
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;
procedure TimerCallBack(Handle: hwnd; Msg : DWORD; idEvent: UINT; 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:LongWord; uElapse:LongWord; lpTimerFunc:TTimerNotify):LongWord;
var
WinInfo: PWin32WindowInfo;
begin
WinInfo := GetWin32WindowInfo(hWnd);
FTimerList.Add(hWnd,nIDEvent,lpTimerFunc,WinInfo^.WinControl);
//todo: see the best way to set result when handle is 0
Result := Windows.SetTimer(hWnd,nIDEvent,uElapse,@TimerCallBack);
//DebugLn('SetTimer - Handle %d - ID: %d - Result: %d',[hWnd,nIDEvent,Result]);
end;
function KillTimer(hWnd:THandle; nIDEvent: LongWord):Boolean;
begin
Result := Windows.KillTimer(hWnd,nIDEvent);
//DebugLn('KillTimer - Handle %d - ID: %d',[hWnd,nIDEvent]);
end;

61
components/lclextensions/include/win32/lclext.inc Normal file
View 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 Normal file
View file

@ -0,0 +1,3 @@
Windows, win32proc, CommCtrl,

2
components/lclextensions/include/win32/uses_lclext.inc Normal file
View file

@ -0,0 +1,2 @@
uses
Windows;

58
components/lclextensions/lclext.pas Normal file
View 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.

64
components/lclextensions/lclextensions_package.lpk Normal file
View file

@ -0,0 +1,64 @@
<?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="10"/>
<SearchPaths>
<IncludeFiles Value="include/$(LCLWidgetType)"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)-$(LCLWidgetType)"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<UseAnsiStrings Value="False"/>
</SyntaxOptions>
</Parsing>
<Linking>
<Debugging>
<GenerateDebugInfo Value="True"/>
<DebugInfoType Value="dsDwarf2Set"/>
</Debugging>
</Linking>
<Other>
<CompilerMessages>
<UseMsgFile Value="True"/>
</CompilerMessages>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Description Value="LCL Extensions provides additional functions to be used together with LCL
"/>
<License Value="Modified LGPL
"/>
<Version Minor="4"/>
<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 Normal file
View 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 Normal file
View 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.

3
components/lclextensions/readme.txt Normal file
View file

@ -0,0 +1,3 @@
lclextensions v0.4
http://code.google.com/p/luipack/

674
components/virtualtreeview/VTAccessibility.pas Normal file
View file

@ -0,0 +1,674 @@
unit VTAccessibility;
// This unit implements iAccessible interfaces for the VirtualTree visual components
// and the currently focused node.
//
// Written by Marco Zehe. (c) 2007
interface
uses Windows, Classes, ActiveX, oleacc, VirtualTrees, VTAccessibilityFactory, Controls;
type
TVirtualTreeAccessibility = class(TInterfacedObject, IDispatch, IAccessible)
private
FVirtualTree: TVirtualStringTree;
public
{ IAccessibility }
function Get_accParent(out ppdispParent: IDispatch): HResult; stdcall;
function Get_accChildCount(out pcountChildren: Integer): HResult; stdcall;
function Get_accChild(varChild: OleVariant; out ppdispChild: IDispatch): HResult; stdcall;
function Get_accName(varChild: OleVariant; out pszName: WideString): HResult; stdcall;
function Get_accValue(varChild: OleVariant; out pszValue: WideString): HResult; stdcall;
function Get_accDescription(varChild: OleVariant; out pszDescription: WideString): HResult; stdcall;
function Get_accRole(varChild: OleVariant; out pvarRole: OleVariant): HResult; stdcall;
function Get_accState(varChild: OleVariant; out pvarState: OleVariant): HResult; stdcall;
function Get_accHelp(varChild: OleVariant; out pszHelp: WideString): HResult; stdcall;
function Get_accHelpTopic(out pszHelpFile: WideString; varChild: OleVariant;
out pidTopic: Integer): HResult; stdcall;
function Get_accKeyboardShortcut(varChild: OleVariant; out pszKeyboardShortcut: WideString): HResult; stdcall;
function Get_accFocus(out pvarChild: OleVariant): HResult; stdcall;
function Get_accSelection(out pvarChildren: OleVariant): HResult; stdcall;
function Get_accDefaultAction(varChild: OleVariant; out pszDefaultAction: WideString): HResult; stdcall;
function accSelect(flagsSelect: Integer; varChild: OleVariant): HResult; stdcall;
function accLocation(out pxLeft: Integer; out pyTop: Integer; out pcxWidth: Integer;
out pcyHeight: Integer; varChild: OleVariant): HResult; stdcall;
function accNavigate(navDir: Integer; varStart: OleVariant; out pvarEndUpAt: OleVariant): HResult; stdcall;
function accHitTest(xLeft: Integer; yTop: Integer; out pvarChild: OleVariant): HResult; stdcall;
function accDoDefaultAction(varChild: OleVariant): HResult; stdcall;
function Set_accName(varChild: OleVariant; const pszName: WideString): HResult; stdcall;
function Set_accValue(varChild: OleVariant; const pszValue: WideString): HResult; stdcall;
{IDispatch}
function GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount: Integer; LocaleID: Integer; DispIDs: Pointer): HRESULT; stdcall;
function GetTypeInfo(Index: Integer; LocaleID: Integer;
out TypeInfo): HRESULT; stdcall;
function GetTypeInfoCount(out Count: Integer): HRESULT; stdcall;
function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult: Pointer; ExcepInfo: Pointer;
ArgErr: Pointer): HRESULT; stdcall;
constructor Create(VirtualTree: TVirtualStringTree);
end;
TVirtualTreeItemAccessibility = class(TVirtualTreeAccessibility, IAccessible)
public
{ IAccessibility }
function Get_accParent(out ppdispParent: IDispatch): HResult; stdcall;
function Get_accChildCount(out pcountChildren: Integer): HResult; stdcall;
function Get_accChild(varChild: OleVariant; out ppdispChild: IDispatch): HResult; stdcall;
function Get_accName(varChild: OleVariant; out pszName: WideString): HResult; stdcall;
function Get_accValue(varChild: OleVariant; out pszValue: WideString): HResult; stdcall;
function Get_accDescription(varChild: OleVariant; out pszDescription: WideString): HResult; stdcall;
function Get_accRole(varChild: OleVariant; out pvarRole: OleVariant): HResult; stdcall;
function Get_accState(varChild: OleVariant; out pvarState: OleVariant): HResult; stdcall;
function accLocation(out pxLeft: Integer;
out pyTop: Integer; out pcxWidth: Integer;
out pcyHeight: Integer; varChild: OleVariant): HResult; stdcall;
constructor Create(VirtualTree: TVirtualStringTree);
end;
TVTMultiColumnItemAccessibility = class(TVirtualTreeItemAccessibility, IAccessible)
private
function GetItemDescription(varChild: OleVariant; out pszDescription: WideString; IncludeMainColumn: boolean): HResult; stdcall;
public
{ IAccessibility }
function Get_accName(varChild: OleVariant; out pszName: WideString): HResult; stdcall;
function Get_accDescription(varChild: OleVariant; out pszDescription: WideString): HResult; stdcall;
end;
TVTDefaultAccessibleProvider = class(TInterfacedObject, IVTAccessibleProvider)
function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible;
end;
TVTDefaultAccessibleItemProvider = class(TInterfacedObject, IVTAccessibleProvider)
function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible;
end;
TVTMultiColumnAccessibleItemProvider = class(TInterfacedObject, IVTAccessibleProvider)
function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible;
end;
implementation
uses Variants, SysUtils, Types, Forms;
{ TVirtualTreeAccessibility }
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.accDoDefaultAction(varChild: OleVariant): HResult;
// a default action is not supported.
begin
Result := DISP_E_MEMBERNOTFOUND;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.accHitTest(xLeft: Integer; yTop: Integer; out pvarChild: OleVariant): HResult;
// returns the iAccessible object at the given point, if applicable.
var
Pt: TPoint;
HitInfo: THitInfo;
begin
Result := S_FALSE;
if FVirtualTree <> nil then
begin
// VariantInit(pvarChild);
// TVarData(pvarChild).VType := VT_I4;
Pt := fVirtualTree.ScreenToClient(Point(xLeft, yTop));
if fVirtualTree.FocusedNode <> nil then
begin
fVirtualTree.GetHitTestInfoAt(xLeft, yTop, false, HitInfo);
if FVirtualTree.FocusedNode = HitInfo.HitNode then
begin
pvarChild := FVirtualTree.AccessibleItem;
Result := S_OK;
exit;
end;
end;
if PtInRect(FVirtualTree.BoundsRect, Pt) then
begin
pvarChild := CHILDID_SELF;
Result := S_OK;
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.accLocation(out pxLeft: Integer;
out pyTop: Integer; out pcxWidth: Integer;
out pcyHeight: Integer; varChild: OleVariant): HResult;
// returns the location of the VirtualStringTree object.
var
P: TPoint;
begin
Result := S_FALSE;
if varChild = CHILDID_SELF then
begin
if FVirtualTree <> nil then
begin
P := FVirtualTree.ClientToScreen(FVirtualTree.ClientRect.TopLeft);
pxLeft := P.X;
pyTop := P.Y;
pcxWidth := FVirtualTree.Width;
pcyHeight := FVirtualTree.Height;
Result := S_OK;
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.accNavigate(navDir: Integer; varStart: OleVariant;
out pvarEndUpAt: OleVariant): HResult;
// This is not supported.
begin
Result := DISP_E_MEMBERNOTFOUND;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Get_accSelection(out pvarChildren: OleVariant): HResult;
// returns the selected child ID, if any.
begin
Result := s_false;
if FVirtualTree <> nil then
if fVirtualTree.FocusedNode <> nil then
begin
pvarChildren := 1;
result := s_OK;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
constructor TVirtualTreeAccessibility.Create(VirtualTree: TVirtualStringTree);
// assigns the parent and current fields, and lets the control's iAccessible object know its address.
begin
fVirtualTree := VirtualTree;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.GetIDsOfNames(const IID: TGUID;
Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HRESULT;
// Not supported.
begin
Result := E_NOTIMPL;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.GetTypeInfo(Index, LocaleID: Integer;
out TypeInfo): HRESULT;
// not supported.
begin
Result := E_NOTIMPL;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.GetTypeInfoCount(
out Count: Integer): HRESULT;
// not supported.
begin
Result := E_NOTIMPL;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Get_accChild(varChild: OleVariant; out ppdispChild: IDispatch): HResult;
// returns the iAccessible child, whicfh represents the focused item.
begin
if varChild = CHILDID_SELF then
begin
ppdispChild := FVirtualTree.AccessibleItem;
Result := S_OK;
end
else
Result := E_INVALIDARG
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Get_accChildCount(out pcountChildren: Integer): HResult;
// Returns the number 1 for the one child: The focused item.
begin
pcountChildren := 1;
Result := S_OK;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Get_accDefaultAction(varChild: OleVariant; out pszDefaultAction: WideString): HResult;
// Not supported.
begin
Result := DISP_E_MEMBERNOTFOUND;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Get_accDescription(varChild: OleVariant; out pszDescription: WideString): HResult;
// returns the hint of the control, if assigned.
begin
pszDescription := '';
Result := S_FALSE;
if varChild = CHILDID_SELF then
begin
if FVirtualTree <> nil then
pszDescription := GetLongHint(fVirtualTree.Hint);
end;
if Length(pszDescription) > 0 then
Result := S_OK;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Get_accFocus(out pvarChild: OleVariant): HResult;
// returns the child ID of 1, if assigned.
begin
Result := s_false;
if fVirtualTree <> nil then
begin
if FVirtualTree.FocusedNode <> nil then
begin
pvarChild := fVirtualTree.AccessibleItem;
result := s_OK;
end
else begin
pvarChild := childid_self;
result := S_OK;
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Get_accHelp(varChild: OleVariant; out pszHelp: WideString): HResult;
// Not supported.
begin
Result := DISP_E_MEMBERNOTFOUND;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Get_accHelpTopic(out pszHelpFile: WideString; varChild: OleVariant;
out pidTopic: Integer): HResult;
// Returns the HelpContext ID, if present.
begin
pszHelpFile := '';
pidTopic := 0;
Result := S_OK;
if varChild = CHILDID_SELF then
if FVirtualTree <> nil then
begin
pszHelpFile := Application.HelpFile;
pidTopic := FVirtualTree.HelpContext;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Get_accKeyboardShortcut(varChild: OleVariant; out pszKeyboardShortcut: WideString): HResult;
// Not supported.
begin
pszKeyboardShortcut := '';
Result := S_FALSE;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Get_accName(varChild: OleVariant; out pszName: WideString): HResult;
// if set, returns the new published AccessibleName property.
// otherwise, returns the default text.
begin
pszName := '';
Result := S_FALSE;
if varChild = CHILDID_SELF then
begin
if FVirtualTree <> nil then
begin
if FVirtualTree.AccessibleName <> '' then
pszName := FVirtualTree.AccessibleName
else
PSZName := FVirtualTree.DefaultText;
result := S_OK;
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Get_accParent(out ppdispParent: IDispatch): HResult;
// Returns false, the tree itself does not have a parent.
begin
ppdispParent := nil;
Result := S_FALSE;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Get_accRole(varChild: OleVariant; out pvarRole: OleVariant): HResult;
// tells MSAA that it is a TreeView.
begin
Result := S_OK;
// VariantInit(pvarRole);
// TVarData(pvarRole).VType := VT_I4;
if varChild = CHILDID_SELF then
begin
if FVirtualTree <> nil then
pvarRole := ROLE_SYSTEM_OUTLINE
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.accSelect(flagsSelect: Integer; varChild: OleVariant): HResult;
// since we're not supporting more than one item, this is not supported currently.
begin
Result := DISP_E_MEMBERNOTFOUND;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Get_accState(varChild: OleVariant; out pvarState: OleVariant): HResult;
// returns the state of the control.
const
IsEnabled: array[Boolean] of Integer = (STATE_SYSTEM_UNAVAILABLE, 0);
HasPopup: array[Boolean] of Integer = (0, STATE_SYSTEM_HASPOPUP);
IsVisible: array[Boolean] of Integer = (STATE_SYSTEM_INVISIBLE, 0);
begin
Result := S_OK;
// VariantInit(pvarState);
// TVarData(pvarState).VType := VT_I4;
if varChild = CHILDID_SELF then
begin
if FVirtualTree <> nil then
begin
pvarState := STATE_SYSTEM_FOCUSED or STATE_SYSTEM_FOCUSABLE or STATE_SYSTEM_HOTTRACKED;
pvarState := pvarState or IsVisible[FVirtualTree.Visible];
pvarState := pvarState or IsEnabled[FVirtualTree.Enabled];
end
else
Result := E_INVALIDARG;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Get_accValue(varChild: OleVariant; out pszValue: WideString): HResult;
// the TreeView control itself does not have a value, returning false here.
begin
pszValue := '';
Result := S_FALSE;//DISP_E_MEMBERNOTFOUND;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Invoke(DispID: Integer; const IID: TGUID;
LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
ArgErr: Pointer): HRESULT;
// not supported.
begin
Result := E_NOTIMPL;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Set_accName(varChild: OleVariant; const pszName: WideString): HResult; stdcall;
// not supported.
begin
Result := DISP_E_MEMBERNOTFOUND
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Set_accValue(varChild: OleVariant; const pszValue: WideString): HResult;
// not supported.
begin
Result := DISP_E_MEMBERNOTFOUND
end;
{ TVirtualTreeItemAccessibility }
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeItemAccessibility.accLocation(out pxLeft, pyTop, pcxWidth,
pcyHeight: Integer; varChild: OleVariant): HResult;
// returns the location of the current accessible item.
var
P: TPoint;
DisplayRect: TRect;
begin
Result := S_FALSE;
if varChild = CHILDID_SELF then
begin
if FVirtualTree.FocusedNode <> nil then
begin
DisplayRect := FVirtualTree.GetDisplayRect(FVirtualTree.FocusedNode, -1, TRUE, FALSE);
P := FVirtualTree.ClientToScreen(DisplayRect.TopLeft);
pxLeft := P.X;
pyTop := P.Y;
pcxWidth := DisplayRect.Right - DisplayRect.Left;
pcyHeight := DisplayRect.Bottom - DisplayRect.Top;
Result := S_OK;
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
constructor TVirtualTreeItemAccessibility.Create(VirtualTree: TVirtualStringTree);
// sets up the parent/child relationship.
begin
fVirtualTree := VirtualTree;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeItemAccessibility.Get_accChild(varChild: OleVariant; out ppdispChild: IDispatch): HResult;
// the item does not have children. Returning false.
begin
ppdispChild := nil;
Result := S_FALSE;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeItemAccessibility.Get_accChildCount(out pcountChildren: Integer): HResult;
// the item itself does not have children, returning 0.
begin
pcountChildren := 0;
Result := S_OK;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeItemAccessibility.Get_accDescription(varChild: OleVariant; out pszDescription: WideString): HResult;
// not supported for an item.
begin
Result := DISP_E_MEMBERNOTFOUND;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeItemAccessibility.Get_accName(varChild: OleVariant; out pszName: WideString): HResult;
// the name is the node's caption.
begin
pszName := '';
Result := S_FALSE;
if varChild = childid_self then
begin
if FVirtualTree <> nil then
if FVirtualTree.FocusedNode <> nil then
begin
pszName := FVirtualTree.Text[FVirtualTree.FocusedNode, FVirtualTree.Header.MainColumn];
result := S_OK;
end
else begin
PSZName := FVirtualTree.DefaultText;
result := S_OK;
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeItemAccessibility.Get_accParent(out ppdispParent: IDispatch): HResult;
// tells MSAA that the VritualStringTree is its parent.
begin
result := S_FALSE;
if FVirtualTree <> nil then
begin
ppdispParent := FVirtualTree.Accessible;
Result := S_OK;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeItemAccessibility.Get_accRole(varChild: OleVariant; out pvarRole: OleVariant): HResult;
// tells MSAA that it is a TreeView item as opposed to the TreeView itself.
begin
Result := S_OK;
// VariantInit(pvarRole);
// TVarData(pvarRole).VType := VT_I4;
if varChild = childid_self then
begin
if FVirtualTree <> nil then
pvarRole := ROLE_SYSTEM_OUTLINEITEM
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeItemAccessibility.Get_accState(varChild: OleVariant; out pvarState: OleVariant): HResult;
// Tells MSAA the state the item is in.
const
IsEnabled: array[Boolean] of Integer = (STATE_SYSTEM_UNAVAILABLE, 0);
HasPopup: array[Boolean] of Integer = (0, STATE_SYSTEM_HASPOPUP);
IsVisible: array[Boolean] of Integer = (STATE_SYSTEM_INVISIBLE, 0);
IsChecked: array[Boolean] of Integer = (0, STATE_SYSTEM_CHECKED);
IsExpanded: array[Boolean] of Integer = (0, STATE_SYSTEM_EXPANDED);
IsCollapsed: array[Boolean] of Integer = (0, STATE_SYSTEM_COLLAPSED);
begin
Result := S_OK;
// VariantInit(pvarState);
// TVarData(pvarState).VType := VT_I4;
if varChild = childid_self then
begin
if FVirtualTree <> nil then
begin
pvarState := STATE_SYSTEM_FOCUSED or STATE_SYSTEM_FOCUSABLE or STATE_SYSTEM_HOTTRACKED;
pvarState := pvarState or IsVisible[FVirtualTree.Visible];
pvarState := pvarState or IsEnabled[FVirtualTree.Enabled];
if fVirtualTree.FocusedNode <> nil then
begin
pvarState := pvarState or IsChecked[csCheckedNormal = FVirtualTree.FocusedNode.CheckState];
pvarState := pvarState or IsExpanded[VSExpanded in FVirtualTree.FocusedNode.States];
if not (vsExpanded in FVirtualTree.FocusedNode.States) then
pvarState:= PvarState or IsCollapsed[vsHasChildren in FVirtualTree.FocusedNode.States];
end;
end
else
Result := E_INVALIDARG;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeItemAccessibility.Get_accValue(varChild: OleVariant; out pszValue: WideString): HResult;
// for a TreeView item, the value is the nesting level number, 0-based.
begin
pszValue := '';
Result := S_FALSE;//DISP_E_MEMBERNOTFOUND;
if varChild = childid_self then
if FVirtualTree <> nil then
if FVirtualTree.FocusedNode <> nil then
begin
PSZValue := IntToStr(FVirtualTree.GetNodeLevel(FVirtualTree.FocusedNode));
result := S_OK;
end;
end;
{ TVTMultiColumnItemAccessibility }
function TVTMultiColumnItemAccessibility.GetItemDescription(
varChild: OleVariant; out pszDescription: WideString;
IncludeMainColumn: boolean): HResult;
var
I: Integer;
sTemp: WideString;
begin
pszDescription := '';
Result := S_FALSE;
if varChild = childid_self then
begin
if FVirtualTree <> nil then
if FVirtualTree.FocusedNode <> nil then
begin
if IncludeMainColumn then
pszDescription := FVirtualTree.Text[FVirtualTree.FocusedNode, FVirtualTree.Header.MainColumn]
+'; ';
for I := 0 to FVirtualTree.Header.Columns.Count - 1 do
if FVirtualTree.Header.MainColumn <> I then
begin
sTemp := FVirtualTree.Text[FVirtualTree.FocusedNode, I];
if sTemp <> '' then
pszDescription := pszDescription
+FVirtualTree.Header.Columns[I].Text
+': '
+sTemp
+'; ';
end;
if pszDescription <> '' then
if pszDescription[Length(pszDescription)-1] = ';' then
Delete(pszDescription, length(pszDescription)-1, 2);
result := S_OK;
end
else begin
PSZDescription := FVirtualTree.DefaultText;
result := S_OK;
end;
end;
end;
function TVTMultiColumnItemAccessibility.Get_accDescription(
varChild: OleVariant; out pszDescription: WideString): HResult;
begin
result := GetItemDescription(varChild, pszDescription, false)
end;
function TVTMultiColumnItemAccessibility.Get_accName(varChild: OleVariant;
out pszName: WideString): HResult;
begin
result := GetItemDescription(varChild, pszName, true)
end;
{ TVTDefaultAccessibleProvider }
function TVTDefaultAccessibleProvider.CreateIAccessible(
ATree: TBaseVirtualTree): IAccessible;
begin
result := TVirtualTreeAccessibility.Create(TVirtualStringTree(ATree));
end;
{ TVTDefaultAccessibleItemProvider }
function TVTDefaultAccessibleItemProvider.CreateIAccessible(
ATree: TBaseVirtualTree): IAccessible;
begin
result := TVirtualTreeItemAccessibility.Create(TVirtualStringTree(ATree));
end;
{ TVTMultiColumnAccessibleItemProvider }
function TVTMultiColumnAccessibleItemProvider.CreateIAccessible(
ATree: TBaseVirtualTree): IAccessible;
begin
result := nil;
if TVirtualStringTree(ATree).Header.UseColumns then
result := TVTMultiColumnItemAccessibility.Create(TVirtualStringTree(ATree));
end;
var
IDefaultAccessibleProvider: TVTDefaultAccessibleProvider;
IDefaultAccessibleItemProvider: TVTDefaultAccessibleItemProvider;
IMultiColumnAccessibleProvider: TVTMultiColumnAccessibleItemProvider;
initialization
if VTAccessibleFactory = nil then
VTAccessibleFactory := TVTAccessibilityFactory.Create;
if IDefaultAccessibleProvider = nil then
begin
IDefaultAccessibleProvider := TVTDefaultAccessibleProvider.Create;
VTAccessibleFactory.RegisterAccessibleProvider(IDefaultAccessibleProvider);
end;
if IDefaultAccessibleItemProvider = nil then
begin
IDefaultAccessibleItemProvider := TVTDefaultAccessibleItemProvider.Create;
VTAccessibleFactory.RegisterAccessibleProvider(IDefaultAccessibleItemProvider);
end;
if IMultiColumnAccessibleProvider = nil then
begin
IMultiColumnAccessibleProvider := TVTMultiColumnAccessibleItemProvider.Create;
VTAccessibleFactory.RegisterAccessibleProvider(IMultiColumnAccessibleProvider);
end;
finalization
if VTAccessibleFactory <> nil then
begin
VTAccessibleFactory.UnRegisterAccessibleProvider(IMultiColumnAccessibleProvider);
IMultiColumnAccessibleProvider := nil;
VTAccessibleFactory.UnRegisterAccessibleProvider(IDefaultAccessibleItemProvider);
IDefaultAccessibleItemProvider := nil;
VTAccessibleFactory.UnRegisterAccessibleProvider(IDefaultAccessibleProvider);
IDefaultAccessibleProvider := nil;
end;
end.

123
components/virtualtreeview/VTAccessibilityFactory.pas Normal file
View file

@ -0,0 +1,123 @@
unit VTAccessibilityFactory;
// class to create IAccessibles for the tree passed into it.
// If not already assigned, creates IAccessibles for the tree itself
// and the focused item
// the tree accessible is returned when the tree receives an WM_GETOBJECT message
// the AccessibleItem is returned when the Accessible is being asked for the first child
// To create your own IAccessibles, use the VTStandardAccessible unit as a reference,
// and assign your Accessibles to the variables in tthe unit's initialization.
// You only need to add the unit to your project, and voilá, you have an accessible string tree!
//
// Written by Marco Zehe. (c) 2007
interface
uses
Classes, oleacc, VirtualTrees;
type
IVTAccessibleProvider = interface
function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible;
end;
TVTAccessibilityFactory = class(TObject)
private
FAccessibleProviders: TInterfaceList;
public
constructor Create;
destructor Destroy; override;
function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible;
procedure RegisterAccessibleProvider(AProvider: IVTAccessibleProvider);
procedure UnRegisterAccessibleProvider(AProvider: IVTAccessibleProvider);
end;
var
VTAccessibleFactory: TVTAccessibilityFactory;
implementation
{ TVTAccessibilityFactory }
constructor TVTAccessibilityFactory.Create;
begin
inherited;
FAccessibleProviders := TInterfaceList.Create;
FAccessibleProviders.Clear;
end;
function TVTAccessibilityFactory.CreateIAccessible(
ATree: TBaseVirtualTree): IAccessible;
var
I: Integer;
TmpIAccessible: IAccessible;
// returns an IAccessible.
// 1. If the Accessible property of the passed-in tree is nil,
// the first registered element will be returned.
// Usually, this is the IAccessible that provides information about the tree itself.
// If it is not nil, we'll check whether the AccessibleItem is nil.
// If it is, we'll look in the registered IAccessibles for the appropriate one.
// Each IAccessibleProvider will check the tree for properties to determine whether it is responsible.
// We'll work top to bottom, from the most complicated to the most simple.
// The index for these should all be greater than 0, e g the IAccessible for the tree itself should always be registered first, then any IAccessible items.
begin
result := nil;
if ATree <> nil then
begin
if ATree.Accessible = nil then
begin
if FAccessibleProviders.Count > 0 then
begin
result := IVTAccessibleProvider(FAccessibleProviders.Items[0]).CreateIAccessible(ATree);
exit;
end;
end;
if ATree.AccessibleItem = nil then
begin
if FAccessibleProviders.Count > 0 then
begin
for I := FAccessibleProviders.Count - 1 downto 1 do
begin
TmpIAccessible := IVTAccessibleProvider(FAccessibleProviders.Items[I]).CreateIAccessible(ATree);
if TmpIAccessible <> nil then
begin
result := TmpIAccessible;
break;
end;
end;
if TmpIAccessible = nil then
begin
result := IVTAccessibleProvider(FAccessibleProviders.Items[0]).CreateIAccessible(ATree);
end;
end;
end
else begin
result := ATree.AccessibleItem;
end;
end;
end;
destructor TVTAccessibilityFactory.Destroy;
begin
FAccessibleProviders.Free;
FAccessibleProviders := nil;
inherited;
end;
procedure TVTAccessibilityFactory.RegisterAccessibleProvider(
AProvider: IVTAccessibleProvider);
// Ads a provider if it is not already registered
begin
if FAccessibleProviders.IndexOf(AProvider) < 0 then
FAccessibleProviders.Add(AProvider)
end;
procedure TVTAccessibilityFactory.UnRegisterAccessibleProvider(
AProvider: IVTAccessibleProvider);
// Unregisters/removes an IAccessible provider if it is present
begin
if FAccessibleProviders.IndexOf(AProvider) >= 0 then
FAccessibleProviders.Remove(AProvider);
end;
end.

46
components/virtualtreeview/VTConfig.inc Normal file
View file

@ -0,0 +1,46 @@
// Configuration file for VirtualTrees.pas (see www.soft-gems.net).
//
// The content of this file is public domain. You may do with it whatever you like, provided the header stays fully intact
// in all version and derivative work.
//
// The original code is VTConfig.inc, released October 5, 2004.
//
// The initial developer of the original code is Mike Lischke (public@soft-gems.net, www.soft-gems.net).
//----------------------------------------------------------------------------------------------------------------------
{.$define UseFlatScrollbars}
{.$define ReverseFullExpandHotKey} // Used to define Ctrl+'+' instead of Ctrl+Shift+'+' for full expand (and similar for collapsing).
// Enable this switch for Windows XP theme support. If you compile with Delphi 6 or lower you must download and install
// the Soft Gems Theme Manager package.
{.$define ThemeSupport}
// Virtual Treeview can use a tiny but very effective local memory manager for node allocation.
// The local memory manager was implemented by David Clark from Caelo Software Inc.
// See below for more info about it.
{.$define UseLocalMemoryManager}
//Lazarus port options
{.$define EnableOLE}
{.$define EnableNativeTVM}
{.$define EnablePrint}
{.$define EnableNCFunctions}
{$define EnableAdvancedGraphics}
{$define EnableAlphaBlend}
{.$define EnableAccessible}
{$define ThemeSupport}
{$if defined(LCLWin32) or defined(LCLWinCE)}
{$define LCLWin}
{$endif}
{.$define DEBUG_VTV}
{$define USE_DELPHICOMPAT}
//since
{$if not defined(USE_DELPHICOMPAT) and not defined(LCLWin)}
{$define INCOMPLETE_WINAPI}
{$endif}
//under linux the performance is poor with threading enabled
{$ifdef Windows}
{.$define EnableThreadSupport}
{$endif}

32
components/virtualtreeview/VTGraphics.pas Normal file
View file

@ -0,0 +1,32 @@
unit VTGraphics;
{$mode delphi}
interface
uses
DelphiCompat, Types, LCLIntf, LCLType;
type
// Describes the mode how to blend pixels.
TBlendMode = (
bmConstantAlpha, // apply given constant alpha
bmPerPixelAlpha, // use alpha value of the source pixel
bmMasterAlpha, // use alpha value of source pixel and multiply it with the constant alpha value
bmConstantAlphaAndColor // blend the destination color with the given constant color und the constant alpha value
);
procedure AlphaBlend(Source, Destination: HDC; const R: TRect; const Target: TPoint; Mode: TBlendMode; ConstantAlpha, Bias: Integer);
function CalculateScanline(Bits: Pointer; Width, Height, Row: Integer): Pointer;
function GetBitmapBitsFromBitmap(Bitmap: HBITMAP): Pointer;
implementation
{$i vtgraphicsi.inc}
end.

250
components/virtualtreeview/VTHeaderPopup.pas Normal file
View file

@ -0,0 +1,250 @@
unit VTHeaderPopup;
//----------------------------------------------------------------------------------------------------------------------
// The contents of this file are subject to the Mozilla Public License
// Version 1.1 (the "License"); you may not use this file except in
// compliance with the License. You may obtain a copy of the License at
// http://www.mozilla.org/MPL/
//
// Alternatively, you may redistribute this library, use and/or modify it under the terms of the
// GNU Lesser General Public License as published by the Free Software Foundation;
// either version 2.1 of the License, or (at your option) any later version.
// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/.
//
// Software distributed under the License is distributed on an "AS IS"
// basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
// License for the specific language governing rights and limitations
// under the License.
//
// The Original Code is VTHeaderPopup.pas.
//
// The Initial Developer of the Original Code is Ralf Junker <delphi@zeitungsjunge.de>. All Rights Reserved.
//
// September 2004:
// - Bug fix: TVTHeaderPopupMenu.OnMenuItemClick used the wrong Tag member for the event.
//
// Modified 12 Dec 2003 by Ralf Junker <delphi@zeitungsjunge.de>.
// - Added missing default storage specifier for Options property.
// - To avoid mixing up image lists of different trees sharing the same header
// popup, set the popup's image list to nil if hoShowImages is not in the
// tree's header options.
// - Added an additional check for the PopupComponent property before casting
// it hardly to a Virtual Treeview in OnMenuItemClick. See entry 31 Mar 2003.
//
// Modified 14 Sep 2003 by Mike Lischke <public@delphi-gems.com>.
// - Renamed event type name to be consistent with other event types (e.g. used in VT).
// - Added event for hiding/showing columns.
// - DoXXX method are now virtual.
// - Conditional code rearrangement to get back Ctrl+Shift+Up/Down navigation.
//
// Modified 31 Mar 2003 by Mike Lischke <public@soft-gems.net>.
// - Added a check for the PopupComponent property before casting it hardly to
// a Virtual Treeview. People might (accidentally) misuse the header popup.
//
// Modified 20 Oct 2002 by Borut Maricic <borut.maricic@pobox.com>.
// - Added the possibility to use Troy Wolbrink's Unicode aware popup menu.
// Define the compiler symbol TNT to enable it. You can get Troy's Unicode
// controls collection from http://home.ccci.org/wolbrink/tnt/delphi_unicode_controls.htm.
//
// Modified 24 Feb 2002 by Ralf Junker <delphi@zeitungsjunge.de>.
// - Fixed a bug where the OnAddHeaderPopupItem would interfere with
// poAllowHideAll options.
// - All column indexes now consistently use TColumnIndex (instead of Integer).
//
// Modified 23 Feb 2002 by Ralf Junker <delphi@zeitungsjunge.de>.
// - Added option to show menu items in the same order as the columns or in
// original order.
// - Added option to prevent the user to hide all columns.
//
// Modified 17 Feb 2002 by Jim Kueneman <jimdk@mindspring.com>.
// - Added the event to filter the items as they are added to the menu.
//----------------------------------------------------------------------------------------------------------------------
{$mode delphi}
interface
uses
{$ifdef TNT}
TntMenus,
{$else}
Menus,
{$endif TNT}
VirtualTrees;
type
TVTHeaderPopupOption = (
poOriginalOrder, // Show menu items in original column order as they were added to the tree.
poAllowHideAll // Allows to hide all columns, including the last one.
);
TVTHeaderPopupOptions = set of TVTHeaderPopupOption;
TAddPopupItemType = (
apNormal,
apDisabled,
apHidden
);
TAddHeaderPopupItemEvent = procedure(const Sender: TBaseVirtualTree; const Column: TColumnIndex;
var Cmd: TAddPopupItemType) of object;
TColumnChangeEvent = procedure(const Sender: TBaseVirtualTree; const Column: TColumnIndex; Visible: Boolean) of object;
{$ifdef TNT}
TVTMenuItem = TTntMenuItem;
{$else}
TVTMenuItem = TMenuItem;
{$endif}
{$ifdef TNT}
TVTHeaderPopupMenu = class(TTntPopupMenu)
{$else}
TVTHeaderPopupMenu = class(TPopupMenu)
{$endif}
private
FOptions: TVTHeaderPopupOptions;
FOnAddHeaderPopupItem: TAddHeaderPopupItemEvent;
FOnColumnChange: TColumnChangeEvent;
protected
procedure DoAddHeaderPopupItem(const Column: TColumnIndex; out Cmd: TAddPopupItemType); virtual;
procedure DoColumnChange(Column: TColumnIndex; Visible: Boolean); virtual;
procedure OnMenuItemClick(Sender: TObject);
public
procedure Popup(x, y: Integer); override;
published
property Options: TVTHeaderPopupOptions read FOptions write FOptions default [];
property OnAddHeaderPopupItem: TAddHeaderPopupItemEvent read FOnAddHeaderPopupItem write FOnAddHeaderPopupItem;
property OnColumnChange: TColumnChangeEvent read FOnColumnChange write FOnColumnChange;
end;
//----------------------------------------------------------------------------------------------------------------------
implementation
uses
{$ifdef TNT}
TnTClasses
{$else}
Classes
{$endif TNT};
type
TVirtualTreeCast = class(TBaseVirtualTree); // Necessary to make the header accessible.
//----------------- TVTHeaderPopupMenu ---------------------------------------------------------------------------------
procedure TVTHeaderPopupMenu.DoAddHeaderPopupItem(const Column: TColumnIndex; out Cmd: TAddPopupItemType);
begin
Cmd := apNormal;
if Assigned(FOnAddHeaderPopupItem) then
FOnAddHeaderPopupItem(TVirtualTreeCast(PopupComponent), Column, Cmd);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeaderPopupMenu.DoColumnChange(Column: TColumnIndex; Visible: Boolean);
begin
if Assigned(FOnColumnChange) then
FOnColumnChange(TVirtualTreeCast(PopupComponent), Column, Visible);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeaderPopupMenu.OnMenuItemClick(Sender: TObject);
begin
if Assigned(PopupComponent) and (PopupComponent is TBaseVirtualTree) then
with TVTMenuItem(Sender),
TVirtualTreeCast(PopupComponent).Header.Columns.Items[Tag] do
begin
if Checked then
Options := Options - [coVisible]
else
Options := Options + [coVisible];
DoColumnChange(TVTMenuItem(Sender).Tag, not Checked);
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeaderPopupMenu.Popup(x, y: Integer);
var
I: Integer;
ColPos: TColumnPosition;
ColIdx: TColumnIndex;
NewMenuItem: TVTMenuItem;
Cmd: TAddPopupItemType;
VisibleCounter: Cardinal;
VisibleItem: TVTMenuItem;
begin
if Assigned(PopupComponent) and (PopupComponent is TBaseVirtualTree) then
begin
// Delete existing menu items.
I := Items.Count;
while I > 0 do
begin
Dec(I);
Items[I].Free;
end;
// Add column menu items.
with TVirtualTreeCast(PopupComponent).Header do
begin
if hoShowImages in Options then
Self.Images := Images
else
// Remove a possible reference to image list of another tree previously assigned.
Self.Images := nil;
VisibleItem := nil;
VisibleCounter := 0;
for ColPos := 0 to Columns.Count - 1 do
begin
if poOriginalOrder in FOptions then
ColIdx := ColPos
else
ColIdx := Columns.ColumnFromPosition(ColPos);
with Columns[ColIdx] do
begin
if coVisible in Options then
Inc(VisibleCounter);
DoAddHeaderPopupItem(ColIdx, Cmd);
if Cmd <> apHidden then
begin
NewMenuItem := TVTMenuItem.Create(Self);
NewMenuItem.Tag := ColIdx;
NewMenuItem.Caption := Text;
NewMenuItem.Hint := Hint;
NewMenuItem.ImageIndex := ImageIndex;
NewMenuItem.Checked := coVisible in Options;
NewMenuItem.OnClick := OnMenuItemClick;
if Cmd = apDisabled then
NewMenuItem.Enabled := False
else
if coVisible in Options then
VisibleItem := NewMenuItem;
Items.Add(NewMenuItem);
end;
end;
end;
// Conditionally disable menu item of last enabled column.
if (VisibleCounter = 1) and (VisibleItem <> nil) and not (poAllowHideAll in FOptions) then
VisibleItem.Enabled := False;
end;
end;
inherited;
end;
//----------------------------------------------------------------------------------------------------------------------
end.

32992
components/virtualtreeview/VirtualTrees.pas Normal file
View file

File diff suppressed because it is too large Load diff

234
components/virtualtreeview/doublecmd.diff Normal file
View file

@ -0,0 +1,234 @@
Index: VirtualTrees.pas
===================================================================
--- VirtualTrees.pas (revision 2334)
+++ VirtualTrees.pas (working copy)
@@ -745,6 +745,7 @@
toAutoHideButtons, // Node buttons are hidden when there are child nodes, but all are invisible.
toAutoDeleteMovedNodes, // Delete nodes which where moved in a drag operation (if not directed otherwise).
toDisableAutoscrollOnFocus, // Disable scrolling a node or column into view if it gets focused.
+ toDisableAutoscrollHorizontal, // Only autoscroll on focus vertically never horizontally
toAutoChangeScale, // Change default node height automatically if the system's font scale is set to big fonts.
toAutoFreeOnCollapse, // Frees any child node after a node has been collapsed (HasChildren flag stays there).
toDisableAutoscrollOnEdit, // Do not center a node horizontally when it is edited.
@@ -2013,7 +2014,7 @@
var Allowed: Boolean) of object;
TVTDragOverEvent = procedure(Sender: TBaseVirtualTree; Source: TObject; Shift: TShiftState; State: TDragState;
const Pt: TPoint; Mode: TDropMode; var Effect: Integer; var Accept: Boolean) of object;
- TVTDragDropEvent = procedure(Sender: TBaseVirtualTree; Source: TObject; DataObject: IDataObject;
+ TVTDragDropEvent = procedure(Sender: TBaseVirtualTree; Source: TObject; {DataObject: IDataObject;}
Formats: TFormatArray; Shift: TShiftState; const Pt: TPoint; var Effect: Integer; Mode: TDropMode) of object;
TVTRenderOLEDataEvent = procedure(Sender: TBaseVirtualTree; const FormatEtcIn: TFormatEtc; out Medium: TStgMedium;
ForClipboard: Boolean; var Result: HRESULT) of object;
@@ -2472,7 +2473,7 @@
procedure CMDenySubclassing(var Message: TLMessage); message CM_DENYSUBCLASSING;
//procedure CMDrag(var Message: TCMDrag); message CM_DRAG;
procedure CMFontChanged(var Message: TLMessage); message CM_FONTCHANGED;
- procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
+ procedure CMHintShow(var Message: TCMHintShow); //message CM_HINTSHOW;
procedure CMMouseLeave(var Message: TLMessage); message CM_MOUSELEAVE;
procedure CMMouseWheel(var Message: TLMMouseEvent); message LM_MOUSEWHEEL;
{$ifdef EnableNativeTVM}
@@ -3008,6 +3009,7 @@
function GetNextNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;
function GetNextSelected(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;
function GetNextSibling(Node: PVirtualNode): PVirtualNode;
+ function GetNextSiblingNoInit(Node: PVirtualNode): PVirtualNode;
function GetNextVisible(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode;
function GetNextVisibleNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode;
function GetNextVisibleSibling(Node: PVirtualNode): PVirtualNode;
@@ -3026,6 +3028,7 @@
function GetPreviousNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;
function GetPreviousSelected(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;
function GetPreviousSibling(Node: PVirtualNode): PVirtualNode;
+ function GetPreviousSiblingNoInit(Node: PVirtualNode): PVirtualNode;
function GetPreviousVisible(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode;
function GetPreviousVisibleNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode;
function GetPreviousVisibleSibling(Node: PVirtualNode): PVirtualNode;
@@ -13869,7 +13872,7 @@
FFocusedColumn := Value;
if Assigned(FFocusedNode) and not (toDisableAutoscrollOnFocus in FOptions.FAutoOptions) then
begin
- if ScrollIntoView(FFocusedNode, toCenterScrollIntoView in FOptions.SelectionOptions, True) then
+ if ScrollIntoView(FFocusedNode, toCenterScrollIntoView in FOptions.SelectionOptions, not (toDisableAutoscrollHorizontal in FOptions.FAutoOptions)) then
InvalidateNode(FFocusedNode);
end;
@@ -15672,7 +15675,7 @@
if (Shift = [ssCtrlOS]) and not ActAsGrid then
begin
ScrollIntoView(Node, toCenterScrollIntoView in FOptions.SelectionOptions,
- not (toDisableAutoscrollOnFocus in FOptions.FAutoOptions));
+ not (toDisableAutoscrollHorizontal in FOptions.FAutoOptions));
if (CharCode = VK_HOME) and not UseRightToLeftAlignment then
SetOffsetX(0)
else
@@ -18437,7 +18440,7 @@
begin
if Assigned(FOnDragDrop) then
- FOnDragDrop(Self, Source, DataObject, Formats, Shift, Pt, Effect, Mode);
+ FOnDragDrop(Self, Source, {DataObject, }Formats, Shift, Pt, Effect, Mode);
end;
//----------------------------------------------------------------------------------------------------------------------
@@ -18589,7 +18592,7 @@
InvalidateNode(FFocusedNode);
if (FUpdateCount = 0) and not (toDisableAutoscrollOnFocus in FOptions.FAutoOptions) then
ScrollIntoView(FFocusedNode, (toCenterScrollIntoView in FOptions.SelectionOptions) and
- (MouseButtonDown * FStates = []), True);
+ (MouseButtonDown * FStates = []), toDisableAutoscrollHorizontal in FOptions.FAutoOptions);
end;
// Reset range anchor if necessary.
@@ -21122,7 +21125,7 @@
if NewNode or NewColumn then
begin
ScrollIntoView(FFocusedNode, toCenterScrollIntoView in FOptions.SelectionOptions,
- not (toDisableAutoscrollOnFocus in FOptions.FAutoOptions));
+ not (toDisableAutoscrollHorizontal in FOptions.FAutoOptions));
DoFocusChange(FFocusedNode, FFocusedColumn);
end;
end;
@@ -26469,6 +26472,22 @@
//----------------------------------------------------------------------------------------------------------------------
+function TBaseVirtualTree.GetNextSiblingNoInit(Node: PVirtualNode): PVirtualNode;
+
+// Returns the next sibling of Node performing no initialization.
+
+begin
+ Result := Node;
+ if Assigned(Result) then
+ begin
+ Assert(Result <> FRoot, 'Node must not be the hidden root node.');
+
+ Result := Result.NextSibling;
+ end;
+end;
+
+//----------------------------------------------------------------------------------------------------------------------
+
function TBaseVirtualTree.GetNextVisible(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode;
// Returns next node in tree, with regard to Node, which is visible.
@@ -27087,6 +27106,22 @@
//----------------------------------------------------------------------------------------------------------------------
+function TBaseVirtualTree.GetPreviousSiblingNoInit(Node: PVirtualNode): PVirtualNode;
+
+// Get next sibling of Node, performes no initialization.
+
+begin
+ Result := Node;
+ if Assigned(Result) then
+ begin
+ Assert(Result <> FRoot, 'Node must not be the hidden root node.');
+
+ Result := Result.PrevSibling;
+ end;
+end;
+
+//----------------------------------------------------------------------------------------------------------------------
+
function TBaseVirtualTree.GetPreviousVisible(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode;
// Returns the previous node in tree, with regard to Node, which is visible.
@@ -29272,6 +29307,7 @@
HScrollBarVisible: Boolean;
ScrolledVertically,
ScrolledHorizontally: Boolean;
+ OffY, OffYM: Integer;
begin
//todo: minimize calls to ClientHeight and ClientWidth
@@ -29316,7 +29352,13 @@
if Center then
SetOffsetY(FOffsetY - R.Bottom + ClientHeight div 2)
else
- SetOffsetY(FOffsetY - R.Bottom + ClientHeight);
+ begin
+ OffY := FOffsetY - R.Bottom + ClientHeight;
+ OffYM := OffY mod DefaultNodeHeight;
+ if OffYM <> 0 then
+ OffY := OffY - (DefaultNodeHeight + OffYM);
+ SetOffsetY(OffY);
+ end;
// When scrolling up and the horizontal scroll appears because of the operation
// then we have to move up the node the horizontal scrollbar's height too
// in order to avoid that the scroll bar hides the node which we wanted to have in view.
@@ -29370,10 +29412,13 @@
end
else
begin
- if ColumnRight > ClientWidth then
- NewOffset := FEffectiveOffsetX + (ColumnRight - ClientWidth)
- else if ColumnLeft < Header.Columns.GetVisibleFixedWidth then
- NewOffset := FEffectiveOffsetX - (Header.Columns.GetVisibleFixedWidth - ColumnLeft);
+ if FHeader.Columns.Count > 1 then
+ begin
+ if ColumnRight > ClientWidth then
+ NewOffset := FEffectiveOffsetX + (ColumnRight - ClientWidth)
+ else if ColumnLeft < Header.Columns.GetVisibleFixedWidth then
+ NewOffset := FEffectiveOffsetX - (Header.Columns.GetVisibleFixedWidth - ColumnLeft);
+ end;
if NewOffset <> FEffectiveOffsetX then
begin
if UseRightToLeftAlignment then
Index: VTConfig.inc
===================================================================
--- VTConfig.inc (revision 2334)
+++ VTConfig.inc (working copy)
@@ -22,7 +22,7 @@
//Lazarus port options
-{$define EnableOLE}
+{.$define EnableOLE}
{.$define EnableNativeTVM}
{.$define EnablePrint}
{.$define EnableNCFunctions}
@@ -42,5 +42,5 @@
//under linux the performance is poor with threading enabled
{$ifdef Windows}
- {$define EnableThreadSupport}
+ {.$define EnableThreadSupport}
{$endif}
Index: virtualtreeview_package.lpk
===================================================================
--- virtualtreeview_package.lpk (revision 2334)
+++ virtualtreeview_package.lpk (working copy)
@@ -1,10 +1,11 @@
<?xml version="1.0"?>
<CONFIG>
- <Package Version="3">
+ <Package Version="4">
<Name Value="virtualtreeview_package"/>
+ <AddToProjectUsesSection Value="True"/>
<Author Value="Mike Lischke (LCL Port: Luiz Américo)"/>
<CompilerOptions>
- <Version Value="10"/>
+ <Version Value="11"/>
<SearchPaths>
<IncludeFiles Value="include/intf/$(LCLWidgetType);units;include/intf"/>
<OtherUnitFiles Value="units/$(LCLWidgetType)"/>
@@ -15,6 +16,17 @@
<UseAnsiStrings Value="False"/>
</SyntaxOptions>
</Parsing>
+ <CodeGeneration>
+ <Checks>
+ <RangeChecks Value="True"/>
+ <OverflowChecks Value="True"/>
+ </Checks>
+ </CodeGeneration>
+ <Linking>
+ <Debugging>
+ <DebugInfoType Value="dsDwarf2Set"/>
+ </Debugging>
+ </Linking>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>

48
components/virtualtreeview/ideicons.lrs Normal file
View file

@ -0,0 +1,48 @@
LazarusResources.Add('tvirtualdrawtree','XPM',[
'/* XPM */'#10'static char * tvirtualdrawtree_xpm[] = {'#10'"24 24 8 1",'#10
+'".'#9'c #000000",'#10'"+'#9'c None",'#10'"@'#9'c #808000",'#10'"#'#9'c #20A'
+'080",'#10'"$'#9'c #808080",'#10'"%'#9'c #C0A000",'#10'"&'#9'c #C0C0C0",'#10
+'"*'#9'c #FFFFFF",'#10'"++++++..++++++++++++++++",'#10'"+++++.&&............'
+'.+++",'#10'"++++.***&&&&&&&&&&$$@.++",'#10'"++++.************@$$$.++",'#10
+'"+++.************@$$$$.++",'#10'"++++...@********.$$$$.++",'#10'"+++++++...'
+'......$$$$@+++",'#10'"+++++++.$$$$$$$$***$.+++",'#10'"+++++++.*******%***&.'
+'+++",'#10'"+++++++.*.****%%%**$.+++",'#10'"+++++++.*...*%%%%%*.++++",'#10'"'
+'+++++++.*.**%%%%%%%.++++",'#10'"++++++.**.***####**.++++",'#10'"+++++.$**.*'
+'*######*.++++",'#10'"+++++.&**..*######*.++++",'#10'"+++++.******######*.++'
+'++",'#10'"+++++.*******####**&.+++",'#10'"+...+.***.....******.+++",'#10'"+'
+'.&&@....&&&&&.****$.+++",'#10'"+.&&&&&&&&&&&&&.**&.++++",'#10'"++.$&&&&&&&&'
+'&&&.&&&.++++",'#10'"++.$$$$$$$$$$$$$.&.+++++",'#10'"+++...............+++++'
+'+",'#10'"++++++++++++++++++++++++"};'#10
]);
LazarusResources.Add('tvirtualstringtree','XPM',[
'/* XPM */'#10'static char * tvirtualstringtree_xpm[] = {'#10'"24 24 8 1",'#10
+'".'#9'c #000000",'#10'"+'#9'c None",'#10'"@'#9'c #808000",'#10'"#'#9'c #20A'
+'080",'#10'"$'#9'c #808080",'#10'"%'#9'c #C0A000",'#10'"&'#9'c #C0C0C0",'#10
+'"*'#9'c #FFFFFF",'#10'"++++++..++++++++++++++++",'#10'"+++++.&&............'
+'.+++",'#10'"++++.***&&&&&&&&&&$$@.++",'#10'"++++.************@$$$.++",'#10
+'"+++.************@$$$$.++",'#10'"++++...@********.$$$$.++",'#10'"+++++++...'
+'......$$$$@+++",'#10'"+++++++.$$$$$$$$***$.+++",'#10'"+++++++.***********&.'
+'+++",'#10'"+++++++.*.**......*$.+++",'#10'"+++++++.*....%%%%.*.++++",'#10'"'
+'+++++++.*.**......*.++++",'#10'"++++++.**.*********.++++",'#10'"+++++.$**.*'
+'*......*.++++",'#10'"+++++.&**....####.*.++++",'#10'"+++++.******......*.++'
+'++",'#10'"+++++.*************&.+++",'#10'"+...+.***.....******.+++",'#10'"+'
+'.&&@....&&&&&.****$.+++",'#10'"+.&&&&&&&&&&&&&.**&.++++",'#10'"++.$&&&&&&&&'
+'&&&.&&&.++++",'#10'"++.$$$$$$$$$$$$$.&.+++++",'#10'"+++...............+++++'
+'+",'#10'"++++++++++++++++++++++++"};'#10
]);
LazarusResources.Add('tvtheaderpopupmenu','XPM',[
'/* XPM */'#10'static char * tvtheaderpopupmenu_xpm[] = {'#10'"24 24 7 1",'#10
+'".'#9'c #000000",'#10'"+'#9'c #000080",'#10'"@'#9'c None",'#10'"#'#9'c #808'
+'000",'#10'"$'#9'c #808080",'#10'"%'#9'c #C0C0C0",'#10'"&'#9'c #FFFFFF",'#10
+'"@@@@@@..@@@@@@@@@@@@@@@@",'#10'"@@@@@.%%.............@@@",'#10'"@@@@.&&&%%'
+'%%%%%%%%$$#.@@",'#10'"@@@@.&&&&&&&&&&&&#$$$.@@",'#10'"@@@.&&&&&&&&&&&&#$$$$'
+'.@@",'#10'"@@@@...#&&&&&&&&.$$$$.@@",'#10'"@@@@@@@.........$$$$#@@@",'#10'"'
+'@@@@@@@.$$$$$$$$&&&$.@@@",'#10'"@@@@@@@.$&&&&&&.&&&%.@@@",'#10'"@@@@@@@.$&+'
+'++&&.&&&$.@@@",'#10'"@@@@@@@.$&&&&&&.&&&.@@@@",'#10'"@@@@@@@.$&+++++.&&&.@@'
+'@@",'#10'"@@@@@@.&$+&&&+&+&&&.@@@@",'#10'"@@@@@.$&$&++++&&+&&.@@@@",'#10'"@'
+'@@@@.%&$&&&&+&&&+&.@@@@",'#10'"@@@@@.&&$....+&&&&+.@@@@",'#10'"@@@@@.&&&&&&'
+'&+&&&++++@@@",'#10'"@...@.&&&....+&&&&+&.@@@",'#10'"@.%%#....%%%%+&++&&+.@@'
+'@",'#10'"@.%%%%%%%%%%%++$+&&+@@@@",'#10'"@@.$%%%%%%%%%+%.%+&&+@@@",'#10'"@@'
+'.$$$$$$$$$$$$$.+&&+@@@",'#10'"@@@...............++@@@@",'#10'"@@@@@@@@@@@@@'
+'@@@@@@@@@@@"};'#10
]);

2
components/virtualtreeview/include/intf/carbon/olemethods.inc Normal file
View file

@ -0,0 +1,2 @@
{$i ../dummyolemethods.inc}

23
components/virtualtreeview/include/intf/carbon/vtgraphicsi.inc Normal file
View file

@ -0,0 +1,23 @@
//todo: properly implement
procedure AlphaBlend(Source, Destination: HDC; const R: TRect; const Target: TPoint; Mode: TBlendMode; ConstantAlpha, Bias: Integer);
begin
case Mode of
bmConstantAlpha,
bmPerPixelAlpha,
bmMasterAlpha,
bmConstantAlphaAndColor:
begin
BitBlt(Destination, Target.X, Target.Y, R.Right - R.Left, R.Bottom - R.Top, Source, R.Left, R.Right, SRCCOPY);
end;
end;
end;
function CalculateScanline(Bits: Pointer; Width, Height, Row: Integer): Pointer;
begin
Result := nil;
end;
function GetBitmapBitsFromBitmap(Bitmap: HBITMAP): Pointer;
begin
Result := nil;
end;

2
components/virtualtreeview/include/intf/carbon/vtvdragmanager.inc Normal file
View file

@ -0,0 +1,2 @@
{$i ../dummydragmanager.inc}

790
components/virtualtreeview/include/intf/dummydragmanager.inc Normal file
View file

@ -0,0 +1,790 @@
//----------------------------------------------------------------------------------------------------------------------
// OLE drag and drop support classes
// This is quite heavy stuff (compared with the VCL implementation) but is much better suited to fit the needs
// of DD'ing various kinds of virtual data and works also between applications.
//----------------- TEnumFormatEtc -------------------------------------------------------------------------------------
constructor TEnumFormatEtc.Create(Tree: TBaseVirtualTree; AFormatEtcArray: TFormatEtcArray);
var
I: Integer;
begin
inherited Create;
{
FTree := Tree;
// Make a local copy of the format data.
SetLength(FFormatEtcArray, Length(AFormatEtcArray));
for I := 0 to High(AFormatEtcArray) do
FFormatEtcArray[I] := AFormatEtcArray[I];
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TEnumFormatEtc.Clone(out Enum: IEnumFormatEtc): HResult;
{
var
AClone: TEnumFormatEtc;
}
begin
{
Result := S_OK;
try
AClone := TEnumFormatEtc.Create(nil, FFormatEtcArray);
AClone.FCurrentIndex := FCurrentIndex;
Enum := AClone as IEnumFormatEtc;
except
Result := E_FAIL;
end;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TEnumFormatEtc.Next(celt: LongWord; out elt: FormatEtc;pceltFetched:pULong=nil): HResult;
{
var
CopyCount: LongWord;
}
begin
{
Result := S_FALSE;
CopyCount := Length(FFormatEtcArray) - FCurrentIndex;
if celt < CopyCount then
CopyCount := celt;
if CopyCount > 0 then
begin
Move(FFormatEtcArray[FCurrentIndex], elt, CopyCount * SizeOf(TFormatEtc));
Inc(FCurrentIndex, CopyCount);
Result := S_OK;
end;
//todo_lcl_check Delphi treats pceltFetched an PInteger. Implemented like in fpc.activex. What heappens with
// a C Program call with a NULL in pCeltFetcjed??
//Answer: Yes. Is necessary a check here
if @pceltFetched <> nil then
pceltFetched := CopyCount;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TEnumFormatEtc.Reset: HResult;
begin
{
FCurrentIndex := 0;
Result := S_OK;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TEnumFormatEtc.Skip(celt: LongWord): HResult;
begin
{
if FCurrentIndex + celt < High(FFormatEtcArray) then
begin
Inc(FCurrentIndex, celt);
Result := S_Ok;
end
else
Result := S_FALSE;
}
end;
//----------------- TVTDataObject --------------------------------------------------------------------------------------
constructor TVTDataObject.Create(AOwner: TBaseVirtualTree; ForClipboard: Boolean);
begin
inherited Create;
{
FOwner := AOwner;
FForClipboard := ForClipboard;
FOwner.GetNativeClipboardFormats(FFormatEtcArray);
}
end;
//----------------------------------------------------------------------------------------------------------------------
destructor TVTDataObject.Destroy;
var
I: Integer;
StgMedium: PStgMedium;
begin
{
// Cancel a pending clipboard operation if this data object was created for the clipboard and
// is freed because something else is placed there.
if FForClipboard and not (tsClipboardFlushing in FOwner.FStates) then
FOwner.CancelCutOrCopy;
// Release any internal clipboard formats
for I := 0 to High(FormatEtcArray) do
begin
StgMedium := FindInternalStgMedium(FormatEtcArray[I].cfFormat);
if Assigned(StgMedium) then
ReleaseStgMedium(StgMedium);
end;
FormatEtcArray := nil;
inherited;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.CanonicalIUnknown(TestUnknown: IUnknown): IUnknown;
// Uses COM object identity: An explicit call to the IUnknown::QueryInterface method, requesting the IUnknown
// interface, will always return the same pointer.
begin
{
if Assigned(TestUnknown) then
begin
if TestUnknown.QueryInterface(IUnknown, Result) = 0 then
Result._Release // Don't actually need it just need the pointer value
else
Result := TestUnknown
end
else
Result := TestUnknown
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.EqualFormatEtc(FormatEtc1, FormatEtc2: TFormatEtc): Boolean;
begin
{
Result := (FormatEtc1.cfFormat = FormatEtc2.cfFormat) and (FormatEtc1.ptd = FormatEtc2.ptd) and
(FormatEtc1.dwAspect = FormatEtc2.dwAspect) and (FormatEtc1.lindex = FormatEtc2.lindex) and
(FormatEtc1.tymed and FormatEtc2.tymed <> 0);
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.FindFormatEtc(TestFormatEtc: TFormatEtc; const FormatEtcArray: TFormatEtcArray): integer;
var
I: integer;
begin
{
Result := -1;
for I := 0 to High(FormatEtcArray) do
begin
if EqualFormatEtc(TestFormatEtc, FormatEtcArray[I]) then
begin
Result := I;
Break;
end
end;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.FindInternalStgMedium(Format: TClipFormat): PStgMedium;
{
var
I: integer;
}
begin
{
Result := nil;
for I := 0 to High(InternalStgMediumArray) do
begin
if Format = InternalStgMediumArray[I].Format then
begin
Result := @InternalStgMediumArray[I].Medium;
Break;
end
end;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.HGlobalClone(HGlobal: THandle): THandle;
// Returns a global memory block that is a copy of the passed memory block.
{
var
Size: Cardinal;
Data,
NewData: PChar;
}
begin
{
Size := GlobalSize(HGlobal);
Result := GlobalAlloc(GPTR, Size);
Data := GlobalLock(hGlobal);
try
NewData := GlobalLock(Result);
try
Move(Data^, NewData^, Size);
finally
GlobalUnLock(Result);
end
finally
GlobalUnLock(hGlobal);
end;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.RenderInternalOLEData(const FormatEtcIn: TFormatEtc; var Medium: TStgMedium;
var OLEResult: HResult): Boolean;
// Tries to render one of the formats which have been stored via the SetData method.
// Since this data is already there it is just copied or its reference count is increased (depending on storage medium).
{
var
InternalMedium: PStgMedium;
}
begin
{
Result := True;
InternalMedium := FindInternalStgMedium(FormatEtcIn.cfFormat);
if Assigned(InternalMedium) then
OLEResult := StgMediumIncRef(InternalMedium^, Medium, False, Self as IDataObject)
else
Result := False;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.StgMediumIncRef(const InStgMedium: TStgMedium; var OutStgMedium: TStgMedium;
CopyInMedium: Boolean; DataObject: IDataObject): HRESULT;
// InStgMedium is the data that is requested, OutStgMedium is the data that we are to return either a copy of or
// increase the IDataObject's reference and send ourselves back as the data (unkForRelease). The InStgMedium is usually
// the result of a call to find a particular FormatEtc that has been stored locally through a call to SetData.
// If CopyInMedium is not true we already have a local copy of the data when the SetData function was called (during
// that call the CopyInMedium must be true). Then as the caller asks for the data through GetData we do not have to make
// copy of the data for the caller only to have them destroy it then need us to copy it again if necessary.
// This way we increase the reference count to ourselves and pass the STGMEDIUM structure initially stored in SetData.
// This way when the caller frees the structure it sees the unkForRelease is not nil and calls Release on the object
// instead of destroying the actual data.
var
Len: Integer;
begin
{
Result := S_OK;
// Simply copy all fields to start with.
OutStgMedium := InStgMedium;
// The data handled here always results from a call of SetData we got. This ensures only one storage format
// is indicated and hence the case statement below is safe (IDataObject.GetData can optionally use several
// storage formats).
case InStgMedium.tymed of
TYMED_HGLOBAL:
begin
if CopyInMedium then
begin
// Generate a unique copy of the data passed
OutStgMedium.hGlobal := HGlobalClone(InStgMedium.hGlobal);
if OutStgMedium.hGlobal = 0 then
Result := E_OUTOFMEMORY
end
else
// Don't generate a copy just use ourselves and the copy previously saved.
OutStgMedium.PunkForRelease := Pointer(DataObject); // Does not increase RefCount.
end;
TYMED_FILE:
begin
//todo_lcl_check
Len := Length(WideString(InStgMedium.lpszFileName)) + 1; // Don't forget the terminating null character.
OutStgMedium.lpszFileName := CoTaskMemAlloc(2 * Len);
Move(InStgMedium.lpszFileName^, OutStgMedium.lpszFileName^, 2 * Len);
end;
TYMED_ISTREAM:
IUnknown(OutStgMedium.Pstm)._AddRef;
TYMED_ISTORAGE:
IUnknown(OutStgMedium.Pstg)._AddRef;
TYMED_GDI:
if not CopyInMedium then
// Don't generate a copy just use ourselves and the previously saved data.
OutStgMedium.PunkForRelease := Pointer(DataObject) // Does not increase RefCount.
else
Result := DV_E_TYMED; // Don't know how to copy GDI objects right now.
TYMED_MFPICT:
if not CopyInMedium then
// Don't generate a copy just use ourselves and the previously saved data.
OutStgMedium.PunkForRelease := Pointer(DataObject) // Does not increase RefCount.
else
Result := DV_E_TYMED; // Don't know how to copy MetaFile objects right now.
TYMED_ENHMF:
if not CopyInMedium then
// Don't generate a copy just use ourselves and the previously saved data.
OutStgMedium.PunkForRelease := Pointer(DataObject) // Does not increase RefCount.
else
Result := DV_E_TYMED; // Don't know how to copy enhanced metafiles objects right now.
else
Result := DV_E_TYMED;
end;
if (Result = S_OK) and Assigned(OutStgMedium.PunkForRelease) then
IUnknown(OutStgMedium.PunkForRelease)._AddRef;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.DAdvise(const FormatEtc: TFormatEtc; advf: DWord; const advSink: IAdviseSink;
out dwConnection: DWord): HResult;
// Advise sink management is greatly simplified by the IDataAdviseHolder interface.
// We use this interface and forward all concerning calls to it.
begin
{
Result := S_OK;
if FAdviseHolder = nil then
Result := CreateDataAdviseHolder(FAdviseHolder);
if Result = S_OK then
Result := FAdviseHolder.Advise(Self as IDataObject, FormatEtc, advf, advSink, dwConnection);
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.DUnadvise(dwConnection: DWord): HResult;
begin
{
if FAdviseHolder = nil then
Result := E_NOTIMPL
else
Result := FAdviseHolder.Unadvise(dwConnection);
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.EnumDAdvise(Out enumAdvise : IEnumStatData):HResult;
begin
{
if FAdviseHolder = nil then
Result := OLE_E_ADVISENOTSUPPORTED
else
Result := FAdviseHolder.EnumAdvise(enumAdvise);
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.EnumFormatEtc(Direction: DWord; out EnumFormatEtc: IEnumFormatEtc): HResult;
{
var
NewList: TEnumFormatEtc;
}
begin
{
Result := E_FAIL;
if Direction = DATADIR_GET then
begin
NewList := TEnumFormatEtc.Create(FOwner, FormatEtcArray);
EnumFormatEtc := NewList as IEnumFormatEtc;
Result := S_OK;
end
else
EnumFormatEtc := nil;
if EnumFormatEtc = nil then
Result := OLE_S_USEREG;
}
end;
//----------------------------------------------------------------------------------------------------------------------
Function TVTDataObject.GetCanonicalFormatEtc(const pformatetcIn : FORMATETC;Out pformatetcOut : FORMATETC):HResult;
begin
//Result := DATA_S_SAMEFORMATETC;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium): HResult;
// Data is requested by clipboard or drop target. This method dispatchs the call
// depending on the data being requested.
{
var
I: Integer;
Data: PVTReference;
}
begin
{
// The tree reference format is always supported and returned from here.
if FormatEtcIn.cfFormat = CF_VTREFERENCE then
begin
// Note: this format is not used while flushing the clipboard to avoid a dangling reference
// when the owner tree is destroyed before the clipboard data is replaced with something else.
if tsClipboardFlushing in FOwner.FStates then
Result := E_FAIL
else
begin
Medium.hGlobal := GlobalAlloc(GHND or GMEM_SHARE, SizeOf(TVTReference));
Data := GlobalLock(Medium.hGlobal);
Data.Process := GetCurrentProcessID;
Data.Tree := FOwner;
GlobalUnlock(Medium.hGlobal);
Medium.tymed := TYMED_HGLOBAL;
Medium.PunkForRelease := nil;
Result := S_OK;
end;
end
else
begin
try
// See if we accept this type and if not get the correct return value.
Result := QueryGetData(FormatEtcIn);
if Result = S_OK then
begin
for I := 0 to High(FormatEtcArray) do
begin
if EqualFormatEtc(FormatEtcIn, FormatEtcArray[I]) then
begin
if not RenderInternalOLEData(FormatEtcIn, Medium, Result) then
Result := FOwner.RenderOLEData(FormatEtcIn, Medium, FForClipboard);
Break;
end;
end
end
except
FillChar(Medium, SizeOf(Medium), #0);
Result := E_FAIL;
end;
end;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium): HResult;
begin
//Result := E_NOTIMPL;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.QueryGetData(const FormatEtc: TFormatEtc): HResult;
{
var
I: Integer;
}
begin
{
Result := DV_E_CLIPFORMAT;
for I := 0 to High(FFormatEtcArray) do
begin
if FormatEtc.cfFormat = FFormatEtcArray[I].cfFormat then
begin
if (FormatEtc.tymed and FFormatEtcArray[I].tymed) <> 0 then
begin
if FormatEtc.dwAspect = FFormatEtcArray[I].dwAspect then
begin
if FormatEtc.lindex = FFormatEtcArray[I].lindex then
begin
Result := S_OK;
Break;
end
else
Result := DV_E_LINDEX;
end
else
Result := DV_E_DVASPECT;
end
else
Result := DV_E_TYMED;
end;
end
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.SetData(const FormatEtc: TFormatEtc; {$ifdef VER2_0}var{$else}const{$endif} Medium: TStgMedium; DoRelease: BOOL): HResult;
// Allows dynamic adding to the IDataObject during its existance. Most noteably it is used to implement
// IDropSourceHelper and allows to set a special format for optimized moves during a shell transfer.
{
var
Index: Integer;
LocalStgMedium: PStgMedium;
}
begin
{
// See if we already have a format of that type available.
Index := FindFormatEtc(FormatEtc, FormatEtcArray);
if Index > - 1 then
begin
// Just use the TFormatEct in the array after releasing the data.
LocalStgMedium := FindInternalStgMedium(FormatEtcArray[Index].cfFormat);
if Assigned(LocalStgMedium) then
begin
ReleaseStgMedium(LocalStgMedium);
FillChar(LocalStgMedium^, SizeOf(LocalStgMedium^), #0);
end;
end
else
begin
// It is a new format so create a new TFormatCollectionItem, copy the
// FormatEtc parameter into the new object and and put it in the list.
SetLength(FFormatEtcArray, Length(FormatEtcArray) + 1);
FormatEtcArray[High(FormatEtcArray)] := FormatEtc;
// Create a new InternalStgMedium and initialize it and associate it with the format.
SetLength(FInternalStgMediumArray, Length(InternalStgMediumArray) + 1);
InternalStgMediumArray[High(InternalStgMediumArray)].Format := FormatEtc.cfFormat;
LocalStgMedium := @InternalStgMediumArray[High(InternalStgMediumArray)].Medium;
FillChar(LocalStgMedium^, SizeOf(LocalStgMedium^), #0);
end;
if DoRelease then
begin
// We are simply being given the data and we take control of it.
LocalStgMedium^ := Medium;
Result := S_OK
end
else
begin
// We need to reference count or copy the data and keep our own references to it.
Result := StgMediumIncRef(Medium, LocalStgMedium^, True, Self as IDataObject);
// Can get a circular reference if the client calls GetData then calls SetData with the same StgMedium.
// Because the unkForRelease for the IDataObject can be marshalled it is necessary to get pointers that
// can be correctly compared. See the IDragSourceHelper article by Raymond Chen at MSDN.
if Assigned(LocalStgMedium.PunkForRelease) then
begin
if CanonicalIUnknown(Self) = CanonicalIUnknown(IUnknown(LocalStgMedium.PunkForRelease)) then
IUnknown(LocalStgMedium.PunkForRelease) := nil; // release the interface
end;
end;
// Tell all registered advice sinks about the data change.
if Assigned(FAdviseHolder) then
FAdviseHolder.SendOnDataChange(Self as IDataObject, 0, 0);
}
end;
//----------------- TVTDragManager -------------------------------------------------------------------------------------
constructor TVTDragManager.Create(AOwner: TBaseVirtualTree);
begin
inherited Create;
FOwner := AOwner;
{
// Create an instance of the drop target helper interface. This will fail but not harm on systems which do
// not support this interface (everything below Windows 2000);
CoCreateInstance(CLSID_DragDropHelper, nil, CLSCTX_INPROC_SERVER, IID_IDropTargetHelper, FDropTargetHelper);
}
end;
//----------------------------------------------------------------------------------------------------------------------
destructor TVTDragManager.Destroy;
begin
// Set the owner's reference to us to nil otherwise it will access an invalid pointer
// after our desctruction is complete.
Pointer(FOwner.FDragManager) := nil;
inherited;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.GetDataObject: IDataObject;
begin
// When the owner tree starts a drag operation then it gets a data object here to pass it to the OLE subsystem.
// In this case there is no local reference to a data object and one is created (but not stored).
// If there is a local reference then the owner tree is currently the drop target and the stored interface is
// that of the drag initiator.
{
if Assigned(FDataObject) then
Result := FDataObject
else
begin
Result := FOwner.DoCreateDataObject;
if Result = nil then
Result := TVTDataObject.Create(FOwner, False) as IDataObject;
end;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.GetDragSource: TBaseVirtualTree;
begin
//Result := FDragSource;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.GetDropTargetHelperSupported: Boolean;
begin
//Result := Assigned(FDropTargetHelper);
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.GetIsDropTarget: Boolean;
begin
//Result := FIsDropTarget;
Result := True;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.DragEnter(const DataObject: IDataObject; KeyState: LongWord; Pt: TPoint;
var Effect: LongWord): HResult;
begin
{
FDataObject := DataObject;
FIsDropTarget := True;
SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0, @FFullDragging, 0);
// If full dragging of window contents is disabled in the system then our tree windows will be locked
// and cannot be updated during a drag operation. With the following call painting is again enabled.
if not FFullDragging then
LockWindowUpdate(0);
if Assigned(FDropTargetHelper) and FFullDragging then
FDropTargetHelper.DragEnter(FOwner.Handle, DataObject, Pt, Effect);
FDragSource := FOwner.GetTreeFromDataObject(DataObject);
Result := FOwner.DragEnter(KeyState, Pt, Effect);
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.DragLeave: HResult;
begin
{
if Assigned(FDropTargetHelper) and FFullDragging then
FDropTargetHelper.DragLeave;
FOwner.DragLeave;
FIsDropTarget := False;
FDragSource := nil;
FDataObject := nil;
Result := NOERROR;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.DragOver(KeyState: LongWord; Pt: TPoint; var Effect: LongWord): HResult;
begin
{
if Assigned(FDropTargetHelper) and FFullDragging then
FDropTargetHelper.DragOver(Pt, Effect);
Result := FOwner.DragOver(FDragSource, KeyState, dsDragMove, Pt, Effect);
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.Drop(const DataObject: IDataObject; KeyState: LongWord; Pt: TPoint;
var Effect: LongWord): HResult;
begin
{
if Assigned(FDropTargetHelper) and FFullDragging then
FDropTargetHelper.Drop(DataObject, Pt, Effect);
Result := FOwner.DragDrop(DataObject, KeyState, Pt, Effect);
FIsDropTarget := False;
FDataObject := nil;
}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTDragManager.ForceDragLeave;
// Some drop targets, e.g. Internet Explorer leave a drag image on screen instead removing it when they receive
// a drop action. This method calls the drop target helper's DragLeave method to ensure it removes the drag image from
// screen. Unfortunately, sometimes not even this does help (e.g. when dragging text from VT to a text field in IE).
begin
{
if Assigned(FDropTargetHelper) and FFullDragging then
FDropTargetHelper.DragLeave;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.GiveFeedback(Effect: Integer): HResult;
begin
//Result := DRAGDROP_S_USEDEFAULTCURSORS;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.QueryContinueDrag(EscapePressed: BOOL; KeyState: Integer): HResult;
var
RButton,
LButton: Boolean;
begin
{
LButton := (KeyState and MK_LBUTTON) <> 0;
RButton := (KeyState and MK_RBUTTON) <> 0;
// Drag'n drop canceled by pressing both mouse buttons or Esc?
if (LButton and RButton) or EscapePressed then
Result := DRAGDROP_S_CANCEL
else
// Drag'n drop finished?
if not (LButton or RButton) then
Result := DRAGDROP_S_DROP
else
Result := S_OK;
}
end;

404
components/virtualtreeview/include/intf/dummyolemethods.inc Normal file
View file

@ -0,0 +1,404 @@
function TBaseVirtualTree.GetTreeFromDataObject(const DataObject: IDataObject): TBaseVirtualTree;
// Returns the owner/sender of the given data object by means of a special clipboard format
// or nil if the sender is in another process or no virtual tree at all.
var
Medium: TStgMedium;
Data: PVTReference;
begin
Result := nil;
{
if Assigned(DataObject) then
begin
StandardOLEFormat.cfFormat := CF_VTREFERENCE;
if DataObject.GetData(StandardOLEFormat, Medium) = S_OK then
begin
Data := GlobalLock(Medium.hGlobal);
if Assigned(Data) then
begin
if Data.Process = GetCurrentProcessID then
Result := Data.Tree;
GlobalUnlock(Medium.hGlobal);
end;
ReleaseStgMedium(@Medium);
end;
end;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TBaseVirtualTree.RenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium;
ForClipboard: Boolean): HResult;
// Returns a memory expression of all currently selected nodes in the Medium structure.
// Note: The memory requirement of this method might be very high. This depends however on the requested storage format.
// For HGlobal (a global memory block) we need to render first all nodes to local memory and copy this then to
// the global memory in Medium. This is necessary because we have first to determine how much
// memory is needed before we can allocate it. Hence for a short moment we need twice the space as used by the
// nodes alone (plus the amount the nodes need in the tree anyway)!
// With IStream this does not happen. We directly stream out the nodes and pass the constructed stream along.
//--------------- local function --------------------------------------------
{
procedure WriteNodes(Stream: TStream);
var
Selection: TNodeArray;
I: Integer;
begin
if ForClipboard then
Selection := GetSortedCutCopySet(True)
else
Selection := GetSortedSelection(True);
for I := 0 to High(Selection) do
WriteNode(Stream, Selection[I]);
end;
//--------------- end local function ----------------------------------------
var
Data: PCardinal;
ResPointer: Pointer;
ResSize: Integer;
OLEStream: IStream;
VCLStream: TStream;
}
begin
{
FillChar(Medium, SizeOf(Medium), 0);
// We can render the native clipboard format in two different storage media.
if (FormatEtcIn.cfFormat = CF_VIRTUALTREE) and (FormatEtcIn.tymed and (TYMED_HGLOBAL or TYMED_ISTREAM) <> 0) then
begin
VCLStream := nil;
try
Medium.PunkForRelease := nil;
// Return data in one of the supported storage formats, prefer IStream.
if FormatEtcIn.tymed and TYMED_ISTREAM <> 0 then
begin
// Create an IStream on a memory handle (here it is 0 which indicates to implicitely allocated a handle).
// Do not use TStreamAdapter as it is not compatible with OLE (when flushing the clipboard OLE wants the HGlobal
// back which is not supported by TStreamAdapater).
CreateStreamOnHGlobal(0, True, OLEStream);
VCLStream := TOLEStream.Create(OLEStream);
WriteNodes(VCLStream);
// Rewind stream.
VCLStream.Position := 0;
Medium.tymed := TYMED_ISTREAM;
IUnknown(Medium.Pstm) := OLEStream;
Result := S_OK;
end
else
begin
VCLStream := TMemoryStream.Create;
WriteNodes(VCLStream);
ResPointer := TMemoryStream(VCLStream).Memory;
ResSize := VCLStream.Position;
// Allocate memory to hold the string.
if ResSize > 0 then
begin
Medium.hGlobal := GlobalAlloc(GHND or GMEM_SHARE, ResSize + SizeOf(Cardinal));
Data := GlobalLock(Medium.hGlobal);
// Store the size of the data too, for easy retrival.
Data^ := ResSize;
Inc(Data);
Move(ResPointer^, Data^, ResSize);
GlobalUnlock(Medium.hGlobal);
Medium.tymed := TYMED_HGLOBAL;
Result := S_OK;
end
else
Result := E_FAIL;
end;
finally
// We can free the VCL stream here since it was either a pure memory stream or only a wrapper around
// the OLEStream which exists independently.
VCLStream.Free;
end;
end
else // Ask application descendants to render self defined formats.
Result := DoRenderOLEData(FormatEtcIn, Medium, ForClipboard);
}
end;
//----------------------------------------------------------------------------------------------------------------------
type
// needed to handle OLE global memory objects
TOLEMemoryStream = class(TCustomMemoryStream)
public
function Write(const Buffer; Count: Integer): Longint; override;
end;
//----------------------------------------------------------------------------------------------------------------------
function TOLEMemoryStream.Write(const Buffer; Count: Integer): Integer;
begin
//raise EStreamError.CreateRes(PResStringRec(@SCantWriteResourceStreamError));
raise EStreamError.Create(SCantWriteResourceStreamError);
end;
//----------------------------------------------------------------------------------------------------------------------
function TBaseVirtualTree.ProcessOLEData(Source: TBaseVirtualTree; DataObject: IDataObject; TargetNode: PVirtualNode;
Mode: TVTNodeAttachMode; Optimized: Boolean): Boolean;
// Recreates the (sub) tree structure serialized into memory and provided by DataObject. The new nodes are attached to
// the passed node or FRoot if TargetNode is nil according to Mode. Optimized can be set to True if the entire operation
// happens within the same process (i.e. sender and receiver of the OLE operation are located in the same process).
// Optimize = True makes only sense if the operation to carry out is a move hence it is also the indication of the
// operation to be done here. Source is the source of the OLE data and only of use (and usually assigned) when
// an OLE operation takes place in the same application.
// Returns True on success, i.e. the CF_VIRTUALTREE format is supported by the data object and the structure could be
// recreated, otherwise False.
var
Medium: TStgMedium;
Stream: TStream;
Data: Pointer;
Node: PVirtualNode;
Nodes: TNodeArray;
I: Integer;
Res: HRESULT;
ChangeReason: TChangeReason;
begin
{
Nodes := nil;
// Check the data format available by the data object.
with StandardOLEFormat do
begin
// Read best format.
cfFormat := CF_VIRTUALTREE;
end;
Result := DataObject.QueryGetData(StandardOLEFormat) = S_OK;
if Result and not (toReadOnly in FOptions.FMiscOptions) then
begin
BeginUpdate;
Result := False;
try
if TargetNode = nil then
TargetNode := FRoot;
if TargetNode = FRoot then
begin
case Mode of
amInsertBefore:
Mode := amAddChildFirst;
amInsertAfter:
Mode := amAddChildLast;
end;
end;
// Optimized means source is known and in the same process so we can access its pointers, which avoids duplicating
// the data while doing a serialization. Can only be used with cut'n paste and drag'n drop with move effect.
if Optimized then
begin
if tsOLEDragging in Source.FStates then
Nodes := Source.FDragSelection
else
Nodes := Source.GetSortedCutCopySet(True);
if Mode in [amInsertBefore,amAddChildLast] then
begin
for I := 0 to High(Nodes) do
if not HasAsParent(TargetNode, Nodes[I]) then
Source.MoveTo(Nodes[I], TargetNode, Mode, False);
end
else
begin
for I := High(Nodes) downto 0 do
if not HasAsParent(TargetNode, Nodes[I]) then
Source.MoveTo(Nodes[I], TargetNode, Mode, False);
end;
Result := True;
end
else
begin
if Source = Self then
ChangeReason := crNodeCopied
else
ChangeReason := crNodeAdded;
Res := DataObject.GetData(StandardOLEFormat, Medium);
if Res = S_OK then
begin
case Medium.tymed of
TYMED_ISTREAM, // IStream interface
TYMED_HGLOBAL: // global memory block
begin
Stream := nil;
if Medium.tymed = TYMED_ISTREAM then
Stream := TOLEStream.Create(IUnknown(Medium.Pstm) as IStream)
else
begin
Data := GlobalLock(Medium.hGlobal);
if Assigned(Data) then
begin
// Get the total size of data to retrieve.
I := PCardinal(Data)^;
Inc(PCardinal(Data));
Stream := TOLEMemoryStream.Create;
TOLEMemoryStream(Stream).SetPointer(Data, I);
end;
end;
if Assigned(Stream) then
try
while Stream.Position < Stream.Size do
begin
Node := MakeNewNode;
InternalConnectNode(Node, TargetNode, Self, Mode);
InternalAddFromStream(Stream, VTTreeStreamVersion, Node);
// This seems a bit strange because of the callback for granting to add the node
// which actually comes after the node has been added. The reason is that the node must
// contain valid data otherwise I don't see how the application can make a funded decision.
if not DoNodeCopying(Node, TargetNode) then
DeleteNode(Node)
else
DoNodeCopied(Node);
StructureChange(Node, ChangeReason);
// In order to maintain the same node order when restoring nodes in the case of amInsertAfter
// we have to move the reference node continously. Othwise we would end up with reversed node order.
if Mode = amInsertAfter then
TargetNode := Node;
end;
Result := True;
finally
Stream.Free;
if Medium.tymed = TYMED_HGLOBAL then
GlobalUnlock(Medium.hGlobal);
end;
end;
end;
ReleaseStgMedium(@Medium);
end;
end;
finally
EndUpdate;
end;
end;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TCustomVirtualStringTree.ContentToClipboard(Format: Word; Source: TVSTTextSourceType): HGLOBAL;
// This method constructs a shareable memory object filled with string data in the required format. Supported are:
// CF_TEXT - plain ANSI text (Unicode text is converted using the user's current locale)
// CF_UNICODETEXT - plain Unicode text
// CF_CSV - comma separated plain ANSI text
// CF_VRTF + CF_RTFNOOBS - rich text (plain ANSI)
// CF_HTML - HTML text encoded using UTF-8
//
// Result is the handle to a globally allocated memory block which can directly be used for clipboard and drag'n drop
// transfers. The caller is responsible for freeing the memory. If for some reason the content could not be rendered
// the Result is 0.
//--------------- local function --------------------------------------------
{
procedure MakeFragment(var HTML: string);
// Helper routine to build a properly-formatted HTML fragment.
const
Version = 'Version:1.0'#13#10;
StartHTML = 'StartHTML:';
EndHTML = 'EndHTML:';
StartFragment = 'StartFragment:';
EndFragment = 'EndFragment:';
DocType = '<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">';
HTMLIntro = '<html><head><META http-equiv=Content-Type content="text/html; charset=utf-8">' +
'</head><body><!--StartFragment-->';
HTMLExtro = '<!--EndFragment--></body></html>';
NumberLengthAndCR = 10;
// Let the compiler determine the description length.
DescriptionLength = Length(Version) + Length(StartHTML) + Length(EndHTML) + Length(StartFragment) +
Length(EndFragment) + 4 * NumberLengthAndCR;
var
Description: string;
StartHTMLIndex,
EndHTMLIndex,
StartFragmentIndex,
EndFragmentIndex: Integer;
begin
// The HTML clipboard format is defined by using byte positions in the entire block where HTML text and
// fragments start and end. These positions are written in a description. Unfortunately the positions depend on the
// length of the description but the description may change with varying positions.
// To solve this dilemma the offsets are converted into fixed length strings which makes it possible to know
// the description length in advance.
StartHTMLIndex := DescriptionLength; // position 0 after the description
StartFragmentIndex := StartHTMLIndex + Length(DocType) + Length(HTMLIntro);
EndFragmentIndex := StartFragmentIndex + Length(HTML);
EndHTMLIndex := EndFragmentIndex + Length(HTMLExtro);
Description := Version +
SysUtils.Format('%s%.8d', [StartHTML, StartHTMLIndex]) + #13#10 +
SysUtils.Format('%s%.8d', [EndHTML, EndHTMLIndex]) + #13#10 +
SysUtils.Format('%s%.8d', [StartFragment, StartFragmentIndex]) + #13#10 +
SysUtils.Format('%s%.8d', [EndFragment, EndFragmentIndex]) + #13#10;
HTML := Description + DocType + HTMLIntro + HTML + HTMLExtro;
end;
}
//--------------- end local function ----------------------------------------
var
Data: Pointer;
DataSize: Cardinal;
S: string;
WS: WideString;
P: Pointer;
begin
Result := 0;
{
case Format of
CF_TEXT:
begin
S := ContentToText(Source, #9) + #0;
Data := PChar(S);
DataSize := Length(S);
end;
CF_UNICODETEXT:
begin
WS := ContentToUnicode(Source, #9) + #0;
Data := PWideChar(WS);
DataSize := 2 * Length(WS);
end;
else
if Format = CF_CSV then
S := ContentToText(Source, ListSeparator) + #0
else
if (Format = CF_VRTF) or (Format = CF_VRTFNOOBJS) then
S := ContentToRTF(Source) + #0
else
if Format = CF_HTML then
begin
S := ContentToHTML(Source);
// Build a valid HTML clipboard fragment.
MakeFragment(S);
S := S + #0;
end;
Data := PChar(S);
DataSize := Length(S);
end;
if DataSize > 0 then
begin
Result := GlobalAlloc(GHND or GMEM_SHARE, DataSize);
P := GlobalLock(Result);
Move(Data^, P^, DataSize);
GlobalUnlock(Result);
end;
}
end;

2
components/virtualtreeview/include/intf/gtk/olemethods.inc Normal file
View file

@ -0,0 +1,2 @@
{$i ../dummyolemethods.inc}

67
components/virtualtreeview/include/intf/gtk/vtgraphicsi.inc Normal file
View file

@ -0,0 +1,67 @@
uses
gtkdef, gtkint, CairoXlib, gdk, Cairo, glib;
//procedure gdk_drawable_get_size(drawable: PGdkDrawable; width, height: Pgint); cdecl; external gdkdll;
procedure AlphaBlend(Source, Destination: HDC; const R: TRect; const Target: TPoint; Mode: TBlendMode; ConstantAlpha, Bias: Integer);
function CreateSurface(GtkDC: TGtkDeviceContext): Pcairo_surface_t;
var
Width, Height: gint;
Visual: PGdkVisual;
begin
Result := nil;
if (GtkDC <> nil) and (GtkDC.Drawable <> nil) then
begin
gdk_window_get_size(GtkDC.Drawable, @Width, @Height);
Visual := gdk_visual_get_system;
Result := cairo_xlib_surface_create(
GDK_WINDOW_XDISPLAY(PGdkWindowPrivate(GtkDC.Drawable)),
GDK_WINDOW_XWINDOW(PGdkWindowPrivate(GtkDC.Drawable)),
GDK_VISUAL_XVISUAL(PGdkVisualPrivate(Visual)),
Width, Height);
end;
end;
var
SrcDC: TGtkDeviceContext absolute Source;
DestDC: TGtkDeviceContext absolute Destination;
SrcSurface, DestSurface: Pcairo_surface_t;
SrcContext, DestContext: Pcairo_t;
begin
case Mode of
bmConstantAlpha:;
bmPerPixelAlpha:;
bmMasterAlpha:;
bmConstantAlphaAndColor:
begin
DestSurface := CreateSurface(DestDC);
if DestSurface <> nil then
begin
DestContext := cairo_create(DestSurface);
cairo_set_source_rgba(DestContext,
(Bias and $000000FF) / 255,
((Bias shr 8) and $000000FF) / 255,
((Bias shr 16) and $000000FF) / 255,
ConstantAlpha / 255
);
cairo_rectangle(DestContext, R.Left + Target.x, R.Top + Target.y,
R.Right - R.Left, R.Bottom - R.Top);
cairo_fill(DestContext);
cairo_destroy(DestContext);
cairo_surface_destroy(DestSurface);
end;
end;
end;
end;
function CalculateScanline(Bits: Pointer; Width, Height, Row: Integer): Pointer;
begin
Result := nil;
end;
function GetBitmapBitsFromBitmap(Bitmap: HBITMAP): Pointer;
begin
Result := nil;
end;

2
components/virtualtreeview/include/intf/gtk/vtvdragmanager.inc Normal file
View file

@ -0,0 +1,2 @@
{$i ../dummydragmanager.inc}

2
components/virtualtreeview/include/intf/gtk2/olemethods.inc Normal file
View file

@ -0,0 +1,2 @@
{$i ../dummyolemethods.inc}

54
components/virtualtreeview/include/intf/gtk2/vtgraphicsi.inc Normal file
View file

@ -0,0 +1,54 @@
uses
gtk2def, gdk2, GTK2Proc, Cairo;
function gdk_cairo_create(drawable: PGdkDrawable): Pcairo_t cdecl external gdklib;
procedure AlphaBlend(Source, Destination: HDC; const R: TRect; const Target: TPoint; Mode: TBlendMode; ConstantAlpha, Bias: Integer);
function GetContext(GtkDC: TGtk2DeviceContext): Pcairo_t;
begin
Result := nil;
if (GtkDC <> nil) and (GtkDC.Drawable <> nil) then
Result := gdk_cairo_create(GtkDC.Drawable);
end;
var
SrcDC: TGtk2DeviceContext absolute Source;
DestDC: TGtk2DeviceContext absolute Destination;
SrcContext, DestContext: Pcairo_t;
begin
case Mode of
bmConstantAlpha:;
bmPerPixelAlpha:;
bmMasterAlpha:;
bmConstantAlphaAndColor:
begin
DestContext := GetContext(DestDC);
if DestContext <> nil then
begin
cairo_set_source_rgba(DestContext,
(Bias and $000000FF) / 255,
((Bias shr 8) and $000000FF) / 255,
((Bias shr 16) and $000000FF) / 255,
ConstantAlpha / 255
);
cairo_rectangle(DestContext, R.Left + Target.x, R.Top + Target.y,
R.Right - R.Left, R.Bottom - R.Top);
cairo_fill(DestContext);
cairo_destroy(DestContext);
end;
end;
end;
end;
function CalculateScanline(Bits: Pointer; Width, Height, Row: Integer): Pointer;
begin
Result := nil;
end;
function GetBitmapBitsFromBitmap(Bitmap: HBITMAP): Pointer;
begin
Result := nil;
end;

2
components/virtualtreeview/include/intf/gtk2/vtvdragmanager.inc Normal file
View file

@ -0,0 +1,2 @@
{$i ../dummydragmanager.inc}

2
components/virtualtreeview/include/intf/qt/olemethods.inc Normal file
View file

@ -0,0 +1,2 @@
{$i ../dummyolemethods.inc}

476
components/virtualtreeview/include/intf/qt/vtgraphicsi.inc Normal file
View file

@ -0,0 +1,476 @@
uses
qt4, qtobjects;
procedure AlphaBlendLineConstant(Source, Destination: Pointer; Count: Integer; ConstantAlpha, Bias: Integer);
// Blends a line of Count pixels from Source to Destination using a constant alpha value.
// The layout of a pixel must be BGRA where A is ignored (but is calculated as the other components).
// ConstantAlpha must be in the range 0..255 where 0 means totally transparent (destination pixel only)
// and 255 totally opaque (source pixel only).
// Bias is an additional value which gets added to every component and must be in the range -128..127
//
// EAX contains Source
// EDX contains Destination
// ECX contains Count
// ConstantAlpha and Bias are on the stack
asm
PUSH ESI // save used registers
PUSH EDI
MOV ESI, EAX // ESI becomes the actual source pointer
MOV EDI, EDX // EDI becomes the actual target pointer
// Load MM6 with the constant alpha value (replicate it for every component).
// Expand it to word size.
MOV EAX, [ConstantAlpha]
DB $0F, $6E, $F0 /// MOVD MM6, EAX
DB $0F, $61, $F6 /// PUNPCKLWD MM6, MM6
DB $0F, $62, $F6 /// PUNPCKLDQ MM6, MM6
// Load MM5 with the bias value.
MOV EAX, [Bias]
DB $0F, $6E, $E8 /// MOVD MM5, EAX
DB $0F, $61, $ED /// PUNPCKLWD MM5, MM5
DB $0F, $62, $ED /// PUNPCKLDQ MM5, MM5
// Load MM4 with 128 to allow for saturated biasing.
MOV EAX, 128
DB $0F, $6E, $E0 /// MOVD MM4, EAX
DB $0F, $61, $E4 /// PUNPCKLWD MM4, MM4
DB $0F, $62, $E4 /// PUNPCKLDQ MM4, MM4
@1: // The pixel loop calculates an entire pixel in one run.
// Note: The pixel byte values are expanded into the higher bytes of a word due
// to the way unpacking works. We compensate for this with an extra shift.
DB $0F, $EF, $C0 /// PXOR MM0, MM0, clear source pixel register for unpacking
DB $0F, $60, $06 /// PUNPCKLBW MM0, [ESI], unpack source pixel byte values into words
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, move higher bytes to lower bytes
DB $0F, $EF, $C9 /// PXOR MM1, MM1, clear target pixel register for unpacking
DB $0F, $60, $0F /// PUNPCKLBW MM1, [EDI], unpack target pixel byte values into words
DB $0F, $6F, $D1 /// MOVQ MM2, MM1, make a copy of the shifted values, we need them again
DB $0F, $71, $D1, $08 /// PSRLW MM1, 8, move higher bytes to lower bytes
// calculation is: target = (alpha * (source - target) + 256 * target) / 256
DB $0F, $F9, $C1 /// PSUBW MM0, MM1, source - target
DB $0F, $D5, $C6 /// PMULLW MM0, MM6, alpha * (source - target)
DB $0F, $FD, $C2 /// PADDW MM0, MM2, add target (in shifted form)
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, divide by 256
// Bias is accounted for by conversion of range 0..255 to -128..127,
// doing a saturated add and convert back to 0..255.
DB $0F, $F9, $C4 /// PSUBW MM0, MM4
DB $0F, $ED, $C5 /// PADDSW MM0, MM5
DB $0F, $FD, $C4 /// PADDW MM0, MM4
DB $0F, $67, $C0 /// PACKUSWB MM0, MM0, convert words to bytes with saturation
DB $0F, $7E, $07 /// MOVD [EDI], MM0, store the result
@3:
ADD ESI, 4
ADD EDI, 4
DEC ECX
JNZ @1
POP EDI
POP ESI
end;
//----------------------------------------------------------------------------------------------------------------------
procedure AlphaBlendLinePerPixel(Source, Destination: Pointer; Count, Bias: Integer);
// Blends a line of Count pixels from Source to Destination using the alpha value of the source pixels.
// The layout of a pixel must be BGRA.
// Bias is an additional value which gets added to every component and must be in the range -128..127
//
// EAX contains Source
// EDX contains Destination
// ECX contains Count
// Bias is on the stack
asm
PUSH ESI // save used registers
PUSH EDI
MOV ESI, EAX // ESI becomes the actual source pointer
MOV EDI, EDX // EDI becomes the actual target pointer
// Load MM5 with the bias value.
MOV EAX, [Bias]
DB $0F, $6E, $E8 /// MOVD MM5, EAX
DB $0F, $61, $ED /// PUNPCKLWD MM5, MM5
DB $0F, $62, $ED /// PUNPCKLDQ MM5, MM5
// Load MM4 with 128 to allow for saturated biasing.
MOV EAX, 128
DB $0F, $6E, $E0 /// MOVD MM4, EAX
DB $0F, $61, $E4 /// PUNPCKLWD MM4, MM4
DB $0F, $62, $E4 /// PUNPCKLDQ MM4, MM4
@1: // The pixel loop calculates an entire pixel in one run.
// Note: The pixel byte values are expanded into the higher bytes of a word due
// to the way unpacking works. We compensate for this with an extra shift.
DB $0F, $EF, $C0 /// PXOR MM0, MM0, clear source pixel register for unpacking
DB $0F, $60, $06 /// PUNPCKLBW MM0, [ESI], unpack source pixel byte values into words
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, move higher bytes to lower bytes
DB $0F, $EF, $C9 /// PXOR MM1, MM1, clear target pixel register for unpacking
DB $0F, $60, $0F /// PUNPCKLBW MM1, [EDI], unpack target pixel byte values into words
DB $0F, $6F, $D1 /// MOVQ MM2, MM1, make a copy of the shifted values, we need them again
DB $0F, $71, $D1, $08 /// PSRLW MM1, 8, move higher bytes to lower bytes
// Load MM6 with the source alpha value (replicate it for every component).
// Expand it to word size.
DB $0F, $6F, $F0 /// MOVQ MM6, MM0
DB $0F, $69, $F6 /// PUNPCKHWD MM6, MM6
DB $0F, $6A, $F6 /// PUNPCKHDQ MM6, MM6
// calculation is: target = (alpha * (source - target) + 256 * target) / 256
DB $0F, $F9, $C1 /// PSUBW MM0, MM1, source - target
DB $0F, $D5, $C6 /// PMULLW MM0, MM6, alpha * (source - target)
DB $0F, $FD, $C2 /// PADDW MM0, MM2, add target (in shifted form)
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, divide by 256
// Bias is accounted for by conversion of range 0..255 to -128..127,
// doing a saturated add and convert back to 0..255.
DB $0F, $F9, $C4 /// PSUBW MM0, MM4
DB $0F, $ED, $C5 /// PADDSW MM0, MM5
DB $0F, $FD, $C4 /// PADDW MM0, MM4
DB $0F, $67, $C0 /// PACKUSWB MM0, MM0, convert words to bytes with saturation
DB $0F, $7E, $07 /// MOVD [EDI], MM0, store the result
@3:
ADD ESI, 4
ADD EDI, 4
DEC ECX
JNZ @1
POP EDI
POP ESI
end;
//----------------------------------------------------------------------------------------------------------------------
procedure AlphaBlendLineMaster(Source, Destination: Pointer; Count: Integer; ConstantAlpha, Bias: Integer);
// Blends a line of Count pixels from Source to Destination using the source pixel and a constant alpha value.
// The layout of a pixel must be BGRA.
// ConstantAlpha must be in the range 0..255.
// Bias is an additional value which gets added to every component and must be in the range -128..127
//
// EAX contains Source
// EDX contains Destination
// ECX contains Count
// ConstantAlpha and Bias are on the stack
asm
PUSH ESI // save used registers
PUSH EDI
MOV ESI, EAX // ESI becomes the actual source pointer
MOV EDI, EDX // EDI becomes the actual target pointer
// Load MM6 with the constant alpha value (replicate it for every component).
// Expand it to word size.
MOV EAX, [ConstantAlpha]
DB $0F, $6E, $F0 /// MOVD MM6, EAX
DB $0F, $61, $F6 /// PUNPCKLWD MM6, MM6
DB $0F, $62, $F6 /// PUNPCKLDQ MM6, MM6
// Load MM5 with the bias value.
MOV EAX, [Bias]
DB $0F, $6E, $E8 /// MOVD MM5, EAX
DB $0F, $61, $ED /// PUNPCKLWD MM5, MM5
DB $0F, $62, $ED /// PUNPCKLDQ MM5, MM5
// Load MM4 with 128 to allow for saturated biasing.
MOV EAX, 128
DB $0F, $6E, $E0 /// MOVD MM4, EAX
DB $0F, $61, $E4 /// PUNPCKLWD MM4, MM4
DB $0F, $62, $E4 /// PUNPCKLDQ MM4, MM4
@1: // The pixel loop calculates an entire pixel in one run.
// Note: The pixel byte values are expanded into the higher bytes of a word due
// to the way unpacking works. We compensate for this with an extra shift.
DB $0F, $EF, $C0 /// PXOR MM0, MM0, clear source pixel register for unpacking
DB $0F, $60, $06 /// PUNPCKLBW MM0, [ESI], unpack source pixel byte values into words
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, move higher bytes to lower bytes
DB $0F, $EF, $C9 /// PXOR MM1, MM1, clear target pixel register for unpacking
DB $0F, $60, $0F /// PUNPCKLBW MM1, [EDI], unpack target pixel byte values into words
DB $0F, $6F, $D1 /// MOVQ MM2, MM1, make a copy of the shifted values, we need them again
DB $0F, $71, $D1, $08 /// PSRLW MM1, 8, move higher bytes to lower bytes
// Load MM7 with the source alpha value (replicate it for every component).
// Expand it to word size.
DB $0F, $6F, $F8 /// MOVQ MM7, MM0
DB $0F, $69, $FF /// PUNPCKHWD MM7, MM7
DB $0F, $6A, $FF /// PUNPCKHDQ MM7, MM7
DB $0F, $D5, $FE /// PMULLW MM7, MM6, source alpha * master alpha
DB $0F, $71, $D7, $08 /// PSRLW MM7, 8, divide by 256
// calculation is: target = (alpha * master alpha * (source - target) + 256 * target) / 256
DB $0F, $F9, $C1 /// PSUBW MM0, MM1, source - target
DB $0F, $D5, $C7 /// PMULLW MM0, MM7, alpha * (source - target)
DB $0F, $FD, $C2 /// PADDW MM0, MM2, add target (in shifted form)
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, divide by 256
// Bias is accounted for by conversion of range 0..255 to -128..127,
// doing a saturated add and convert back to 0..255.
DB $0F, $F9, $C4 /// PSUBW MM0, MM4
DB $0F, $ED, $C5 /// PADDSW MM0, MM5
DB $0F, $FD, $C4 /// PADDW MM0, MM4
DB $0F, $67, $C0 /// PACKUSWB MM0, MM0, convert words to bytes with saturation
DB $0F, $7E, $07 /// MOVD [EDI], MM0, store the result
@3:
ADD ESI, 4
ADD EDI, 4
DEC ECX
JNZ @1
POP EDI
POP ESI
end;
//----------------------------------------------------------------------------------------------------------------------
procedure AlphaBlendLineMasterAndColor(Destination: Pointer; Count: Integer; ConstantAlpha, Color: Integer);
// Blends a line of Count pixels in Destination against the given color using a constant alpha value.
// The layout of a pixel must be BGRA and Color must be rrggbb00 (as stored by a COLORREF).
// ConstantAlpha must be in the range 0..255.
//
// EAX contains Destination
// EDX contains Count
// ECX contains ConstantAlpha
// Color is passed on the stack
asm
// The used formula is: target = (alpha * color + (256 - alpha) * target) / 256.
// alpha * color (factor 1) and 256 - alpha (factor 2) are constant values which can be calculated in advance.
// The remaining calculation is therefore: target = (F1 + F2 * target) / 256
// Load MM3 with the constant alpha value (replicate it for every component).
// Expand it to word size. (Every calculation here works on word sized operands.)
DB $0F, $6E, $D9 /// MOVD MM3, ECX
DB $0F, $61, $DB /// PUNPCKLWD MM3, MM3
DB $0F, $62, $DB /// PUNPCKLDQ MM3, MM3
// Calculate factor 2.
MOV ECX, $100
DB $0F, $6E, $D1 /// MOVD MM2, ECX
DB $0F, $61, $D2 /// PUNPCKLWD MM2, MM2
DB $0F, $62, $D2 /// PUNPCKLDQ MM2, MM2
DB $0F, $F9, $D3 /// PSUBW MM2, MM3 // MM2 contains now: 255 - alpha = F2
// Now calculate factor 1. Alpha is still in MM3, but the r and b components of Color must be swapped.
MOV ECX, [Color]
BSWAP ECX
ROR ECX, 8
DB $0F, $6E, $C9 /// MOVD MM1, ECX // Load the color and convert to word sized values.
DB $0F, $EF, $E4 /// PXOR MM4, MM4
DB $0F, $60, $CC /// PUNPCKLBW MM1, MM4
DB $0F, $D5, $CB /// PMULLW MM1, MM3 // MM1 contains now: color * alpha = F1
@1: // The pixel loop calculates an entire pixel in one run.
DB $0F, $6E, $00 /// MOVD MM0, [EAX]
DB $0F, $60, $C4 /// PUNPCKLBW MM0, MM4
DB $0F, $D5, $C2 /// PMULLW MM0, MM2 // calculate F1 + F2 * target
DB $0F, $FD, $C1 /// PADDW MM0, MM1
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8 // divide by 256
DB $0F, $67, $C0 /// PACKUSWB MM0, MM0 // convert words to bytes with saturation
DB $0F, $7E, $00 /// MOVD [EAX], MM0 // store the result
ADD EAX, 4
DEC EDX
JNZ @1
end;
//----------------------------------------------------------------------------------------------------------------------
procedure EMMS;
// Reset MMX state to use the FPU for other tasks again.
asm
DB $0F, $77 /// EMMS
end;
//----------------------------------------------------------------------------------------------------------------------
function GetBitmapBitsFromDeviceContext(DC: HDC; out Width, Height: Integer): Pointer;
// Helper function used to retrieve the bitmap selected into the given device context. If there is a bitmap then
// the function will return a pointer to its bits otherwise nil is returned.
// Additionally the dimensions of the bitmap are returned.
var
Bitmap: HBITMAP;
DIB: TDIBSection;
begin
Result := nil;
Width := 0;
Height := 0;
Bitmap := GetCurrentObject(DC, OBJ_BITMAP);
if Bitmap <> 0 then
begin
if GetObject(Bitmap, SizeOf(DIB), @DIB) = SizeOf(DIB) then
begin
Assert(DIB.dsBm.bmPlanes * DIB.dsBm.bmBitsPixel = 32, 'Alpha blending error: bitmap must use 32 bpp.');
Result := DIB.dsBm.bmBits;
Width := DIB.dsBmih.biWidth;
Height := DIB.dsBmih.biHeight;
end;
end;
Assert(Result <> nil, 'Alpha blending DC error: no bitmap available.');
end;
//----------------------------------------------------------------------------------------------------------------------
function GetBitmapBitsFromBitmap(Bitmap: HBITMAP): Pointer;
var
DIB: TDIBSection;
begin
Result := nil;
if Bitmap <> 0 then
begin
if GetObject(Bitmap, SizeOf(DIB), @DIB) = SizeOf(DIB) then
begin
Assert(DIB.dsBm.bmPlanes * DIB.dsBm.bmBitsPixel = 32, 'Alpha blending error: bitmap must use 32 bpp.');
Result := DIB.dsBm.bmBits;
end;
end;
end;
function CalculateScanline(Bits: Pointer; Width, Height, Row: Integer): Pointer;
// Helper function to calculate the start address for the given row.
begin
//todo: Height is always > 0 in LCL
{
if Height > 0 then // bottom-up DIB
Row := Height - Row - 1;
}
// Return DWORD aligned address of the requested scanline.
Result := Bits + Row * ((Width * 32 + 31) and not 31) div 8;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure AlphaBlend(Source, Destination: HDC; const R: TRect; const Target: TPoint; Mode: TBlendMode; ConstantAlpha, Bias: Integer);
// Optimized alpha blend procedure using MMX instructions to perform as quick as possible.
// For this procedure to work properly it is important that both source and target bitmap use the 32 bit color format.
// R describes the source rectangle to work on.
// Target is the place (upper left corner) in the target bitmap where to blend to. Note that source width + X offset
// must be less or equal to the target width. Similar for the height.
// If Mode is bmConstantAlpha then the blend operation uses the given ConstantAlpha value for all pixels.
// If Mode is bmPerPixelAlpha then each pixel is blended using its individual alpha value (the alpha value of the source).
// If Mode is bmMasterAlpha then each pixel is blended using its individual alpha value multiplied by ConstantAlpha.
// If Mode is bmConstantAlphaAndColor then each destination pixel is blended using ConstantAlpha but also a constant
// color which will be obtained from Bias. In this case no offset value is added, otherwise Bias is used as offset.
// Blending of a color into target only (bmConstantAlphaAndColor) ignores Source (the DC) and Target (the position).
// CAUTION: This procedure does not check whether MMX instructions are actually available! Call it only if MMX is really
// usable.
var
Y: Integer;
SourceRun,
TargetRun: PByte;
SourceBits,
DestBits: Pointer;
SourceWidth,
SourceHeight,
DestWidth,
DestHeight: Integer;
//BlendColor: TQColor;
begin
if not IsRectEmpty(R) then
begin
// Note: it is tempting to optimize the special cases for constant alpha 0 and 255 by just ignoring soure
// (alpha = 0) or simply do a blit (alpha = 255). But this does not take the bias into account.
case Mode of
bmConstantAlpha:
begin
// Get a pointer to the bitmap bits for the source and target device contexts.
// Note: this supposes that both contexts do actually have bitmaps assigned!
SourceBits := GetBitmapBitsFromDeviceContext(Source, SourceWidth, SourceHeight);
DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight);
if Assigned(SourceBits) and Assigned(DestBits) then
begin
for Y := 0 to R.Bottom - R.Top - 1 do
begin
SourceRun := CalculateScanline(SourceBits, SourceWidth, SourceHeight, Y + R.Top);
Inc(SourceRun, 4 * R.Left);
TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + Target.Y);
Inc(TargetRun, 4 * Target.X);
AlphaBlendLineConstant(SourceRun, TargetRun, R.Right - R.Left, ConstantAlpha, Bias);
end;
end;
EMMS;
end;
bmPerPixelAlpha:
begin
SourceBits := GetBitmapBitsFromDeviceContext(Source, SourceWidth, SourceHeight);
DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight);
if Assigned(SourceBits) and Assigned(DestBits) then
begin
for Y := 0 to R.Bottom - R.Top - 1 do
begin
SourceRun := CalculateScanline(SourceBits, SourceWidth, SourceHeight, Y + R.Top);
Inc(SourceRun, 4 * R.Left);
TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + Target.Y);
Inc(TargetRun, 4 * Target.X);
AlphaBlendLinePerPixel(SourceRun, TargetRun, R.Right - R.Left, Bias);
end;
end;
EMMS;
end;
bmMasterAlpha:
begin
SourceBits := GetBitmapBitsFromDeviceContext(Source, SourceWidth, SourceHeight);
DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight);
if Assigned(SourceBits) and Assigned(DestBits) then
begin
for Y := 0 to R.Bottom - R.Top - 1 do
begin
SourceRun := CalculateScanline(SourceBits, SourceWidth, SourceHeight, Y + R.Top);
Inc(SourceRun, 4 * Target.X);
TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + Target.Y);
AlphaBlendLineMaster(SourceRun, TargetRun, R.Right - R.Left, ConstantAlpha, Bias);
end;
end;
EMMS;
end;
bmConstantAlphaAndColor:
begin
//todo: see why is not working
{
QColor_fromRgb(@BlendColor,
Bias and $000000FF,
(Bias shr 8) and $000000FF,
(Bias shr 16) and $000000FF,
ConstantAlpha);
QPainter_fillRect(TQTDeviceContext(Destination).Widget,
R.Left + Target.x, R.Top + Target.y,
R.Right - R.Left, R.Bottom - R.Top, @BlendColor);
}
// Source is ignored since there is a constant color value.
DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight);
if Assigned(DestBits) then
begin
for Y := 0 to R.Bottom - R.Top - 1 do
begin
TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + R.Top);
Inc(TargetRun, 4 * R.Left);
AlphaBlendLineMasterAndColor(TargetRun, R.Right - R.Left, ConstantAlpha, Bias);
end;
end;
EMMS;
end;
end;
end;
end;

2
components/virtualtreeview/include/intf/qt/vtvdragmanager.inc Normal file
View file

@ -0,0 +1,2 @@
{$i ../dummydragmanager.inc}

396
components/virtualtreeview/include/intf/win32/olemethods.inc Normal file
View file

@ -0,0 +1,396 @@
function TBaseVirtualTree.GetTreeFromDataObject(const DataObject: IDataObject): TBaseVirtualTree;
// Returns the owner/sender of the given data object by means of a special clipboard format
// or nil if the sender is in another process or no virtual tree at all.
var
Medium: TStgMedium;
Data: PVTReference;
begin
Result := nil;
if Assigned(DataObject) then
begin
StandardOLEFormat.cfFormat := CF_VTREFERENCE;
if DataObject.GetData(StandardOLEFormat, Medium) = S_OK then
begin
Data := GlobalLock(Medium.hGlobal);
if Assigned(Data) then
begin
if Data.Process = GetCurrentProcessID then
Result := Data.Tree;
GlobalUnlock(Medium.hGlobal);
end;
ReleaseStgMedium(@Medium);
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TBaseVirtualTree.RenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium;
ForClipboard: Boolean): HResult;
// Returns a memory expression of all currently selected nodes in the Medium structure.
// Note: The memory requirement of this method might be very high. This depends however on the requested storage format.
// For HGlobal (a global memory block) we need to render first all nodes to local memory and copy this then to
// the global memory in Medium. This is necessary because we have first to determine how much
// memory is needed before we can allocate it. Hence for a short moment we need twice the space as used by the
// nodes alone (plus the amount the nodes need in the tree anyway)!
// With IStream this does not happen. We directly stream out the nodes and pass the constructed stream along.
//--------------- local function --------------------------------------------
procedure WriteNodes(Stream: TStream);
var
Selection: TNodeArray;
I: Integer;
begin
if ForClipboard then
Selection := GetSortedCutCopySet(True)
else
Selection := GetSortedSelection(True);
for I := 0 to High(Selection) do
WriteNode(Stream, Selection[I]);
end;
//--------------- end local function ----------------------------------------
var
Data: PCardinal;
ResPointer: Pointer;
ResSize: Integer;
OLEStream: IStream;
VCLStream: TStream;
begin
FillChar(Medium, SizeOf(Medium), 0);
// We can render the native clipboard format in two different storage media.
if (FormatEtcIn.cfFormat = CF_VIRTUALTREE) and (FormatEtcIn.tymed and (TYMED_HGLOBAL or TYMED_ISTREAM) <> 0) then
begin
VCLStream := nil;
try
Medium.PunkForRelease := nil;
// Return data in one of the supported storage formats, prefer IStream.
if FormatEtcIn.tymed and TYMED_ISTREAM <> 0 then
begin
// Create an IStream on a memory handle (here it is 0 which indicates to implicitely allocated a handle).
// Do not use TStreamAdapter as it is not compatible with OLE (when flushing the clipboard OLE wants the HGlobal
// back which is not supported by TStreamAdapater).
CreateStreamOnHGlobal(0, True, OLEStream);
VCLStream := TOLEStream.Create(OLEStream);
WriteNodes(VCLStream);
// Rewind stream.
VCLStream.Position := 0;
Medium.tymed := TYMED_ISTREAM;
IUnknown(Medium.Pstm) := OLEStream;
Result := S_OK;
end
else
begin
VCLStream := TMemoryStream.Create;
WriteNodes(VCLStream);
ResPointer := TMemoryStream(VCLStream).Memory;
ResSize := VCLStream.Position;
// Allocate memory to hold the string.
if ResSize > 0 then
begin
Medium.hGlobal := GlobalAlloc(GHND or GMEM_SHARE, ResSize + SizeOf(Cardinal));
Data := GlobalLock(Medium.hGlobal);
// Store the size of the data too, for easy retrival.
Data^ := ResSize;
Inc(Data);
Move(ResPointer^, Data^, ResSize);
GlobalUnlock(Medium.hGlobal);
Medium.tymed := TYMED_HGLOBAL;
Result := S_OK;
end
else
Result := E_FAIL;
end;
finally
// We can free the VCL stream here since it was either a pure memory stream or only a wrapper around
// the OLEStream which exists independently.
VCLStream.Free;
end;
end
else // Ask application descendants to render self defined formats.
Result := DoRenderOLEData(FormatEtcIn, Medium, ForClipboard);
end;
//----------------------------------------------------------------------------------------------------------------------
type
// needed to handle OLE global memory objects
TOLEMemoryStream = class(TCustomMemoryStream)
public
function Write(const Buffer; Count: Integer): Longint; override;
end;
//----------------------------------------------------------------------------------------------------------------------
function TOLEMemoryStream.Write(const Buffer; Count: Integer): Integer;
begin
//raise EStreamError.CreateRes(PResStringRec(@SCantWriteResourceStreamError));
raise EStreamError.Create(SCantWriteResourceStreamError);
end;
//----------------------------------------------------------------------------------------------------------------------
function TBaseVirtualTree.ProcessOLEData(Source: TBaseVirtualTree; DataObject: IDataObject; TargetNode: PVirtualNode;
Mode: TVTNodeAttachMode; Optimized: Boolean): Boolean;
// Recreates the (sub) tree structure serialized into memory and provided by DataObject. The new nodes are attached to
// the passed node or FRoot if TargetNode is nil according to Mode. Optimized can be set to True if the entire operation
// happens within the same process (i.e. sender and receiver of the OLE operation are located in the same process).
// Optimize = True makes only sense if the operation to carry out is a move hence it is also the indication of the
// operation to be done here. Source is the source of the OLE data and only of use (and usually assigned) when
// an OLE operation takes place in the same application.
// Returns True on success, i.e. the CF_VIRTUALTREE format is supported by the data object and the structure could be
// recreated, otherwise False.
var
Medium: TStgMedium;
Stream: TStream;
Data: Pointer;
Node: PVirtualNode;
Nodes: TNodeArray;
I: Integer;
Res: HRESULT;
ChangeReason: TChangeReason;
begin
Nodes := nil;
// Check the data format available by the data object.
with StandardOLEFormat do
begin
// Read best format.
cfFormat := CF_VIRTUALTREE;
end;
Result := DataObject.QueryGetData(StandardOLEFormat) = S_OK;
if Result and not (toReadOnly in FOptions.FMiscOptions) then
begin
BeginUpdate;
Result := False;
try
if TargetNode = nil then
TargetNode := FRoot;
if TargetNode = FRoot then
begin
case Mode of
amInsertBefore:
Mode := amAddChildFirst;
amInsertAfter:
Mode := amAddChildLast;
end;
end;
// Optimized means source is known and in the same process so we can access its pointers, which avoids duplicating
// the data while doing a serialization. Can only be used with cut'n paste and drag'n drop with move effect.
if Optimized then
begin
if tsOLEDragging in Source.FStates then
Nodes := Source.FDragSelection
else
Nodes := Source.GetSortedCutCopySet(True);
if Mode in [amInsertBefore,amAddChildLast] then
begin
for I := 0 to High(Nodes) do
if not HasAsParent(TargetNode, Nodes[I]) then
Source.MoveTo(Nodes[I], TargetNode, Mode, False);
end
else
begin
for I := High(Nodes) downto 0 do
if not HasAsParent(TargetNode, Nodes[I]) then
Source.MoveTo(Nodes[I], TargetNode, Mode, False);
end;
Result := True;
end
else
begin
if Source = Self then
ChangeReason := crNodeCopied
else
ChangeReason := crNodeAdded;
Res := DataObject.GetData(StandardOLEFormat, Medium);
if Res = S_OK then
begin
case Medium.tymed of
TYMED_ISTREAM, // IStream interface
TYMED_HGLOBAL: // global memory block
begin
Stream := nil;
if Medium.tymed = TYMED_ISTREAM then
Stream := TOLEStream.Create(IUnknown(Medium.Pstm) as IStream)
else
begin
Data := GlobalLock(Medium.hGlobal);
if Assigned(Data) then
begin
// Get the total size of data to retrieve.
I := PCardinal(Data)^;
Inc(PCardinal(Data));
Stream := TOLEMemoryStream.Create;
TOLEMemoryStream(Stream).SetPointer(Data, I);
end;
end;
if Assigned(Stream) then
try
while Stream.Position < Stream.Size do
begin
Node := MakeNewNode;
InternalConnectNode(Node, TargetNode, Self, Mode);
InternalAddFromStream(Stream, VTTreeStreamVersion, Node);
// This seems a bit strange because of the callback for granting to add the node
// which actually comes after the node has been added. The reason is that the node must
// contain valid data otherwise I don't see how the application can make a funded decision.
if not DoNodeCopying(Node, TargetNode) then
DeleteNode(Node)
else
DoNodeCopied(Node);
StructureChange(Node, ChangeReason);
// In order to maintain the same node order when restoring nodes in the case of amInsertAfter
// we have to move the reference node continously. Othwise we would end up with reversed node order.
if Mode = amInsertAfter then
TargetNode := Node;
end;
Result := True;
finally
Stream.Free;
if Medium.tymed = TYMED_HGLOBAL then
GlobalUnlock(Medium.hGlobal);
end;
end;
end;
ReleaseStgMedium(@Medium);
end;
end;
finally
EndUpdate;
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TCustomVirtualStringTree.ContentToClipboard(Format: Word; Source: TVSTTextSourceType): HGLOBAL;
// This method constructs a shareable memory object filled with string data in the required format. Supported are:
// CF_TEXT - plain ANSI text (Unicode text is converted using the user's current locale)
// CF_UNICODETEXT - plain Unicode text
// CF_CSV - comma separated plain ANSI text
// CF_VRTF + CF_RTFNOOBS - rich text (plain ANSI)
// CF_HTML - HTML text encoded using UTF-8
//
// Result is the handle to a globally allocated memory block which can directly be used for clipboard and drag'n drop
// transfers. The caller is responsible for freeing the memory. If for some reason the content could not be rendered
// the Result is 0.
//--------------- local function --------------------------------------------
procedure MakeFragment(var HTML: string);
// Helper routine to build a properly-formatted HTML fragment.
const
Version = 'Version:1.0'#13#10;
StartHTML = 'StartHTML:';
EndHTML = 'EndHTML:';
StartFragment = 'StartFragment:';
EndFragment = 'EndFragment:';
DocType = '<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">';
HTMLIntro = '<html><head><META http-equiv=Content-Type content="text/html; charset=utf-8">' +
'</head><body><!--StartFragment-->';
HTMLExtro = '<!--EndFragment--></body></html>';
NumberLengthAndCR = 10;
// Let the compiler determine the description length.
DescriptionLength = Length(Version) + Length(StartHTML) + Length(EndHTML) + Length(StartFragment) +
Length(EndFragment) + 4 * NumberLengthAndCR;
var
Description: string;
StartHTMLIndex,
EndHTMLIndex,
StartFragmentIndex,
EndFragmentIndex: Integer;
begin
// The HTML clipboard format is defined by using byte positions in the entire block where HTML text and
// fragments start and end. These positions are written in a description. Unfortunately the positions depend on the
// length of the description but the description may change with varying positions.
// To solve this dilemma the offsets are converted into fixed length strings which makes it possible to know
// the description length in advance.
StartHTMLIndex := DescriptionLength; // position 0 after the description
StartFragmentIndex := StartHTMLIndex + Length(DocType) + Length(HTMLIntro);
EndFragmentIndex := StartFragmentIndex + Length(HTML);
EndHTMLIndex := EndFragmentIndex + Length(HTMLExtro);
Description := Version +
SysUtils.Format('%s%.8d', [StartHTML, StartHTMLIndex]) + #13#10 +
SysUtils.Format('%s%.8d', [EndHTML, EndHTMLIndex]) + #13#10 +
SysUtils.Format('%s%.8d', [StartFragment, StartFragmentIndex]) + #13#10 +
SysUtils.Format('%s%.8d', [EndFragment, EndFragmentIndex]) + #13#10;
HTML := Description + DocType + HTMLIntro + HTML + HTMLExtro;
end;
//--------------- end local function ----------------------------------------
var
Data: Pointer;
DataSize: Cardinal;
S: string;
WS: UnicodeString;
P: Pointer;
begin
Result := 0;
case Format of
CF_TEXT:
begin
S := ContentToAnsi(Source, #9) + #0;
Data := PChar(S);
DataSize := Length(S);
end;
CF_UNICODETEXT:
begin
WS := ContentToUTF16(Source, #9) + #0;
Data := PWideChar(WS);
DataSize := 2 * Length(WS);
end;
else
if Format = CF_CSV then
S := ContentToAnsi(Source, ListSeparator) + #0
else
if (Format = CF_VRTF) or (Format = CF_VRTFNOOBJS) then
S := ContentToRTF(Source) + #0
else
if Format = CF_HTML then
begin
S := ContentToHTML(Source);
// Build a valid HTML clipboard fragment.
MakeFragment(S);
S := S + #0;
end;
Data := PChar(S);
DataSize := Length(S);
end;
if DataSize > 0 then
begin
Result := GlobalAlloc(GHND or GMEM_SHARE, DataSize);
P := GlobalLock(Result);
Move(Data^, P^, DataSize);
GlobalUnlock(Result);
end;
end;

460
components/virtualtreeview/include/intf/win32/vtgraphicsi.inc Normal file
View file

@ -0,0 +1,460 @@
procedure AlphaBlendLineConstant(Source, Destination: Pointer; Count: Integer; ConstantAlpha, Bias: Integer);
// Blends a line of Count pixels from Source to Destination using a constant alpha value.
// The layout of a pixel must be BGRA where A is ignored (but is calculated as the other components).
// ConstantAlpha must be in the range 0..255 where 0 means totally transparent (destination pixel only)
// and 255 totally opaque (source pixel only).
// Bias is an additional value which gets added to every component and must be in the range -128..127
//
// EAX contains Source
// EDX contains Destination
// ECX contains Count
// ConstantAlpha and Bias are on the stack
asm
PUSH ESI // save used registers
PUSH EDI
MOV ESI, EAX // ESI becomes the actual source pointer
MOV EDI, EDX // EDI becomes the actual target pointer
// Load MM6 with the constant alpha value (replicate it for every component).
// Expand it to word size.
MOV EAX, [ConstantAlpha]
DB $0F, $6E, $F0 /// MOVD MM6, EAX
DB $0F, $61, $F6 /// PUNPCKLWD MM6, MM6
DB $0F, $62, $F6 /// PUNPCKLDQ MM6, MM6
// Load MM5 with the bias value.
MOV EAX, [Bias]
DB $0F, $6E, $E8 /// MOVD MM5, EAX
DB $0F, $61, $ED /// PUNPCKLWD MM5, MM5
DB $0F, $62, $ED /// PUNPCKLDQ MM5, MM5
// Load MM4 with 128 to allow for saturated biasing.
MOV EAX, 128
DB $0F, $6E, $E0 /// MOVD MM4, EAX
DB $0F, $61, $E4 /// PUNPCKLWD MM4, MM4
DB $0F, $62, $E4 /// PUNPCKLDQ MM4, MM4
@1: // The pixel loop calculates an entire pixel in one run.
// Note: The pixel byte values are expanded into the higher bytes of a word due
// to the way unpacking works. We compensate for this with an extra shift.
DB $0F, $EF, $C0 /// PXOR MM0, MM0, clear source pixel register for unpacking
DB $0F, $60, $06 /// PUNPCKLBW MM0, [ESI], unpack source pixel byte values into words
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, move higher bytes to lower bytes
DB $0F, $EF, $C9 /// PXOR MM1, MM1, clear target pixel register for unpacking
DB $0F, $60, $0F /// PUNPCKLBW MM1, [EDI], unpack target pixel byte values into words
DB $0F, $6F, $D1 /// MOVQ MM2, MM1, make a copy of the shifted values, we need them again
DB $0F, $71, $D1, $08 /// PSRLW MM1, 8, move higher bytes to lower bytes
// calculation is: target = (alpha * (source - target) + 256 * target) / 256
DB $0F, $F9, $C1 /// PSUBW MM0, MM1, source - target
DB $0F, $D5, $C6 /// PMULLW MM0, MM6, alpha * (source - target)
DB $0F, $FD, $C2 /// PADDW MM0, MM2, add target (in shifted form)
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, divide by 256
// Bias is accounted for by conversion of range 0..255 to -128..127,
// doing a saturated add and convert back to 0..255.
DB $0F, $F9, $C4 /// PSUBW MM0, MM4
DB $0F, $ED, $C5 /// PADDSW MM0, MM5
DB $0F, $FD, $C4 /// PADDW MM0, MM4
DB $0F, $67, $C0 /// PACKUSWB MM0, MM0, convert words to bytes with saturation
DB $0F, $7E, $07 /// MOVD [EDI], MM0, store the result
@3:
ADD ESI, 4
ADD EDI, 4
DEC ECX
JNZ @1
POP EDI
POP ESI
end;
//----------------------------------------------------------------------------------------------------------------------
procedure AlphaBlendLinePerPixel(Source, Destination: Pointer; Count, Bias: Integer);
// Blends a line of Count pixels from Source to Destination using the alpha value of the source pixels.
// The layout of a pixel must be BGRA.
// Bias is an additional value which gets added to every component and must be in the range -128..127
//
// EAX contains Source
// EDX contains Destination
// ECX contains Count
// Bias is on the stack
asm
PUSH ESI // save used registers
PUSH EDI
MOV ESI, EAX // ESI becomes the actual source pointer
MOV EDI, EDX // EDI becomes the actual target pointer
// Load MM5 with the bias value.
MOV EAX, [Bias]
DB $0F, $6E, $E8 /// MOVD MM5, EAX
DB $0F, $61, $ED /// PUNPCKLWD MM5, MM5
DB $0F, $62, $ED /// PUNPCKLDQ MM5, MM5
// Load MM4 with 128 to allow for saturated biasing.
MOV EAX, 128
DB $0F, $6E, $E0 /// MOVD MM4, EAX
DB $0F, $61, $E4 /// PUNPCKLWD MM4, MM4
DB $0F, $62, $E4 /// PUNPCKLDQ MM4, MM4
@1: // The pixel loop calculates an entire pixel in one run.
// Note: The pixel byte values are expanded into the higher bytes of a word due
// to the way unpacking works. We compensate for this with an extra shift.
DB $0F, $EF, $C0 /// PXOR MM0, MM0, clear source pixel register for unpacking
DB $0F, $60, $06 /// PUNPCKLBW MM0, [ESI], unpack source pixel byte values into words
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, move higher bytes to lower bytes
DB $0F, $EF, $C9 /// PXOR MM1, MM1, clear target pixel register for unpacking
DB $0F, $60, $0F /// PUNPCKLBW MM1, [EDI], unpack target pixel byte values into words
DB $0F, $6F, $D1 /// MOVQ MM2, MM1, make a copy of the shifted values, we need them again
DB $0F, $71, $D1, $08 /// PSRLW MM1, 8, move higher bytes to lower bytes
// Load MM6 with the source alpha value (replicate it for every component).
// Expand it to word size.
DB $0F, $6F, $F0 /// MOVQ MM6, MM0
DB $0F, $69, $F6 /// PUNPCKHWD MM6, MM6
DB $0F, $6A, $F6 /// PUNPCKHDQ MM6, MM6
// calculation is: target = (alpha * (source - target) + 256 * target) / 256
DB $0F, $F9, $C1 /// PSUBW MM0, MM1, source - target
DB $0F, $D5, $C6 /// PMULLW MM0, MM6, alpha * (source - target)
DB $0F, $FD, $C2 /// PADDW MM0, MM2, add target (in shifted form)
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, divide by 256
// Bias is accounted for by conversion of range 0..255 to -128..127,
// doing a saturated add and convert back to 0..255.
DB $0F, $F9, $C4 /// PSUBW MM0, MM4
DB $0F, $ED, $C5 /// PADDSW MM0, MM5
DB $0F, $FD, $C4 /// PADDW MM0, MM4
DB $0F, $67, $C0 /// PACKUSWB MM0, MM0, convert words to bytes with saturation
DB $0F, $7E, $07 /// MOVD [EDI], MM0, store the result
@3:
ADD ESI, 4
ADD EDI, 4
DEC ECX
JNZ @1
POP EDI
POP ESI
end;
//----------------------------------------------------------------------------------------------------------------------
procedure AlphaBlendLineMaster(Source, Destination: Pointer; Count: Integer; ConstantAlpha, Bias: Integer);
// Blends a line of Count pixels from Source to Destination using the source pixel and a constant alpha value.
// The layout of a pixel must be BGRA.
// ConstantAlpha must be in the range 0..255.
// Bias is an additional value which gets added to every component and must be in the range -128..127
//
// EAX contains Source
// EDX contains Destination
// ECX contains Count
// ConstantAlpha and Bias are on the stack
asm
PUSH ESI // save used registers
PUSH EDI
MOV ESI, EAX // ESI becomes the actual source pointer
MOV EDI, EDX // EDI becomes the actual target pointer
// Load MM6 with the constant alpha value (replicate it for every component).
// Expand it to word size.
MOV EAX, [ConstantAlpha]
DB $0F, $6E, $F0 /// MOVD MM6, EAX
DB $0F, $61, $F6 /// PUNPCKLWD MM6, MM6
DB $0F, $62, $F6 /// PUNPCKLDQ MM6, MM6
// Load MM5 with the bias value.
MOV EAX, [Bias]
DB $0F, $6E, $E8 /// MOVD MM5, EAX
DB $0F, $61, $ED /// PUNPCKLWD MM5, MM5
DB $0F, $62, $ED /// PUNPCKLDQ MM5, MM5
// Load MM4 with 128 to allow for saturated biasing.
MOV EAX, 128
DB $0F, $6E, $E0 /// MOVD MM4, EAX
DB $0F, $61, $E4 /// PUNPCKLWD MM4, MM4
DB $0F, $62, $E4 /// PUNPCKLDQ MM4, MM4
@1: // The pixel loop calculates an entire pixel in one run.
// Note: The pixel byte values are expanded into the higher bytes of a word due
// to the way unpacking works. We compensate for this with an extra shift.
DB $0F, $EF, $C0 /// PXOR MM0, MM0, clear source pixel register for unpacking
DB $0F, $60, $06 /// PUNPCKLBW MM0, [ESI], unpack source pixel byte values into words
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, move higher bytes to lower bytes
DB $0F, $EF, $C9 /// PXOR MM1, MM1, clear target pixel register for unpacking
DB $0F, $60, $0F /// PUNPCKLBW MM1, [EDI], unpack target pixel byte values into words
DB $0F, $6F, $D1 /// MOVQ MM2, MM1, make a copy of the shifted values, we need them again
DB $0F, $71, $D1, $08 /// PSRLW MM1, 8, move higher bytes to lower bytes
// Load MM7 with the source alpha value (replicate it for every component).
// Expand it to word size.
DB $0F, $6F, $F8 /// MOVQ MM7, MM0
DB $0F, $69, $FF /// PUNPCKHWD MM7, MM7
DB $0F, $6A, $FF /// PUNPCKHDQ MM7, MM7
DB $0F, $D5, $FE /// PMULLW MM7, MM6, source alpha * master alpha
DB $0F, $71, $D7, $08 /// PSRLW MM7, 8, divide by 256
// calculation is: target = (alpha * master alpha * (source - target) + 256 * target) / 256
DB $0F, $F9, $C1 /// PSUBW MM0, MM1, source - target
DB $0F, $D5, $C7 /// PMULLW MM0, MM7, alpha * (source - target)
DB $0F, $FD, $C2 /// PADDW MM0, MM2, add target (in shifted form)
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, divide by 256
// Bias is accounted for by conversion of range 0..255 to -128..127,
// doing a saturated add and convert back to 0..255.
DB $0F, $F9, $C4 /// PSUBW MM0, MM4
DB $0F, $ED, $C5 /// PADDSW MM0, MM5
DB $0F, $FD, $C4 /// PADDW MM0, MM4
DB $0F, $67, $C0 /// PACKUSWB MM0, MM0, convert words to bytes with saturation
DB $0F, $7E, $07 /// MOVD [EDI], MM0, store the result
@3:
ADD ESI, 4
ADD EDI, 4
DEC ECX
JNZ @1
POP EDI
POP ESI
end;
//----------------------------------------------------------------------------------------------------------------------
procedure AlphaBlendLineMasterAndColor(Destination: Pointer; Count: Integer; ConstantAlpha, Color: Integer);
// Blends a line of Count pixels in Destination against the given color using a constant alpha value.
// The layout of a pixel must be BGRA and Color must be rrggbb00 (as stored by a COLORREF).
// ConstantAlpha must be in the range 0..255.
//
// EAX contains Destination
// EDX contains Count
// ECX contains ConstantAlpha
// Color is passed on the stack
asm
// The used formula is: target = (alpha * color + (256 - alpha) * target) / 256.
// alpha * color (factor 1) and 256 - alpha (factor 2) are constant values which can be calculated in advance.
// The remaining calculation is therefore: target = (F1 + F2 * target) / 256
// Load MM3 with the constant alpha value (replicate it for every component).
// Expand it to word size. (Every calculation here works on word sized operands.)
DB $0F, $6E, $D9 /// MOVD MM3, ECX
DB $0F, $61, $DB /// PUNPCKLWD MM3, MM3
DB $0F, $62, $DB /// PUNPCKLDQ MM3, MM3
// Calculate factor 2.
MOV ECX, $100
DB $0F, $6E, $D1 /// MOVD MM2, ECX
DB $0F, $61, $D2 /// PUNPCKLWD MM2, MM2
DB $0F, $62, $D2 /// PUNPCKLDQ MM2, MM2
DB $0F, $F9, $D3 /// PSUBW MM2, MM3 // MM2 contains now: 255 - alpha = F2
// Now calculate factor 1. Alpha is still in MM3, but the r and b components of Color must be swapped.
MOV ECX, [Color]
BSWAP ECX
ROR ECX, 8
DB $0F, $6E, $C9 /// MOVD MM1, ECX // Load the color and convert to word sized values.
DB $0F, $EF, $E4 /// PXOR MM4, MM4
DB $0F, $60, $CC /// PUNPCKLBW MM1, MM4
DB $0F, $D5, $CB /// PMULLW MM1, MM3 // MM1 contains now: color * alpha = F1
@1: // The pixel loop calculates an entire pixel in one run.
DB $0F, $6E, $00 /// MOVD MM0, [EAX]
DB $0F, $60, $C4 /// PUNPCKLBW MM0, MM4
DB $0F, $D5, $C2 /// PMULLW MM0, MM2 // calculate F1 + F2 * target
DB $0F, $FD, $C1 /// PADDW MM0, MM1
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8 // divide by 256
DB $0F, $67, $C0 /// PACKUSWB MM0, MM0 // convert words to bytes with saturation
DB $0F, $7E, $00 /// MOVD [EAX], MM0 // store the result
ADD EAX, 4
DEC EDX
JNZ @1
end;
//----------------------------------------------------------------------------------------------------------------------
procedure EMMS;
// Reset MMX state to use the FPU for other tasks again.
asm
DB $0F, $77 /// EMMS
end;
//----------------------------------------------------------------------------------------------------------------------
function GetBitmapBitsFromDeviceContext(DC: HDC; out Width, Height: Integer): Pointer;
// Helper function used to retrieve the bitmap selected into the given device context. If there is a bitmap then
// the function will return a pointer to its bits otherwise nil is returned.
// Additionally the dimensions of the bitmap are returned.
var
Bitmap: HBITMAP;
DIB: TDIBSection;
begin
Result := nil;
Width := 0;
Height := 0;
Bitmap := GetCurrentObject(DC, OBJ_BITMAP);
if Bitmap <> 0 then
begin
if GetObject(Bitmap, SizeOf(DIB), @DIB) = SizeOf(DIB) then
begin
Assert(DIB.dsBm.bmPlanes * DIB.dsBm.bmBitsPixel = 32, 'Alpha blending error: bitmap must use 32 bpp.');
Result := DIB.dsBm.bmBits;
Width := DIB.dsBmih.biWidth;
Height := DIB.dsBmih.biHeight;
end;
end;
Assert(Result <> nil, 'Alpha blending DC error: no bitmap available.');
end;
//----------------------------------------------------------------------------------------------------------------------
function GetBitmapBitsFromBitmap(Bitmap: HBITMAP): Pointer;
var
DIB: TDIBSection;
begin
Result := nil;
if Bitmap <> 0 then
begin
if GetObject(Bitmap, SizeOf(DIB), @DIB) = SizeOf(DIB) then
begin
Assert(DIB.dsBm.bmPlanes * DIB.dsBm.bmBitsPixel = 32, 'Alpha blending error: bitmap must use 32 bpp.');
Result := DIB.dsBm.bmBits;
end;
end;
end;
function CalculateScanline(Bits: Pointer; Width, Height, Row: Integer): Pointer;
// Helper function to calculate the start address for the given row.
begin
//todo: Height is always > 0 in LCL
{
if Height > 0 then // bottom-up DIB
Row := Height - Row - 1;
}
// Return DWORD aligned address of the requested scanline.
Result := Bits + Row * ((Width * 32 + 31) and not 31) div 8;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure AlphaBlend(Source, Destination: HDC; const R: TRect; const Target: TPoint; Mode: TBlendMode; ConstantAlpha, Bias: Integer);
// Optimized alpha blend procedure using MMX instructions to perform as quick as possible.
// For this procedure to work properly it is important that both source and target bitmap use the 32 bit color format.
// R describes the source rectangle to work on.
// Target is the place (upper left corner) in the target bitmap where to blend to. Note that source width + X offset
// must be less or equal to the target width. Similar for the height.
// If Mode is bmConstantAlpha then the blend operation uses the given ConstantAlpha value for all pixels.
// If Mode is bmPerPixelAlpha then each pixel is blended using its individual alpha value (the alpha value of the source).
// If Mode is bmMasterAlpha then each pixel is blended using its individual alpha value multiplied by ConstantAlpha.
// If Mode is bmConstantAlphaAndColor then each destination pixel is blended using ConstantAlpha but also a constant
// color which will be obtained from Bias. In this case no offset value is added, otherwise Bias is used as offset.
// Blending of a color into target only (bmConstantAlphaAndColor) ignores Source (the DC) and Target (the position).
// CAUTION: This procedure does not check whether MMX instructions are actually available! Call it only if MMX is really
// usable.
var
Y: Integer;
SourceRun,
TargetRun: PByte;
SourceBits,
DestBits: Pointer;
SourceWidth,
SourceHeight,
DestWidth,
DestHeight: Integer;
begin
if not IsRectEmpty(R) then
begin
// Note: it is tempting to optimize the special cases for constant alpha 0 and 255 by just ignoring soure
// (alpha = 0) or simply do a blit (alpha = 255). But this does not take the bias into account.
case Mode of
bmConstantAlpha:
begin
// Get a pointer to the bitmap bits for the source and target device contexts.
// Note: this supposes that both contexts do actually have bitmaps assigned!
SourceBits := GetBitmapBitsFromDeviceContext(Source, SourceWidth, SourceHeight);
DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight);
if Assigned(SourceBits) and Assigned(DestBits) then
begin
for Y := 0 to R.Bottom - R.Top - 1 do
begin
SourceRun := CalculateScanline(SourceBits, SourceWidth, SourceHeight, Y + R.Top);
Inc(SourceRun, 4 * R.Left);
TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + Target.Y);
Inc(TargetRun, 4 * Target.X);
AlphaBlendLineConstant(SourceRun, TargetRun, R.Right - R.Left, ConstantAlpha, Bias);
end;
end;
EMMS;
end;
bmPerPixelAlpha:
begin
SourceBits := GetBitmapBitsFromDeviceContext(Source, SourceWidth, SourceHeight);
DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight);
if Assigned(SourceBits) and Assigned(DestBits) then
begin
for Y := 0 to R.Bottom - R.Top - 1 do
begin
SourceRun := CalculateScanline(SourceBits, SourceWidth, SourceHeight, Y + R.Top);
Inc(SourceRun, 4 * R.Left);
TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + Target.Y);
Inc(TargetRun, 4 * Target.X);
AlphaBlendLinePerPixel(SourceRun, TargetRun, R.Right - R.Left, Bias);
end;
end;
EMMS;
end;
bmMasterAlpha:
begin
SourceBits := GetBitmapBitsFromDeviceContext(Source, SourceWidth, SourceHeight);
DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight);
if Assigned(SourceBits) and Assigned(DestBits) then
begin
for Y := 0 to R.Bottom - R.Top - 1 do
begin
SourceRun := CalculateScanline(SourceBits, SourceWidth, SourceHeight, Y + R.Top);
Inc(SourceRun, 4 * Target.X);
TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + Target.Y);
AlphaBlendLineMaster(SourceRun, TargetRun, R.Right - R.Left, ConstantAlpha, Bias);
end;
end;
EMMS;
end;
bmConstantAlphaAndColor:
begin
// Source is ignored since there is a constant color value.
DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight);
if Assigned(DestBits) then
begin
for Y := 0 to R.Bottom - R.Top - 1 do
begin
TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + R.Top);
Inc(TargetRun, 4 * R.Left);
AlphaBlendLineMasterAndColor(TargetRun, R.Right - R.Left, ConstantAlpha, Bias);
end;
end;
EMMS;
end;
end;
end;
end;

718
components/virtualtreeview/include/intf/win32/vtvdragmanager.inc Normal file
View file

@ -0,0 +1,718 @@
//----------------------------------------------------------------------------------------------------------------------
// OLE drag and drop support classes
// This is quite heavy stuff (compared with the VCL implementation) but is much better suited to fit the needs
// of DD'ing various kinds of virtual data and works also between applications.
//----------------- TEnumFormatEtc -------------------------------------------------------------------------------------
constructor TEnumFormatEtc.Create(Tree: TBaseVirtualTree; AFormatEtcArray: TFormatEtcArray);
var
I: Integer;
begin
inherited Create;
FTree := Tree;
// Make a local copy of the format data.
SetLength(FFormatEtcArray, Length(AFormatEtcArray));
for I := 0 to High(AFormatEtcArray) do
FFormatEtcArray[I] := AFormatEtcArray[I];
end;
//----------------------------------------------------------------------------------------------------------------------
function TEnumFormatEtc.Clone(out Enum: IEnumFormatEtc): HResult;
var
AClone: TEnumFormatEtc;
begin
Result := S_OK;
try
AClone := TEnumFormatEtc.Create(nil, FFormatEtcArray);
AClone.FCurrentIndex := FCurrentIndex;
Enum := AClone as IEnumFormatEtc;
except
Result := E_FAIL;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TEnumFormatEtc.Next(celt: LongWord; out elt: FormatEtc; pceltFetched:pULong=nil): HResult;
var
CopyCount: LongWord;
begin
Result := S_FALSE;
CopyCount := Length(FFormatEtcArray) - FCurrentIndex;
if celt < CopyCount then
CopyCount := celt;
if CopyCount > 0 then
begin
Move(FFormatEtcArray[FCurrentIndex], elt, CopyCount * SizeOf(TFormatEtc));
Inc(FCurrentIndex, CopyCount);
Result := S_OK;
end;
if pceltFetched <> nil then
pceltFetched^ := CopyCount;
end;
//----------------------------------------------------------------------------------------------------------------------
function TEnumFormatEtc.Reset: HResult;
begin
FCurrentIndex := 0;
Result := S_OK;
end;
//----------------------------------------------------------------------------------------------------------------------
function TEnumFormatEtc.Skip(celt: LongWord): HResult;
begin
if FCurrentIndex + celt < High(FFormatEtcArray) then
begin
Inc(FCurrentIndex, celt);
Result := S_Ok;
end
else
Result := S_FALSE;
end;
//----------------- TVTDataObject --------------------------------------------------------------------------------------
constructor TVTDataObject.Create(AOwner: TBaseVirtualTree; ForClipboard: Boolean);
begin
inherited Create;
FOwner := AOwner;
FForClipboard := ForClipboard;
FOwner.GetNativeClipboardFormats(FFormatEtcArray);
end;
//----------------------------------------------------------------------------------------------------------------------
destructor TVTDataObject.Destroy;
var
I: Integer;
StgMedium: PStgMedium;
begin
// Cancel a pending clipboard operation if this data object was created for the clipboard and
// is freed because something else is placed there.
if FForClipboard and not (tsClipboardFlushing in FOwner.FStates) then
FOwner.CancelCutOrCopy;
// Release any internal clipboard formats
for I := 0 to High(FormatEtcArray) do
begin
StgMedium := FindInternalStgMedium(FormatEtcArray[I].cfFormat);
if Assigned(StgMedium) then
ReleaseStgMedium(StgMedium);
end;
FormatEtcArray := nil;
inherited;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.CanonicalIUnknown(TestUnknown: IUnknown): IUnknown;
// Uses COM object identity: An explicit call to the IUnknown::QueryInterface method, requesting the IUnknown
// interface, will always return the same pointer.
begin
if Assigned(TestUnknown) then
begin
if TestUnknown.QueryInterface(IUnknown, Result) = 0 then
Result._Release // Don't actually need it just need the pointer value
else
Result := TestUnknown
end
else
Result := TestUnknown
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.EqualFormatEtc(FormatEtc1, FormatEtc2: TFormatEtc): Boolean;
begin
Result := (FormatEtc1.cfFormat = FormatEtc2.cfFormat) and (FormatEtc1.ptd = FormatEtc2.ptd) and
(FormatEtc1.dwAspect = FormatEtc2.dwAspect) and (FormatEtc1.lindex = FormatEtc2.lindex) and
(FormatEtc1.tymed and FormatEtc2.tymed <> 0);
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.FindFormatEtc(TestFormatEtc: TFormatEtc; const FormatEtcArray: TFormatEtcArray): integer;
var
I: integer;
begin
Result := -1;
for I := 0 to High(FormatEtcArray) do
begin
if EqualFormatEtc(TestFormatEtc, FormatEtcArray[I]) then
begin
Result := I;
Break;
end
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.FindInternalStgMedium(Format: TClipFormat): PStgMedium;
var
I: integer;
begin
Result := nil;
for I := 0 to High(InternalStgMediumArray) do
begin
if Format = InternalStgMediumArray[I].Format then
begin
Result := @InternalStgMediumArray[I].Medium;
Break;
end
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.HGlobalClone(HGlobal: THandle): THandle;
// Returns a global memory block that is a copy of the passed memory block.
var
Size: Cardinal;
Data,
NewData: PByte;
begin
Size := GlobalSize(HGlobal);
Result := GlobalAlloc(GPTR, Size);
Data := GlobalLock(hGlobal);
try
NewData := GlobalLock(Result);
try
Move(Data^, NewData^, Size);
finally
GlobalUnLock(Result);
end
finally
GlobalUnLock(hGlobal);
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.RenderInternalOLEData(const FormatEtcIn: TFormatEtc; var Medium: TStgMedium;
var OLEResult: HResult): Boolean;
// Tries to render one of the formats which have been stored via the SetData method.
// Since this data is already there it is just copied or its reference count is increased (depending on storage medium).
var
InternalMedium: PStgMedium;
begin
Result := True;
InternalMedium := FindInternalStgMedium(FormatEtcIn.cfFormat);
if Assigned(InternalMedium) then
OLEResult := StgMediumIncRef(InternalMedium^, Medium, False, Self as IDataObject)
else
Result := False;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.StgMediumIncRef(const InStgMedium: TStgMedium; var OutStgMedium: TStgMedium;
CopyInMedium: Boolean; DataObject: IDataObject): HRESULT;
// InStgMedium is the data that is requested, OutStgMedium is the data that we are to return either a copy of or
// increase the IDataObject's reference and send ourselves back as the data (unkForRelease). The InStgMedium is usually
// the result of a call to find a particular FormatEtc that has been stored locally through a call to SetData.
// If CopyInMedium is not true we already have a local copy of the data when the SetData function was called (during
// that call the CopyInMedium must be true). Then as the caller asks for the data through GetData we do not have to make
// copy of the data for the caller only to have them destroy it then need us to copy it again if necessary.
// This way we increase the reference count to ourselves and pass the STGMEDIUM structure initially stored in SetData.
// This way when the caller frees the structure it sees the unkForRelease is not nil and calls Release on the object
// instead of destroying the actual data.
var
Len: Integer;
begin
Result := S_OK;
// Simply copy all fields to start with.
OutStgMedium := InStgMedium;
// The data handled here always results from a call of SetData we got. This ensures only one storage format
// is indicated and hence the case statement below is safe (IDataObject.GetData can optionally use several
// storage formats).
case InStgMedium.tymed of
TYMED_HGLOBAL:
begin
if CopyInMedium then
begin
// Generate a unique copy of the data passed
OutStgMedium.hGlobal := HGlobalClone(InStgMedium.hGlobal);
if OutStgMedium.hGlobal = 0 then
Result := E_OUTOFMEMORY
end
else
// Don't generate a copy just use ourselves and the copy previously saved.
OutStgMedium.PunkForRelease := Pointer(DataObject); // Does not increase RefCount.
end;
TYMED_FILE:
begin
//todo_lcl_check
Len := Length(WideString(InStgMedium.lpszFileName)) + 1; // Don't forget the terminating null character.
OutStgMedium.lpszFileName := CoTaskMemAlloc(2 * Len);
Move(InStgMedium.lpszFileName^, OutStgMedium.lpszFileName^, 2 * Len);
end;
TYMED_ISTREAM:
IUnknown(OutStgMedium.Pstm)._AddRef;
TYMED_ISTORAGE:
IUnknown(OutStgMedium.Pstg)._AddRef;
TYMED_GDI:
if not CopyInMedium then
// Don't generate a copy just use ourselves and the previously saved data.
OutStgMedium.PunkForRelease := Pointer(DataObject) // Does not increase RefCount.
else
Result := DV_E_TYMED; // Don't know how to copy GDI objects right now.
TYMED_MFPICT:
if not CopyInMedium then
// Don't generate a copy just use ourselves and the previously saved data.
OutStgMedium.PunkForRelease := Pointer(DataObject) // Does not increase RefCount.
else
Result := DV_E_TYMED; // Don't know how to copy MetaFile objects right now.
TYMED_ENHMF:
if not CopyInMedium then
// Don't generate a copy just use ourselves and the previously saved data.
OutStgMedium.PunkForRelease := Pointer(DataObject) // Does not increase RefCount.
else
Result := DV_E_TYMED; // Don't know how to copy enhanced metafiles objects right now.
else
Result := DV_E_TYMED;
end;
if (Result = S_OK) and Assigned(OutStgMedium.PunkForRelease) then
IUnknown(OutStgMedium.PunkForRelease)._AddRef;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.DAdvise(const FormatEtc: TFormatEtc; advf: DWord; const advSink: IAdviseSink;
out dwConnection: DWord): HResult;
// Advise sink management is greatly simplified by the IDataAdviseHolder interface.
// We use this interface and forward all concerning calls to it.
begin
Result := S_OK;
if FAdviseHolder = nil then
Result := CreateDataAdviseHolder(FAdviseHolder);
if Result = S_OK then
Result := FAdviseHolder.Advise(Self as IDataObject, FormatEtc, advf, advSink, dwConnection);
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.DUnadvise(dwConnection: DWord): HResult;
begin
if FAdviseHolder = nil then
Result := E_NOTIMPL
else
Result := FAdviseHolder.Unadvise(dwConnection);
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.EnumDAdvise(Out enumAdvise : IEnumStatData):HResult;
begin
if FAdviseHolder = nil then
Result := OLE_E_ADVISENOTSUPPORTED
else
Result := FAdviseHolder.EnumAdvise(enumAdvise);
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.EnumFormatEtc(Direction: DWord; out EnumFormatEtc: IEnumFormatEtc): HResult;
var
NewList: TEnumFormatEtc;
begin
Result := E_FAIL;
if Direction = DATADIR_GET then
begin
NewList := TEnumFormatEtc.Create(FOwner, FormatEtcArray);
EnumFormatEtc := NewList as IEnumFormatEtc;
Result := S_OK;
end
else
EnumFormatEtc := nil;
if EnumFormatEtc = nil then
Result := OLE_S_USEREG;
end;
//----------------------------------------------------------------------------------------------------------------------
Function TVTDataObject.GetCanonicalFormatEtc(const pformatetcIn : FORMATETC;Out pformatetcOut : FORMATETC):HResult;
begin
Result := DATA_S_SAMEFORMATETC;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium): HResult;
// Data is requested by clipboard or drop target. This method dispatchs the call
// depending on the data being requested.
var
I: Integer;
Data: PVTReference;
begin
// The tree reference format is always supported and returned from here.
if FormatEtcIn.cfFormat = CF_VTREFERENCE then
begin
// Note: this format is not used while flushing the clipboard to avoid a dangling reference
// when the owner tree is destroyed before the clipboard data is replaced with something else.
if tsClipboardFlushing in FOwner.FStates then
Result := E_FAIL
else
begin
Medium.hGlobal := GlobalAlloc(GHND or GMEM_SHARE, SizeOf(TVTReference));
Data := GlobalLock(Medium.hGlobal);
Data.Process := GetCurrentProcessID;
Data.Tree := FOwner;
GlobalUnlock(Medium.hGlobal);
Medium.tymed := TYMED_HGLOBAL;
Medium.PunkForRelease := nil;
Result := S_OK;
end;
end
else
begin
try
// See if we accept this type and if not get the correct return value.
Result := QueryGetData(FormatEtcIn);
if Result = S_OK then
begin
for I := 0 to High(FormatEtcArray) do
begin
if EqualFormatEtc(FormatEtcIn, FormatEtcArray[I]) then
begin
if not RenderInternalOLEData(FormatEtcIn, Medium, Result) then
Result := FOwner.RenderOLEData(FormatEtcIn, Medium, FForClipboard);
Break;
end;
end
end
except
FillChar(Medium, SizeOf(Medium), #0);
Result := E_FAIL;
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium): HResult;
begin
Result := E_NOTIMPL;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.QueryGetData(const FormatEtc: TFormatEtc): HResult;
var
I: Integer;
begin
Result := DV_E_CLIPFORMAT;
for I := 0 to High(FFormatEtcArray) do
begin
if FormatEtc.cfFormat = FFormatEtcArray[I].cfFormat then
begin
if (FormatEtc.tymed and FFormatEtcArray[I].tymed) <> 0 then
begin
if FormatEtc.dwAspect = FFormatEtcArray[I].dwAspect then
begin
if FormatEtc.lindex = FFormatEtcArray[I].lindex then
begin
Result := S_OK;
Break;
end
else
Result := DV_E_LINDEX;
end
else
Result := DV_E_DVASPECT;
end
else
Result := DV_E_TYMED;
end;
end
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.SetData(const FormatEtc: TFormatEtc; {$ifdef VER2_0}var{$else}const{$endif} Medium: TStgMedium; DoRelease: BOOL): HResult;
// Allows dynamic adding to the IDataObject during its existance. Most noteably it is used to implement
// IDropSourceHelper and allows to set a special format for optimized moves during a shell transfer.
var
Index: Integer;
LocalStgMedium: PStgMedium;
begin
// See if we already have a format of that type available.
Index := FindFormatEtc(FormatEtc, FormatEtcArray);
if Index > - 1 then
begin
// Just use the TFormatEct in the array after releasing the data.
LocalStgMedium := FindInternalStgMedium(FormatEtcArray[Index].cfFormat);
if Assigned(LocalStgMedium) then
begin
ReleaseStgMedium(LocalStgMedium);
FillChar(LocalStgMedium^, SizeOf(LocalStgMedium^), #0);
end;
end
else
begin
// It is a new format so create a new TFormatCollectionItem, copy the
// FormatEtc parameter into the new object and and put it in the list.
SetLength(FFormatEtcArray, Length(FormatEtcArray) + 1);
FormatEtcArray[High(FormatEtcArray)] := FormatEtc;
// Create a new InternalStgMedium and initialize it and associate it with the format.
SetLength(FInternalStgMediumArray, Length(InternalStgMediumArray) + 1);
InternalStgMediumArray[High(InternalStgMediumArray)].Format := FormatEtc.cfFormat;
LocalStgMedium := @InternalStgMediumArray[High(InternalStgMediumArray)].Medium;
FillChar(LocalStgMedium^, SizeOf(LocalStgMedium^), #0);
end;
if DoRelease then
begin
// We are simply being given the data and we take control of it.
LocalStgMedium^ := Medium;
Result := S_OK
end
else
begin
// We need to reference count or copy the data and keep our own references to it.
Result := StgMediumIncRef(Medium, LocalStgMedium^, True, Self as IDataObject);
// Can get a circular reference if the client calls GetData then calls SetData with the same StgMedium.
// Because the unkForRelease for the IDataObject can be marshalled it is necessary to get pointers that
// can be correctly compared. See the IDragSourceHelper article by Raymond Chen at MSDN.
if Assigned(LocalStgMedium.PunkForRelease) then
begin
if CanonicalIUnknown(Self) = CanonicalIUnknown(IUnknown(LocalStgMedium.PunkForRelease)) then
IUnknown(LocalStgMedium.PunkForRelease) := nil; // release the interface
end;
end;
// Tell all registered advice sinks about the data change.
if Assigned(FAdviseHolder) then
FAdviseHolder.SendOnDataChange(Self as IDataObject, 0, 0);
end;
//----------------- TVTDragManager -------------------------------------------------------------------------------------
constructor TVTDragManager.Create(AOwner: TBaseVirtualTree);
begin
inherited Create;
FOwner := AOwner;
// Create an instance of the drop target helper interface. This will fail but not harm on systems which do
// not support this interface (everything below Windows 2000);
CoCreateInstance(CLSID_DragDropHelper, nil, CLSCTX_INPROC_SERVER, IID_IDropTargetHelper, FDropTargetHelper);
end;
//----------------------------------------------------------------------------------------------------------------------
destructor TVTDragManager.Destroy;
begin
// Set the owner's reference to us to nil otherwise it will access an invalid pointer
// after our desctruction is complete.
Pointer(FOwner.FDragManager) := nil;
inherited;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.GetDataObject: IDataObject;
begin
// When the owner tree starts a drag operation then it gets a data object here to pass it to the OLE subsystem.
// In this case there is no local reference to a data object and one is created (but not stored).
// If there is a local reference then the owner tree is currently the drop target and the stored interface is
// that of the drag initiator.
if Assigned(FDataObject) then
Result := FDataObject
else
begin
Result := FOwner.DoCreateDataObject;
if Result = nil then
Result := TVTDataObject.Create(FOwner, False) as IDataObject;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.GetDragSource: TBaseVirtualTree;
begin
Result := FDragSource;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.GetDropTargetHelperSupported: Boolean;
begin
Result := Assigned(FDropTargetHelper);
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.GetIsDropTarget: Boolean;
begin
Result := FIsDropTarget;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.DragEnter(const DataObject: IDataObject; KeyState: LongWord; Pt: TPoint;
var Effect: LongWord): HResult;
begin
FDataObject := DataObject;
FIsDropTarget := True;
SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0, @FFullDragging, 0);
// If full dragging of window contents is disabled in the system then our tree windows will be locked
// and cannot be updated during a drag operation. With the following call painting is again enabled.
if not FFullDragging then
LockWindowUpdate(0);
if Assigned(FDropTargetHelper) and FFullDragging then
FDropTargetHelper.DragEnter(FOwner.Handle, DataObject, Pt, Effect);
FDragSource := FOwner.GetTreeFromDataObject(DataObject);
Result := FOwner.DragEnter(KeyState, Pt, Effect);
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.DragLeave: HResult;
begin
if Assigned(FDropTargetHelper) and FFullDragging then
FDropTargetHelper.DragLeave;
FOwner.DragLeave;
FIsDropTarget := False;
FDragSource := nil;
FDataObject := nil;
Result := NOERROR;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.DragOver(KeyState: LongWord; Pt: TPoint; var Effect: LongWord): HResult;
begin
if Assigned(FDropTargetHelper) and FFullDragging then
FDropTargetHelper.DragOver(Pt, Effect);
Result := FOwner.DragOver(FDragSource, KeyState, dsDragMove, Pt, Effect);
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.Drop(const DataObject: IDataObject; KeyState: LongWord; Pt: TPoint;
var Effect: LongWord): HResult;
begin
if Assigned(FDropTargetHelper) and FFullDragging then
FDropTargetHelper.Drop(DataObject, Pt, Effect);
Result := FOwner.DragDrop(DataObject, KeyState, Pt, Effect);
FIsDropTarget := False;
FDataObject := nil;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTDragManager.ForceDragLeave;
// Some drop targets, e.g. Internet Explorer leave a drag image on screen instead removing it when they receive
// a drop action. This method calls the drop target helper's DragLeave method to ensure it removes the drag image from
// screen. Unfortunately, sometimes not even this does help (e.g. when dragging text from VT to a text field in IE).
begin
if Assigned(FDropTargetHelper) and FFullDragging then
FDropTargetHelper.DragLeave;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.GiveFeedback(Effect: Integer): HResult;
begin
Result := DRAGDROP_S_USEDEFAULTCURSORS;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.QueryContinueDrag(EscapePressed: BOOL; KeyState: Integer): HResult;
var
RButton,
LButton: Boolean;
begin
LButton := (KeyState and MK_LBUTTON) <> 0;
RButton := (KeyState and MK_RBUTTON) <> 0;
// Drag'n drop canceled by pressing both mouse buttons or Esc?
if (LButton and RButton) or EscapePressed then
Result := DRAGDROP_S_CANCEL
else
// Drag'n drop finished?
if not (LButton or RButton) then
Result := DRAGDROP_S_DROP
else
Result := S_OK;
end;

161
components/virtualtreeview/lclconstants.inc Normal file
View file

@ -0,0 +1,161 @@
// Message constants that are not defined in LCL
WM_APP = $8000;
// ExtTextOut Options
ETO_RTLREADING = 128;
//DrawText options
DT_RTLREADING = 131072;
// Clipboard constants
CF_BITMAP = 2;
CF_DIB = 8;
CF_PALETTE = 9;
CF_ENHMETAFILE = 14;
CF_METAFILEPICT = 3;
CF_OEMTEXT = 7;
CF_TEXT = 1;
CF_UNICODETEXT = 13;
CF_DIF = 5;
CF_DSPBITMAP = 130;
CF_DSPENHMETAFILE = 142;
CF_DSPMETAFILEPICT = 131;
CF_DSPTEXT = 129;
CF_GDIOBJFIRST = 768;
CF_GDIOBJLAST = 1023;
CF_HDROP = 15;
CF_LOCALE = 16;
CF_OWNERDISPLAY = 128;
CF_PENDATA = 10;
CF_PRIVATEFIRST = 512;
CF_PRIVATELAST = 767;
CF_RIFF = 11;
CF_SYLK = 4;
CF_WAVE = 12;
CF_TIFF = 6;
CF_MAX = 17;
// Win32 colors
CLR_NONE = $ffffffff;
CLR_DEFAULT = $ff000000;
//DrawFrameControl constants
DFCS_HOT = $1000;
//Thread support
//This values is for win32, how about others??
INFINITE = $FFFFFFFF;
//OLE Support
E_OUTOFMEMORY = HRESULT($8007000E);
E_INVALIDARG = HRESULT($80070057);
E_NOINTERFACE = HRESULT($80004002);
E_POINTER = HRESULT($80004003);
E_HANDLE = HRESULT($80070006);
E_ABORT = HRESULT($80004004);
E_FAIL = HRESULT($80004005);
E_ACCESSDENIED = HRESULT($80070005);
DV_E_TYMED = HRESULT($80040069);
DV_E_CLIPFORMAT = HRESULT($8004006A);
DV_E_LINDEX = HRESULT($80040068);
DV_E_DVASPECT = HRESULT($8004006B);
OLE_E_ADVISENOTSUPPORTED = HRESULT($80040003);
OLE_S_USEREG = HRESULT($00040000);
DATA_S_SAMEFORMATETC = HRESULT($00040130);
DRAGDROP_S_DROP = HRESULT($00040100);
DRAGDROP_S_CANCEL = HRESULT($00040101);
DRAGDROP_S_USEDEFAULTCURSORS = HRESULT($00040102);
NOERROR = 0;
SPI_GETDRAGFULLWINDOWS = 38;
// windows management
SWP_HIDEWINDOW = 128;
SWP_SHOWWINDOW = 64;
//Imagelists
ILD_NORMAL = 0;
// Set WindowPos
SWP_FRAMECHANGED = 32;
SWP_NOOWNERZORDER = 512;
SWP_NOSENDCHANGING = 1024;
{ RedrawWindow }
RDW_ERASE = 4;
RDW_FRAME = 1024;
RDW_INTERNALPAINT = 2;
RDW_INVALIDATE = 1;
RDW_NOERASE = 32;
RDW_NOFRAME = 2048;
RDW_NOINTERNALPAINT = 16;
RDW_VALIDATE = 8;
RDW_ERASENOW = 512;
RDW_UPDATENOW = 256;
RDW_ALLCHILDREN = 128;
RDW_NOCHILDREN = 64;
//SetRedraw
WM_SETREDRAW = 11;
//Dummy
CM_PARENTFONTCHANGED = 1999;
//Wheel
WHEEL_DELTA = 120;
WHEEL_PAGESCROLL = High(DWord);
SPI_GETWHEELSCROLLLINES = 104;
//MultiByte
MB_USEGLYPHCHARS = 4;
LOCALE_IDEFAULTANSICODEPAGE = 4100;
//Image list
ILD_TRANSPARENT = $00000001;
ILD_MASK = $00000010;
ILD_IMAGE = $00000020;
ILD_ROP = $00000040;
ILD_BLEND25 = $00000002;
ILD_BLEND50 = $00000004;
ILD_OVERLAYMASK = $00000F00;
{ GetDCEx }
DCX_WINDOW = $1;
DCX_CACHE = $2;
DCX_PARENTCLIP = $20;
DCX_CLIPSIBLINGS = $10;
DCX_CLIPCHILDREN = $8;
DCX_NORESETATTRS = $4;
DCX_LOCKWINDOWUPDATE = $400;
DCX_EXCLUDERGN = $40;
DCX_INTERSECTRGN = $80;
DCX_VALIDATE = $200000;
SCantWriteResourceStreamError = 'CantWriteResourceStreamError';
//command
EN_UPDATE = 1024;
ES_AUTOHSCROLL = $80;
ES_AUTOVSCROLL = $40;
ES_CENTER = $1;
ES_LEFT = 0;
ES_LOWERCASE = $10;
ES_MULTILINE = $4;
ES_NOHIDESEL = $100;
EM_SETRECTNP = 180;
DT_END_ELLIPSIS = 32768;

88
components/virtualtreeview/lclfunctions.inc Normal file
View file

@ -0,0 +1,88 @@
//Used in DrawTextW
{
function GetTextAlign(DC: HDC): UINT;
begin
Logger.AddCheckPoint(lcDummyFunctions,'GetTextAlign');
Result:=TA_TOP or TA_LEFT;
end;
}
//Used in DrawTextW, ShortenString, TVirtualTreeColumn.ComputeHeaderLayout, TVirtualTreeColumns.DrawButtonText,
// TVTEdit.AutoAdjustSize, TCustomVirtualStringTree.PaintNormalText, TCustomVirtualStringTree.WMSetFont
// TCustomVirtualStringTree.DoTextMeasuring
{
function GetTextExtentPoint32W(DC: HDC; Str: PWideChar; Count: Integer; var Size: TSize): Boolean;
var
TempStr: String;
begin
Logger.AddCheckPoint(lcDummyFunctions,'GetTextExtentPoint32W');
TempStr:=WideCharToString(Str);
Result:=GetTextExtentPoint(DC, PChar(TempStr), Length(TempStr), Size);
end;
}
//Used in DrawTextW
{
function ExtTextOutW(DC: HDC; X, Y: Integer; Options: LongInt; Rect: PRect;
Str: PWideChar; Count: LongInt; Dx: PInteger): Boolean;
var
TempStr: String;
begin
Logger.AddCheckPoint(lcDummyFunctions,'ExtTextOutW');
TempStr:=WideCharToString(Str);
Result:= ExtTextOut(DC, X, Y, Options, Rect, PChar(TempStr), Length(TempStr), Dx);
end;
}
//Used in TVirtualTreeHintWindow.CalcHintRect, TVirtualTreeColumn.ComputeHeaderLayout
// TBaseVirtualTree.CollectSelectedNodesRTL, TBaseVirtualTree.DetermineHitPositionRTL
// TBaseVirtualTree.UpdateEditBounds, TBaseVirtualTree.GetDisplayRect, PaintTree,
// TStringEditLink.PrepareEdit, TCustomVirtualStringTree.ComputeNodeHeight etc
function MapWindowPoints(hWndFrom, hWndTo: HWND; var lpPoints; cPoints: UINT): Integer;
var
I:Integer;
XOffset, YOffset: SmallInt;
FromRect,ToRect: TRect;
begin
GetWindowRect(hWndFrom,FromRect);
GetWindowRect(hWndTo,ToRect);
XOffset:=(FromRect.Left - ToRect.Left);
YOffset:=(FromRect.Top - ToRect.Top);
for i:=0 to cPoints - 1 do
begin
{
Mode Delphi does not support treating a pointer as a array
if ObjFpc is used than this syntax is preferred
PPoint(@lpPoints)[i].x:= XOffset + PPoint(@lpPoints)[i].x;
PPoint(@lpPoints)[i].y:= YOffset + PPoint(@lpPoints)[i].y;
}
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 UseExternalDragManager}
function RegisterDragDrop(hwnd:HWND; pDropTarget:IDropTarget):WINOLEAPI;stdcall;external 'ole32.dll' name 'RegisterDragDrop';
function RevokeDragDrop(hwnd:HWND):WINOLEAPI;stdcall;external 'ole32.dll' name 'RevokeDragDrop';
function DoDragDrop(pDataObj:IDataObject; pDropSource:IDropSource; dwOKEffects:DWORD; pdwEffect:LPDWORD):WINOLEAPI;stdcall;external 'ole32.dll' name 'DoDragDrop';
function OleInitialize(pvReserved:LPVOID):WINOLEAPI;stdcall;external 'ole32.dll' name 'OleInitialize';
procedure OleUninitialize;stdcall;external 'ole32.dll' name 'OleUninitialize';
procedure ReleaseStgMedium(_para1:LPSTGMEDIUM);stdcall;external 'ole32.dll' name 'ReleaseStgMedium';
function OleSetClipboard(pDataObj:IDataObject):WINOLEAPI;stdcall;external 'ole32.dll' name 'OleSetClipboard';
function OleGetClipboard(out ppDataObj:IDataObject):WINOLEAPI;stdcall;external 'ole32.dll' name 'OleGetClipboard';
function OleFlushClipboard:WINOLEAPI;stdcall;external 'ole32.dll' name 'OleFlushClipboard';
function OleIsCurrentClipboard(pDataObj:IDataObject):WINOLEAPI;stdcall;external 'ole32.dll' name 'OleIsCurrentClipboard';
function CreateStreamOnHGlobal(hGlobal:HGLOBAL; fDeleteOnRelease:BOOL;out stm:IStream):WINOLEAPI;stdcall;external 'ole32.dll' name 'CreateStreamOnHGlobal';
{$endif}

5
components/virtualtreeview/readme.txt Normal file
View file

@ -0,0 +1,5 @@
Virtual Tree View from Lazarus CCR
https://lazarus-ccr.svn.sourceforge.net/svnroot/lazarus-ccr/components/virtualtreeview-new/branches/4.8
Rev. 2200
Some modifications done for Double Commander (see doublecmd.diff).

36
components/virtualtreeview/registervirtualtreeview.pas Normal file
View file

@ -0,0 +1,36 @@
unit registervirtualtreeview;
{$Mode ObjFpc}
{$H+}
interface
uses
Classes, SysUtils, LResources, LazarusPackageIntf,
VirtualTrees, VTHeaderPopup;
procedure Register;
implementation
procedure RegisterUnitVirtualTrees;
begin
RegisterComponents('Virtual Controls', [TVirtualDrawTree, TVirtualStringTree]);
end;
procedure RegisterUnitVTHeaderPopup;
begin
RegisterComponents('Virtual Controls', [TVTHeaderPopupMenu]);
end;
procedure Register;
begin
RegisterUnit('VirtualTrees', @RegisterUnitVirtualTrees);
RegisterUnit('VTHeaderPopup', @RegisterUnitVTHeaderPopup);
end;
initialization
{$i ideicons.lrs}
end.

3
components/virtualtreeview/units/carbon/fakeactivex.pas Normal file
View file

@ -0,0 +1,3 @@
unit FakeActiveX;
{$i ../dummyactivex.inc}

38
components/virtualtreeview/units/carbon/fakemmsystem.pas Normal file
View file

@ -0,0 +1,38 @@
unit fakemmsystem;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Types;
function timeBeginPeriod(x1: DWord): DWord;
function timeEndPeriod(x1: DWord): DWord;
function timeGetTime: DWORD;
implementation
function timeBeginPeriod(x1: DWord): DWord;
begin
end;
function timeEndPeriod(x1: DWord): DWord;
begin
end;
function timeGetTime: DWORD;
var
ATime: TSystemTime;
begin
//todo: properly implement
GetLocalTime(ATime);
Result := ATime.MilliSecond;
end;
end.

1623
components/virtualtreeview/units/carbon/virtualdragmanager.pas Normal file
View file

File diff suppressed because it is too large Load diff

58
components/virtualtreeview/units/carbon/virtualpanningwindow.pas Normal file
View file

@ -0,0 +1,58 @@
unit virtualpanningwindow;
{$mode objfpc}{$H+}
interface
uses
LCLType, Graphics, Classes, SysUtils;
type
{ TVirtualPanningWindow }
TVirtualPanningWindow = class
private
FHandle: THandle;
FOwnerHandle: THandle;
FImage: TBitmap;
procedure HandlePaintMessage;
public
procedure Start(OwnerHandle: THandle; const Position: TPoint);
procedure Stop;
procedure Show(ClipRegion: HRGN);
property Image: TBitmap read FImage;
property Handle: THandle read FHandle;
end;
implementation
{$ifdef DEBUG_VTV}
uses
vtlogger;
{$endif}
{ TVirtualPanningWindow }
procedure TVirtualPanningWindow.HandlePaintMessage;
begin
end;
procedure TVirtualPanningWindow.Start(OwnerHandle: THandle; const Position: TPoint);
begin
FImage := TBitmap.Create;
end;
procedure TVirtualPanningWindow.Stop;
begin
FImage.Free;
FImage := nil;
end;
procedure TVirtualPanningWindow.Show(ClipRegion: HRGN);
begin
{$ifdef DEBUG_VTV}Logger.SendBitmap([lcPanning],'Panning Image',FImage);{$endif}
end;
end.

420
components/virtualtreeview/units/dummyactivex.inc Normal file
View file

@ -0,0 +1,420 @@
{fake unit just to compile - not used under non windows}
{$mode delphi}
interface
uses
{$ifdef Windows} Windows, {$endif} Classes, SysUtils, Types;
const
TYMED_HGLOBAL = 1;
TYMED_ISTREAM = 4;
DVASPECT_CONTENT = 1;
CLSCTX_INPROC_SERVER = $0010;
DROPEFFECT_COPY = 1;
DROPEFFECT_LINK = 4;
DROPEFFECT_MOVE = 2;
DROPEFFECT_NONE = 0;
DROPEFFECT_SCROLL = dword($80000000);
DATADIR_GET = 1;
type
//types from win unit
Long = LongInt;
WinBool = LongBool;
Bool = WinBool;
ULONG = cardinal;
PULONG = ^ULONG;
LONGLONG = int64;
LPDWORD = ^DWORD;
LPVOID = pointer;
TCOLORREF = cardinal;
TIID = TGUID;
LARGE_INTEGER = record
case byte of
0: (LowPart : DWORD;
HighPart : LONG);
1: (QuadPart : LONGLONG);
end;
PLARGE_INTEGER = ^LARGE_INTEGER;
_LARGE_INTEGER = LARGE_INTEGER;
TLargeInteger = Int64;
PLargeInteger = ^TLargeInteger;
ULARGE_INTEGER = record
case byte of
0: (LowPart : DWORD;
HighPart : DWORD);
1: (QuadPart : LONGLONG);
end;
PULARGE_INTEGER = ^ULARGE_INTEGER;
_ULARGE_INTEGER = ULARGE_INTEGER;
HANDLE = System.THandle;
HWND = HANDLE;
//HRESULT = System.HResult;
HBITMAP = HANDLE;
HENHMETAFILE = HANDLE;
//activex types
IMoniker = Interface;
WINOLEAPI = HResult;
TLCID = DWORD;
OleChar = WChar;
LPOLESTR = ^OLECHAR;
HMetaFilePict = Pointer;
tagBIND_OPTS = Record
cvStruct, // sizeof(BIND_OPTS)
grfFlags,
grfMode,
dwTickCountDeadline : DWord;
End;
TBind_Opts = tagBIND_OPTS;
TCLIPFORMAT = Word;
tagDVTARGETDEVICE = Record
tdSize : DWord;
tdDriverNameOffset,
tdDeviceNameOffset,
tdPortNameOffset,
tdExtDevmodeOffset : Word;
Data : Record End;
End;
DVTARGETDEVICE = TagDVTARGETDEVICE;
PDVTARGETDEVICE = ^tagDVTARGETDEVICE;
tagFORMATETC = Record
CfFormat : Word {TCLIPFORMAT};
Ptd : PDVTARGETDEVICE;
dwAspect : DWORD;
lindex : Long;
tymed : DWORD;
End;
FORMATETC = TagFORMATETC;
TFORMATETC = FORMATETC;
LPFORMATETC = ^FORMATETC;
PFormatEtc = LPFORMATETC;
tagSTATDATA = Record
// field used by:
FORMATETC : Tformatetc; // EnumAdvise, EnumData (cache), EnumFormats
advf : DWord; // EnumAdvise, EnumData (cache)
padvSink : Pointer {IAdviseSink}; // EnumAdvise
dwConnection: DWord; // EnumAdvise
End;
STATDATA = TagStatData;
TagSTGMEDIUM = Record
Tymed : DWord;
Case Integer Of
0 : (HBITMAP : hBitmap; PUnkForRelease : Pointer {IUnknown});
1 : (HMETAFILEPICT : hMetaFilePict );
2 : (HENHMETAFILE : hEnhMetaFile );
3 : (HGLOBAL : hGlobal );
4 : (lpszFileName : LPOLESTR );
5 : (pstm : Pointer{IStream} );
6 : (pstg : Pointer{IStorage} );
End;
USTGMEDIUM = TagSTGMEDIUM;
STGMEDIUM = USTGMEDIUM;
TStgMedium = TagSTGMEDIUM;
PStgMedium = ^TStgMedium;
LPSTGMEDIUM = ^STGMEDIUM;
IEnumString = Interface (IUnknown)
['{00000101-0000-0000-C000-000000000046}']
Function Next(Celt:ULong;Out xcelt;Out Celtfetched:ULong):HResult; StdCall;
// Function RemoteNext(Celt:ULong; Out celt;Out Celtfetched:ULong):HResult; StdCall;
Function Skip (Celt:ULong):Hresult;StdCall;
Function Reset:HResult;StdCall;
Function Clone(Out penum:IEnumString):HResult;StdCall;
End;
IEnumMoniker = Interface (IUnknown)
['{00000102-0000-0000-C000-000000000046}']
Function Next(celt:ULong; out Elt;out celftfetched: ULong):HResult; StdCall;
// Function RemoteNext(Celt:ULong; Out rgelt;out celtfetched :ULong):Hresult; StdCall;
Function Skip(celt:Ulong):HResult; StdCall;
Function Reset:HResult; StdCall;
Function Close(out penum:IEnumMoniker):HResult;StdCall;
End;
IEnumSTATDATA = Interface (IUnknown)
['{00000105-0000-0000-C000-000000000046}']
Function Next (Celt:ULong;Out xcelt;pceltfetched : PUlong):HResult; StdCall;
// Function RemoteNext(Celt:ULong;Out Rgelt:statdata;Out pceltFetched:ULong):HResult; StdCall;
Function Skip(Celt:ULong):HResult;StdCall;
Function Reset:HResult;StdCall;
Function Clone(out penum:IEnumstatdata):HResult;StdCall;
End;
IEnumFORMATETC = Interface (IUnknown)
['{00000103-0000-0000-C000-000000000046}']
Function Next(Celt:ULong;Out Rgelt:FormatEtc;pceltFetched:pULong=nil):HResult; StdCall;
// Function RemoteNext(Celt:ULong;Out Rgelt:FormatEtc;Out pceltFetched:ULong):HResult; StdCall;
Function Skip(Celt:ULong):HResult;StdCall;
Function Reset:HResult;StdCall;
Function Clone(out penum:IEnumFORMATETC):HResult;StdCall;
End;
IPersist = Interface (IUnknown)
['{0000010c-0000-0000-C000-000000000046}']
Function GetClassId(clsid:TClsId):HResult; StdCall;
End;
IPersistStream = Interface(IPersist)
['{00000109-0000-0000-C000-000000000046}']
Function IsDirty:HResult; StdCall;
Function Load(Const stm: IStream):HResult; StdCall;
Function Save(Const stm: IStream;fClearDirty:Bool):HResult;StdCall;
Function GetSizeMax(Out cbSize:ULarge_Integer):HResult; StdCall;
End;
IRunningObjectTable = Interface (IUnknown)
['{00000010-0000-0000-C000-000000000046}']
Function Register (grfFlags :DWord;const unkobject:IUnknown;Const mkObjectName:IMoniker;Out dwregister:DWord):HResult;StdCall;
Function Revoke (dwRegister:DWord):HResult; StdCall;
Function IsRunning (Const mkObjectName: IMoniker):HResult;StdCall;
Function GetObject (Const mkObjectName: IMoniker; Out punkObject:IUnknown):HResult; StdCall;
Function NoteChangeTime(dwRegister :DWord;Const FileTime: TFileTime):HResult;StdCall;
Function GetTimeOfLastChange(Const mkObjectName:IMoniker;Out filetime:TFileTime):HResult; StdCall;
Function EnumRunning (Out enumMoniker: IEnumMoniker):HResult; StdCall;
End;
IBindCtx = Interface (IUnknown)
['{0000000e-0000-0000-C000-000000000046}']
Function RegisterObjectBound(Const punk:IUnknown):HResult; stdCall;
Function RevokeObjectBound (Const Punk:IUnknown):HResult; stdCall;
Function ReleaseBoundObjects :HResult; StdCall;
Function SetBindOptions(Const bindOpts:TBind_Opts):HResult; stdCall;
// Function RemoteSetBindOptions(Const bind_opts: TBind_Opts2):HResult;StdCall;
Function GetBindOptions(var BindOpts:TBind_Opts):HResult; stdCall;
// Function RemoteGetBindOptions(Var bind_opts: TBind_Opts2):HResult;StdCall;
Function GetRunningObjectTable(Out rot : IRunningObjectTable):Hresult; StdCall;
Function RegisterObjectParam(Const pszkey:LPOleStr;const punk:IUnknown):HResult;
Function GetObjectParam(Const pszkey:LPOleStr; out punk: IUnknown):HResult; StdCall;
Function EnumObjectParam (out enum:IEnumString):Hresult;StdCall;
Function RevokeObjectParam(pszKey:LPOleStr):HResult;StdCall;
End;
PIMoniker = ^IMoniker;
IMoniker = Interface (IPersistStream)
['{0000000f-0000-0000-C000-000000000046}']
Function BindToObject (const pbc:IBindCtx;const mktoleft:IMoniker; RiidResult:TIID;Out vresult):HResult;StdCall;
// Function RemoteBindToObject (const pbc:IBindCtx;const mktoleft:IMoniker;RiidResult:TIID;Out vresult):HResult;StdCall;
Function BindToStorage(Const Pbc:IBindCtx;Const mktoLeft:IMoniker; Riid:TIID;Out vobj):HResult; StdCall;
// Function RemoteBindToStorage(Const Pbc:IBindCtx;Const mktoLeft:IMoniker; Riid:TIID;Out vobj):HResult; StdCall;
Function Reduce (const pbc:IBindCtx; dwReduceHowFar:DWord; mktoLeft: PIMoniker; Out mkReduced:IMoniker):HResult; StdCall;
Function ComposeWith(Const MkRight:IMoniker;fOnlyIfNotGeneric:BOOL; OUT mkComposite:IMoniker):HResult; StdCall;
Function Enum(fForward:Bool;Out enumMoniker:IEnumMoniker):HResult;StdCall;
Function IsEqual(Const mkOtherMoniker:IMoniker):HResult;StdCall;
Function Hash (Out dwHash:Dword):HResult;StdCall;
Function IsRunning(Const bc:IBindCtx;Const MkToLeft:IMoniker;Const mknewlyRunning:IMoniker):HResult;StdCall;
Function GetTimeOfLastChange(Const bc:IBindCtx;Const mkToLeft:IMoniker; out ft : FileTime):HResult; StdCall;
Function Inverse(out mk : IMoniker):HResult; StdCall;
Function CommonPrefixWith (Const mkOther:IMoniker):HResult; StdCall;
Function RelativePathTo(Const mkother:IMoniker; Out mkRelPath : IMoniker):HResult;StdCall;
Function GetDisplayName(Const bc:IMoniker;const mktoleft:IMoniker;Out szDisplayName: pOleStr):HResult; StdCall;
Function ParseDisplayName(Const bc:IBindCtx;Const mkToLeft:IMoniker;szDisplayName:POleStr;out cheaten:ULong;out mkOut:IMoniker):HResult; StdCall;
Function IsSystemMonitor(Out dwMkSys:DWord):HResult;StdCall;
End;
IAdviseSink = Interface (IUnknown)
['{0000010f-0000-0000-C000-000000000046}']
{$ifdef midl500} ['{00000150-0000-0000-C000-000000000046}'] {$endif}
Procedure OnDataChange (Const pformatetc : Formatetc;const pstgmed : STGMEDIUM); StdCall;
Procedure OnViewChange (dwAspect : DWord; lindex : Long); StdCall;
Procedure OnRename (Const pmk : IMoniker); StdCall;
Procedure OnSave; StdCall;
Procedure OnClose; StdCall;
End;
//Fake interfaces
IDataObject = Interface (IUnknown)
['{0000010e-0000-0000-C000-000000000046}']
Function GetData(Const formatetcIn : FORMATETC;Out medium : STGMEDIUM):HRESULT; STDCALL;
Function GetDataHere(CONST pformatetc : FormatETC; Out medium : STGMEDIUM):HRESULT; STDCALL;
Function QueryGetData(const pformatetc : FORMATETC):HRESULT; STDCALL;
Function GetCanonicalFormatEtc(const pformatetcIn : FORMATETC;Out pformatetcOut : FORMATETC):HResult; STDCALl;
Function SetData (Const pformatetc : FORMATETC;const medium:STGMEDIUM;FRelease : BOOL):HRESULT; StdCall;
Function EnumFormatEtc(dwDirection : DWord; OUT enumformatetcpara : IENUMFORMATETC):HRESULT; StdCall;
Function DAdvise(const formatetc : FORMATETC;advf :DWORD; CONST AdvSink : IAdviseSink;OUT dwConnection:DWORD):HRESULT;StdCall;
Function DUnadvise(dwconnection :DWord) :HRESULT;StdCall;
Function EnumDAdvise(Out enumAdvise : IEnumStatData):HResult;StdCall;
End;
IDropTarget = interface(IUnknown)
['{00000122-0000-0000-C000-000000000046}']
function DragEnter(const dataObj: IDataObject; grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD): HResult;StdCall;
function DragOver(grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD): HResult;StdCall;
function DragLeave: HResult;StdCall;
function Drop(const dataObj: IDataObject; grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD):HResult;StdCall;
end;
IDropSource = interface(IUnknown)
['{00000121-0000-0000-C000-000000000046}']
function QueryContinueDrag(fEscapePressed: BOOL;
grfKeyState: Longint):HResult;StdCall;
function GiveFeedback(dwEffect: Longint): HResult;StdCall;
end;
IDataAdviseHolder = Interface (IUnknown)
['{00000110-0000-0000-C000-000000000046}']
Function Advise (CONST pdataObject : IDataObject;CONST fetc:FORMATETC;advf : DWORD;Const pAdvise:IAdviseSink;Out DwConnection:DWord):HResult; StdCall;
Function Unadvise (dwConnection:Dword):HResult; StdCall;
Function EnumAdvise(out penumAdvise : IEnumStatData):HResult;StdCall;
Function SendOnDataChange(const pDataObject :IDataObject;DwReserved,advf : DWord):HResult; StdCall;
End;
//Ole helper functions
function Succeeded(Status : HRESULT) : BOOLEAN;
function Failed(Status : HRESULT) : BOOLEAN;
//ActiveX functions that have wrong calling convention in fpc
function RegisterDragDrop(hwnd:HWND; pDropTarget:IDropTarget):WINOLEAPI;stdcall;
function RevokeDragDrop(hwnd:HWND):WINOLEAPI;stdcall;
function DoDragDrop(pDataObj:IDataObject; pDropSource:IDropSource; dwOKEffects:DWORD; pdwEffect:LPDWORD):WINOLEAPI;
function OleInitialize(pvReserved:LPVOID):WINOLEAPI;stdcall;
procedure OleUninitialize;stdcall;
procedure ReleaseStgMedium(_para1:LPSTGMEDIUM);stdcall;
function OleSetClipboard(pDataObj:IDataObject):WINOLEAPI;stdcall;
function OleGetClipboard(out ppDataObj:IDataObject):WINOLEAPI;stdcall;
function OleFlushClipboard:WINOLEAPI;stdcall;
function OleIsCurrentClipboard(pDataObj:IDataObject):WINOLEAPI;stdcall;
function CreateStreamOnHGlobal(hGlobal:HGLOBAL; fDeleteOnRelease:BOOL;out stm:IStream):WINOLEAPI;stdcall;
function CoCreateInstance(const _para1:TCLSID; _para2:IUnknown; _para3:DWORD;const _para4:TIID;out _para5):HRESULT;stdcall;
implementation
function Succeeded(Status : HRESULT) : BOOLEAN;
begin
Succeeded:=Status and HRESULT($80000000)=0;
end;
function Failed(Status : HRESULT) : BOOLEAN;
begin
Failed:=Status and HRESULT($80000000)<>0;
end;
function RegisterDragDrop(hwnd: HWND; pDropTarget: IDropTarget): WINOLEAPI;
begin
//Logger.SendError([lcOle],'Ole function called in Linux');
//Logger.SendCallStack([lcOle],'Stack');
end;
function RevokeDragDrop(hwnd: HWND): WINOLEAPI;
begin
//Logger.SendError([lcOle],'Ole function called in Linux');
//Logger.SendCallStack([lcOle],'Stack');
end;
function DoDragDrop(pDataObj: IDataObject; pDropSource: IDropSource;
dwOKEffects: DWORD; pdwEffect: LPDWORD): WINOLEAPI;
begin
//Logger.SendError([lcOle],'Ole function called in Linux');
//Logger.SendCallStack([lcOle],'Stack');
end;
function OleInitialize(pvReserved: LPVOID): WINOLEAPI;
begin
//Logger.SendError([lcOle],'Ole function called in Linux');
//Logger.SendCallStack([lcOle],'Stack');
end;
procedure OleUninitialize;
begin
//Logger.SendError([lcOle],'Ole function called in Linux');
//Logger.SendCallStack([lcOle],'Stack');
end;
procedure ReleaseStgMedium(_para1: LPSTGMEDIUM);
begin
//Logger.SendError([lcOle],'Ole function called in Linux');
//Logger.SendCallStack([lcOle],'Stack');
end;
function OleSetClipboard(pDataObj: IDataObject): WINOLEAPI;
begin
//Logger.SendError([lcOle],'Ole function called in Linux');
//Logger.SendCallStack([lcOle],'Stack');
end;
function OleGetClipboard(out ppDataObj: IDataObject): WINOLEAPI;
begin
//Logger.SendError([lcOle],'Ole function called in Linux');
//Logger.SendCallStack([lcOle],'Stack');
end;
function OleFlushClipboard: WINOLEAPI;
begin
// Logger.SendError([lcOle],'Ole function called in Linux');
//Logger.SendCallStack([lcOle],'Stack');
end;
function OleIsCurrentClipboard(pDataObj: IDataObject): WINOLEAPI;
begin
//Logger.SendError([lcOle],'Ole function called in Linux');
//Logger.SendCallStack([lcOle],'Stack');
end;
function CreateStreamOnHGlobal(hGlobal: HGLOBAL; fDeleteOnRelease: BOOL; out
stm: IStream): WINOLEAPI;
begin
//Logger.SendError([lcOle],'Ole function called in Linux');
//Logger.SendCallStack([lcOle],'Stack');
end;
function CoCreateInstance(const _para1: TCLSID; _para2: IUnknown;
_para3: DWORD; const _para4: TIID; out _para5): HRESULT;
begin
//Logger.SendError([lcOle],'Ole function called in Linux');
//Logger.SendCallStack([lcOle],'Stack');
end;
end.

3
components/virtualtreeview/units/gtk/fakeactivex.pas Normal file
View file

@ -0,0 +1,3 @@
unit FakeActiveX;
{$i ../dummyactivex.inc}

38
components/virtualtreeview/units/gtk/fakemmsystem.pas Normal file
View file

@ -0,0 +1,38 @@
unit fakemmsystem;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Types;
function timeBeginPeriod(x1: DWord): DWord;
function timeEndPeriod(x1: DWord): DWord;
function timeGetTime: DWORD;
implementation
function timeBeginPeriod(x1: DWord): DWord;
begin
end;
function timeEndPeriod(x1: DWord): DWord;
begin
end;
function timeGetTime: DWORD;
var
ATime: TSystemTime;
begin
//todo: properly implement
GetLocalTime(ATime);
Result := ATime.MilliSecond;
end;
end.

1623
components/virtualtreeview/units/gtk/virtualdragmanager.pas Normal file
View file

File diff suppressed because it is too large Load diff

58
components/virtualtreeview/units/gtk/virtualpanningwindow.pas Normal file
View file

@ -0,0 +1,58 @@
unit virtualpanningwindow;
{$mode objfpc}{$H+}
interface
uses
LCLType, Graphics, Classes, SysUtils;
type
{ TVirtualPanningWindow }
TVirtualPanningWindow = class
private
FHandle: THandle;
FOwnerHandle: THandle;
FImage: TBitmap;
procedure HandlePaintMessage;
public
procedure Start(OwnerHandle: THandle; const Position: TPoint);
procedure Stop;
procedure Show(ClipRegion: HRGN);
property Image: TBitmap read FImage;
property Handle: THandle read FHandle;
end;
implementation
{$ifdef DEBUG_VTV}
uses
vtlogger;
{$endif}
{ TVirtualPanningWindow }
procedure TVirtualPanningWindow.HandlePaintMessage;
begin
end;
procedure TVirtualPanningWindow.Start(OwnerHandle: THandle; const Position: TPoint);
begin
FImage := TBitmap.Create;
end;
procedure TVirtualPanningWindow.Stop;
begin
FImage.Free;
FImage := nil;
end;
procedure TVirtualPanningWindow.Show(ClipRegion: HRGN);
begin
{$ifdef DEBUG_VTV}Logger.SendBitmap([lcPanning],'Panning Image',FImage);{$endif}
end;
end.

3
components/virtualtreeview/units/gtk2/fakeactivex.pas Normal file
View file

@ -0,0 +1,3 @@
unit FakeActiveX;
{$i ../dummyactivex.inc}

34
components/virtualtreeview/units/gtk2/fakemmsystem.pas Normal file
View file

@ -0,0 +1,34 @@
unit fakemmsystem;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Types, LCLIntf;
function timeBeginPeriod(x1: DWord): DWord;
function timeEndPeriod(x1: DWord): DWord;
function timeGetTime: DWORD;
implementation
function timeBeginPeriod(x1: DWord): DWord;
begin
//
end;
function timeEndPeriod(x1: DWord): DWord;
begin
//
end;
function timeGetTime: DWORD;
begin
Result := GetTickCount;
end;
end.

1623
components/virtualtreeview/units/gtk2/virtualdragmanager.pas Normal file
View file

File diff suppressed because it is too large Load diff

58
components/virtualtreeview/units/gtk2/virtualpanningwindow.pas Normal file
View file

@ -0,0 +1,58 @@
unit virtualpanningwindow;
{$mode objfpc}{$H+}
interface
uses
LCLType, Graphics, Classes, SysUtils;
type
{ TVirtualPanningWindow }
TVirtualPanningWindow = class
private
FHandle: THandle;
FOwnerHandle: THandle;
FImage: TBitmap;
procedure HandlePaintMessage;
public
procedure Start(OwnerHandle: THandle; const Position: TPoint);
procedure Stop;
procedure Show(ClipRegion: HRGN);
property Image: TBitmap read FImage;
property Handle: THandle read FHandle;
end;
implementation
{$ifdef DEBUG_VTV}
uses
vtlogger;
{$endif}
{ TVirtualPanningWindow }
procedure TVirtualPanningWindow.HandlePaintMessage;
begin
end;
procedure TVirtualPanningWindow.Start(OwnerHandle: THandle; const Position: TPoint);
begin
FImage := TBitmap.Create;
end;
procedure TVirtualPanningWindow.Stop;
begin
FImage.Free;
FImage := nil;
end;
procedure TVirtualPanningWindow.Show(ClipRegion: HRGN);
begin
{$ifdef DEBUG_VTV}Logger.SendBitmap([lcPanning],'Panning Image',FImage);{$endif}
end;
end.

3
components/virtualtreeview/units/qt/fakeactivex.pas Normal file
View file

@ -0,0 +1,3 @@
unit FakeActiveX;
{$i ../dummyactivex.inc}

38
components/virtualtreeview/units/qt/fakemmsystem.pas Normal file
View file

@ -0,0 +1,38 @@
unit fakemmsystem;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Types;
function timeBeginPeriod(x1: DWord): DWord;
function timeEndPeriod(x1: DWord): DWord;
function timeGetTime: DWORD;
implementation
function timeBeginPeriod(x1: DWord): DWord;
begin
end;
function timeEndPeriod(x1: DWord): DWord;
begin
end;
function timeGetTime: DWORD;
var
ATime: TSystemTime;
begin
//todo: properly implement
GetLocalTime(ATime);
Result := ATime.MilliSecond;
end;
end.

1623
components/virtualtreeview/units/qt/virtualdragmanager.pas Normal file
View file

File diff suppressed because it is too large Load diff

58
components/virtualtreeview/units/qt/virtualpanningwindow.pas Normal file
View file

@ -0,0 +1,58 @@
unit virtualpanningwindow;
{$mode objfpc}{$H+}
interface
uses
LCLType, Graphics, Classes, SysUtils;
type
{ TVirtualPanningWindow }
TVirtualPanningWindow = class
private
FHandle: THandle;
FOwnerHandle: THandle;
FImage: TBitmap;
procedure HandlePaintMessage;
public
procedure Start(OwnerHandle: THandle; const Position: TPoint);
procedure Stop;
procedure Show(ClipRegion: HRGN);
property Image: TBitmap read FImage;
property Handle: THandle read FHandle;
end;
implementation
{$ifdef DEBUG_VTV}
uses
vtlogger;
{$endif}
{ TVirtualPanningWindow }
procedure TVirtualPanningWindow.HandlePaintMessage;
begin
end;
procedure TVirtualPanningWindow.Start(OwnerHandle: THandle; const Position: TPoint);
begin
FImage := TBitmap.Create;
end;
procedure TVirtualPanningWindow.Stop;
begin
FImage.Free;
FImage := nil;
end;
procedure TVirtualPanningWindow.Show(ClipRegion: HRGN);
begin
{$ifdef DEBUG_VTV}Logger.SendBitmap([lcPanning],'Panning Image',FImage);{$endif}
end;
end.

1134
components/virtualtreeview/units/win32/virtualdragmanager.pas Normal file
View file

File diff suppressed because it is too large Load diff

113
components/virtualtreeview/units/win32/virtualpanningwindow.pas Normal file
View file

@ -0,0 +1,113 @@
unit virtualpanningwindow;
{Adapted from VirtualTrees by Luiz Américo to work in LCL/Lazarus}
{$mode objfpc}{$H+}
interface
uses
Windows, Graphics, Classes, SysUtils;
type
{ TVirtualPanningWindow }
TVirtualPanningWindow = class
private
FHandle: THandle;
FImage: TBitmap;
procedure HandlePaintMessage;
public
procedure Start(OwnerHandle: THandle; const Position: TPoint);
procedure Stop;
procedure Show(ClipRegion: HRGN);
property Image: TBitmap read FImage;
property Handle: THandle read FHandle;
end;
implementation
{$ifdef DEBUG_VTV}
uses
vtlogger;
{$endif}
function PanningWindowProc(Window: HWnd; Msg: UInt;WPara: WParam; LPara: LParam): LResult; stdcall;
var
PanningObject: TVirtualPanningWindow;
begin
if Msg = WM_PAINT then
begin
PanningObject:=TVirtualPanningWindow(GetWindowLong(Window,GWL_USERDATA));
if Assigned(PanningObject) then
PanningObject.HandlePaintMessage;
end
else
DefWindowProc(Window,Msg,WPara,LPara);
end;
var
PanningWindowClass: TWndClass = (
style: 0;
lpfnWndProc: @PanningWindowProc;
cbClsExtra: 0;
cbWndExtra: 0;
hInstance: 0;
hIcon: 0;
hCursor: 0;
hbrBackground: 0;
lpszMenuName: nil;
lpszClassName: 'VTPanningWindow'
);
{ TVirtualPanningWindow }
procedure TVirtualPanningWindow.HandlePaintMessage;
var
PS: PaintStruct;
begin
BeginPaint(FHandle, PS);
BitBlt(PS.hdc,0,0,FImage.Width,FImage.Height,FImage.Canvas.Handle,0,0,SRCCOPY);
EndPaint(FHandle, PS);
end;
procedure TVirtualPanningWindow.Start(OwnerHandle: THandle; const Position: TPoint);
var
TempClass: TWndClass;
begin
// Register the helper window class.
if not GetClassInfo(HInstance, PanningWindowClass.lpszClassName, TempClass) then
begin
PanningWindowClass.hInstance := HInstance;
Windows.RegisterClass(PanningWindowClass);
end;
// Create the helper window and show it at the given position without activating it.
with Position do
FHandle := CreateWindowEx(WS_EX_TOOLWINDOW, PanningWindowClass.lpszClassName, nil, WS_POPUP, X - 16, Y - 16,
32, 32, OwnerHandle, 0, HInstance, nil);
//todo use SetWindowLongPtr later
SetWindowLong(FHandle,GWL_USERDATA,PtrInt(Self));
FImage := TBitmap.Create;
end;
procedure TVirtualPanningWindow.Stop;
begin
// Destroy the helper window.
DestroyWindow(FHandle);
FImage.Free;
FImage := nil;
end;
procedure TVirtualPanningWindow.Show(ClipRegion: HRGN);
begin
{$ifdef DEBUG_VTV}Logger.SendBitmap([lcPanning],'Panning Image',FImage);{$endif}
//todo: move SetWindowRgn to DelphiCompat
SetWindowRgn(FHandle, ClipRegion, False);
ShowWindow(FHandle, SW_SHOWNOACTIVATE);
end;
end.

2108
components/virtualtreeview/virtualtrees.lrs Normal file
View file

File diff suppressed because it is too large Load diff

87
components/virtualtreeview/virtualtreeview_package.lpk Normal file
View file

@ -0,0 +1,87 @@
<?xml version="1.0"?>
<CONFIG>
<Package Version="4">
<Name Value="virtualtreeview_package"/>
<AddToProjectUsesSection Value="True"/>
<Author Value="Mike Lischke (LCL Port: Luiz Américo)"/>
<CompilerOptions>
<Version Value="11"/>
<SearchPaths>
<IncludeFiles Value="include/intf/$(LCLWidgetType);units;include/intf"/>
<OtherUnitFiles Value="units/$(LCLWidgetType)"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)-$(LCLWidgetType)"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<UseAnsiStrings Value="False"/>
</SyntaxOptions>
</Parsing>
<CodeGeneration>
<Checks>
<RangeChecks Value="True"/>
<OverflowChecks Value="True"/>
</Checks>
</CodeGeneration>
<Linking>
<Debugging>
<DebugInfoType Value="dsDwarf2Set"/>
</Debugging>
</Linking>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Description Value="Virtual Treeview is an advanced component originally created for Delphi
"/>
<License Value=" Mozilla Public License 1.1 (MPL 1.1) or GNU Lesser General Public License
"/>
<Version Major="4" Minor="8" Release="7" Build="1"/>
<Files Count="7">
<Item1>
<Filename Value="virtualtrees.lrs"/>
<Type Value="LRS"/>
</Item1>
<Item2>
<Filename Value="VirtualTrees.pas"/>
<UnitName Value="VirtualTrees"/>
</Item2>
<Item3>
<Filename Value="VTHeaderPopup.pas"/>
<UnitName Value="VTHeaderPopup"/>
</Item3>
<Item4>
<Filename Value="registervirtualtreeview.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="registervirtualtreeview"/>
</Item4>
<Item5>
<Filename Value="ideicons.lrs"/>
<Type Value="LRS"/>
</Item5>
<Item6>
<Filename Value="VTConfig.inc"/>
<Type Value="Include"/>
</Item6>
<Item7>
<Filename Value="VTGraphics.pas"/>
<UnitName Value="VTGraphics"/>
</Item7>
</Files>
<Type Value="RunAndDesignTime"/>
<RequiredPkgs Count="2">
<Item1>
<PackageName Value="lclextensions_package"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
</PublishOptions>
</Package>
</CONFIG>

22
components/virtualtreeview/virtualtreeview_package.pas Normal file
View file

@ -0,0 +1,22 @@
{ This file was automatically created by Lazarus. Do not edit!
This source is only used to compile and install the package.
}
unit virtualtreeview_package;
interface
uses
VirtualTrees, VTHeaderPopup, registervirtualtreeview, VTGraphics,
LazarusPackageIntf;
implementation
procedure Register;
begin
RegisterUnit('registervirtualtreeview', @registervirtualtreeview.Register);
end;
initialization
RegisterPackage('virtualtreeview_package', @Register);
end.

85
components/virtualtreeview/vtlogger.pas Normal file
View file

@ -0,0 +1,85 @@
unit vtlogger;
{$mode objfpc}{$H+}
interface
uses
multiloglcl, multilog;
const
//lc stands for LogClass
//it's possible to define the constants to suit any need
lcAll = [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31];
lcDebug = 0;
lcError = 1;
lcInfo = 2;
lcWarning = 3;
lcEvents = 4;
lcPaint = 5;
lcPaintHeader = 6;
lcDummyFunctions = 7;
lcMessages = 8;
lcPaintSelection = 9;
lcSetCursor = 10;//it generates a lot of messages. so it will be debugged alone
lcPaintBitmap = 11;
lcScroll = 12;
lcPaintDetails = 13;
lcCheck = 14;
lcEditLink = 15;
lcEraseBkgnd = 16;
lcColumnPosition = 17;
lcTimer = 18;
lcDrag = 19;
lcOle = 20;
lcPanning = 21;
lcHeaderOffset = 22;
lcSelection = 23;
lcAlphaBlend = 24;
lcHint = 25;
lcMouseEvent = 26;
var
Logger: TLCLLogger;
function GetSelectedNodes(Sender: TLogger; Data: Pointer; var DoSend: Boolean): String;
implementation
uses
VirtualTrees, sysutils;
type
TNodeData = record
Title: String;
end;
PNodeData = ^TNodeData;
function GetSelectedNodes(Sender: TLogger; Data: Pointer; var DoSend: Boolean): String;
var
i: Integer;
TempNode: PVirtualNode;
begin
with TBaseVirtualTree(Data) do
begin
Result:='SelectedCount: '+IntToStr(SelectedCount)+LineEnding;
TempNode:=GetFirstSelected;
if TempNode = nil then exit;
Result:=Result+PNodeData(GetNodeData(TempNode))^.Title+LineEnding;
for i:= 1 to SelectedCount -1 do
begin
TempNode:=GetNextSelected(TempNode);
Result:=Result+PNodeData(GetNodeData(TempNode))^.Title+LineEnding;
end;
end;
end;
initialization
Logger:=TLCLLogger.Create;
finalization
Logger.Free;
end.

10
src/fmain.pas
View file

@ -675,7 +675,11 @@ uses
uFileSourceOperationTypes, uFileSourceCopyOperation, uFileSourceMoveOperation,
fFileOpDlg, uFileSourceProperty, uFileSourceExecuteOperation, uArchiveFileSource,
uShellExecute, fSymLink, fHardLink, uExceptions, uUniqueInstance, Clipbrd,
uFileSourceOperationOptionsUI, uDebug, uHotkeyManager, uFileSourceUtil;
uFileSourceOperationOptionsUI, uDebug, uHotkeyManager, uFileSourceUtil
{$IFDEF COLUMNSFILEVIEW_VTV}
, uColumnsFileViewVtv
{$ENDIF}
;
const
HotkeysCategory = 'Main';
@ -3417,7 +3421,11 @@ begin
if gDelayLoadingTabs then
FileViewFlags := [fvfDelayLoadingFiles];
if sType = 'columns' then
{$IFDEF COLUMNSFILEVIEW_VTV}
Result := TColumnsFileViewVTV.Create(Page, AConfig, ANode, FileViewFlags)
{$ELSE}
Result := TColumnsFileView.Create(Page, AConfig, ANode, FileViewFlags)
{$ENDIF}
else if sType = 'brief' then
Result := TBriefFileView.Create(Page, AConfig, ANode, FileViewFlags)
else

4183
src/newdesign/ucolumnsfileviewvtv.pas Normal file
View file

File diff suppressed because it is too large Load diff