pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

Import from old repository

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@56 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
blikblum
2007-02-17 21:09:58 +00:00
parent b1f0ba6dc2
commit 4d30d1b397
34 changed files with 34755 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

444
components/virtualtreeview/Compilers.inc Normal file
View File

@ -0,0 +1,444 @@
//----------------------------------------------------------------------------------------------------------------------
// Include file to determine which compiler is currently being used to build the project/component.
// This file uses ideas from Brad Stowers DFS.inc file.
//
// Portions created by Mike Lischke are
// Copyright (C) 1999-2005 Mike Lischke. All Rights Reserved.
// Portions created by Jim Kueneman are
// Copyright (C) 2005 Jim Kueneman. All Rights Reserved.
//
//----------------------------------------------------------------------------------------------------------------------
//
// This unit is released under the MIT license:
// Copyright (c) 1999-2005 Mike Lischke (support@soft-gems.net, www.soft-gems.net).
//
// Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated
// documentation files (the "Software"), to deal in the Software without restriction, including without limitation the
// rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to
// permit persons to whom the Software is furnished to do so, subject to the following conditions:
//
// The above copyright notice and this permission notice shall be included in all copies or substantial portions of the
// Software.
//
// THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE
// WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS
// OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
// OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
//
// You are asked to give the author(s) the due credit. This means that you acknowledge the work of the author(s)
// in the product documentation, about box, help or wherever a prominent place is.
//
//----------------------------------------------------------------------------------------------------------------------
//
// The following symbols are defined:
//
// - COMPILER_1 : Kylix/Delphi/BCB 1.x is the compiler.
// - COMPILER_1_UP : Kylix/Delphi/BCB 1.x or higher is the compiler.
// - COMPILER_2 : Kylix/Delphi 2.x or BCB 1.x is the compiler.
// - COMPILER_2_UP : Kylix/Delphi 2.x or higher, or BCB 1.x or higher is the compiler.
// - COMPILER_3 : Kylix/Delphi/BCB 3.x is the compiler.
// - COMPILER_3_UP : Kylix/Delphi/BCB 3.x or higher is the compiler.
// - COMPILER_4 : Kylix/Delphi/BCB 4.x is the compiler.
// - COMPILER_4_UP : Kylix/Delphi/BCB 4.x or higher is the compiler.
// - COMPILER_5 : Kylix/Delphi/BCB 5.x is the compiler.
// - COMPILER_5_UP : Kylix/Delphi/BCB 5.x or higher is the compiler.
// - COMPILER_6 : Kylix/Delphi/BCB 6.x is the compiler.
// - COMPILER_6_UP : Kylix/Delphi/BCB 6.x or higher is the compiler.
// - COMPILER_7 : Kylix/Delphi/BCB 7.x is the compiler.
// - COMPILER_7_UP : Kylix/Delphi/BCB 7.x or higher is the compiler.
// - COMPILER_8 : Kylix/Delphi/BCB 8.x is the compiler.
// - COMPILER_8_UP : Kylix/Delphi/BCB 8.x or higher is the compiler.
// - COMPILER_9 : Kylix/Delphi/BCB 9.x is the compiler.
// - COMPILER_9_UP : Kylix/Delphi/BCB 9.x or higher is the compiler.
// - COMPILER_10 : Kylix/Delphi/BCB 10.x is the compiler.
// - COMPILER_10_UP : Kylix/Delphi/BCB 10.x or higher is the compiler.
//
// Only defined if Windows is the target:
// - CPPB : Any version of BCB is being used.
// - CPPB_1 : BCB v1.x is being used.
// - CPPB_3 : BCB v3.x is being used.
// - CPPB_3_UP : BCB v3.x or higher is being used.
// - CPPB_4 : BCB v4.x is being used.
// - CPPB_4_UP : BCB v4.x or higher is being used.
// - CPPB_5 : BCB v5.x is being used.
// - CPPB_5_UP : BCB v5.x or higher is being used.
// - CPPB_6 : BCB v6.x is being used.
// - CPPB_6_UP : BCB v6.x or higher is being used.
//
// Only defined if Windows is the target:
// - DELPHI : Any version of Delphi is being used.
// - DELPHI_1 : Delphi v1.x is being used.
// - DELPHI_2 : Delphi v2.x is being used.
// - DELPHI_2_UP : Delphi v2.x or higher is being used.
// - DELPHI_3 : Delphi v3.x is being used.
// - DELPHI_3_UP : Delphi v3.x or higher is being used.
// - DELPHI_4 : Delphi v4.x is being used.
// - DELPHI_4_UP : Delphi v4.x or higher is being used.
// - DELPHI_5 : Delphi v5.x is being used.
// - DELPHI_5_UP : Delphi v5.x or higher is being used.
// - DELPHI_6 : Delphi v6.x is being used.
// - DELPHI_6_UP : Delphi v6.x or higher is being used.
// - DELPHI_7 : Delphi v7.x is being used.
// - DELPHI_7_UP : Delphi v7.x or higher is being used.
// - DELPHI_8 : Delphi v8.x is being used.
// - DELPHI_8_UP : Delphi v8.x or higher is being used.
// - DELPHI_9 : Delphi v9.x is being used.
// - DELPHI_9_UP : Delphi v9.x or higher is being used.
// - DELPHI_XXX is not used any more, use the COMPILER_XXX defines
//
// Only defined if Linux is the target:
// - KYLIX : Any version of Kylix is being used.
// - KYLIX_1 : Kylix 1.x is being used.
// - KYLIX_1_UP : Kylix 1.x or higher is being used.
// - KYLIX_2 : Kylix 2.x is being used.
// - KYLIX_2_UP : Kylix 2.x or higher is being used.
// - KYLIX_3 : Kylix 3.x is being used.
// - KYLIX_3_UP : Kylix 3.x or higher is being used.
//
// Only defined if Linux is the target:
// - QT_CLX : Trolltech's QT library is being used.
//
// Only defined if Delphi.NET is the target:
// - DELPHI.NET : Any version of Delphi.NET is being used.
// - DELPHI.NET_1 : Delphi.NET version 1.x is being used.
// - DELPHI.NET_1_UP : Delphi.NET version 1.x is being used.
//----------------------------------------------------------------------------------------------------------------------
{$ifdef CLR} // The common language runtime symbol is only defined for the .NET platform.
{$define DELPHI.NET}
{$ifdef VER160}
{$define DELPHI.NET_1}
{$endif VER160}
// Compiler defines common to all .NET versions.
{$ifdef DELPHI.NET_1}
{$define DELHI.NET_1_UP}
{$endif DELPHI.NET_1}
{$endif CLR}
{$ifdef Win32}
// DELPHI and BCB are no longer defined, only COMPILER
{$ifdef VER180}
{$define COMPILER_10}
{$endif VER180}
{$ifdef VER170}
{$define COMPILER_9}
{$define DELPHI}
{$define DELPHI_9}
{$endif VER170}
{$ifdef VER160}
{$define COMPILER_8}
{$define DELPHI}
{$define DELPHI_8}
{$endif VER160}
{$ifdef VER150}
{$define COMPILER_7}
{$define DELPHI}
{$define DELPHI_7}
{$endif}
{$ifdef VER140}
{$define COMPILER_6}
{$ifdef BCB}
{$define CPPB}
{$define CPPB_6}
{$else}
{$define DELPHI}
{$define DELPHI_6}
{$endif}
{$endif}
{$ifdef VER130}
{$define COMPILER_5}
{$ifdef BCB}
{$define CPPB}
{$define CPPB_5}
{$else}
{$define DELPHI}
{$define DELPHI_5}
{$endif}
{$endif}
{$ifdef VER125}
{$define COMPILER_4}
{$define CPPB}
{$define CPPB_4}
{$endif}
{$ifdef VER120}
{$define COMPILER_4}
{$define DELPHI}
{$define DELPHI_4}
{$endif}
{$ifdef VER110}
{$define COMPILER_3}
{$define CPPB}
{$define CPPB_3}
{$endif}
{$ifdef VER100}
{$define COMPILER_3}
{$define DELPHI}
{$define DELPHI_3}
{$endif}
{$ifdef VER93}
{$define COMPILER_2} // C++ Builder v1 compiler is really v2
{$define CPPB}
{$define CPPB_1}
{$endif}
{$ifdef VER90}
{$define COMPILER_2}
{$define DELPHI}
{$define DELPHI_2}
{$endif}
{$ifdef VER80}
{$define COMPILER_1}
{$define DELPHI}
{$define DELPHI_1}
{$endif}
{$ifdef DELPHI_2}
{$define DELPHI_2_UP}
{$endif}
{$ifdef DELPHI_3}
{$define DELPHI_2_UP}
{$define DELPHI_3_UP}
{$endif}
{$ifdef DELPHI_4}
{$define DELPHI_2_UP}
{$define DELPHI_3_UP}
{$define DELPHI_4_UP}
{$endif}
{$ifdef DELPHI_5}
{$define DELPHI_2_UP}
{$define DELPHI_3_UP}
{$define DELPHI_4_UP}
{$define DELPHI_5_UP}
{$endif}
{$ifdef DELPHI_6}
{$define DELPHI_2_UP}
{$define DELPHI_3_UP}
{$define DELPHI_4_UP}
{$define DELPHI_5_UP}
{$define DELPHI_6_UP}
{$endif}
{$ifdef DELPHI_7}
{$define DELPHI_2_UP}
{$define DELPHI_3_UP}
{$define DELPHI_4_UP}
{$define DELPHI_5_UP}
{$define DELPHI_6_UP}
{$define DELPHI_7_UP}
{$endif}
{$ifdef DELPHI_8}
{$define DELPHI_2_UP}
{$define DELPHI_3_UP}
{$define DELPHI_4_UP}
{$define DELPHI_5_UP}
{$define DELPHI_6_UP}
{$define DELPHI_7_UP}
{$define DELPHI_8_UP}
{$endif}
{$ifdef DELPHI_9}
{$define DELPHI_2_UP}
{$define DELPHI_3_UP}
{$define DELPHI_4_UP}
{$define DELPHI_5_UP}
{$define DELPHI_6_UP}
{$define DELPHI_7_UP}
{$define DELPHI_8_UP}
{$define DELPHI_9_UP}
{$endif}
{$ifdef CPPB_3}
{$define CPPB_3_UP}
{$endif}
{$ifdef CPPB_4}
{$define CPPB_3_UP}
{$define CPPB_4_UP}
{$endif}
{$ifdef CPPB_5}
{$define CPPB_3_UP}
{$define CPPB_4_UP}
{$define CPPB_5_UP}
{$endif}
{$ifdef CPPB_6}
{$define CPPB_3_UP}
{$define CPPB_4_UP}
{$define CPPB_5_UP}
{$define CPPB_6_UP}
{$endif}
{$ifdef CPPB_3_UP}
// C++ Builder requires this if you use Delphi components in run-time packages.
{$ObjExportAll On}
{$endif}
{$else (not Windows)}
// Linux is the target
{$define QT_CLX}
{$define KYLIX}
{$ifdef VER140}
{$define COMPILER_6}
{$ifdef conditionalexpressions}
{$if Declared(RTLVersion) and (RTLVersion = 14)}
{$define KYLIX_1}
{$ifend}
{$if Declared(RTLVersion) and (RTLVersion = 14.2)}
{$define KYLIX_2}
{$ifend}
{$if Declared(RTLVersion) and (RTLVersion = 14.5)}
{$define KYLIX_3}
{$ifend}
{$endif}
{$endif}
{$ifdef VER150}
{$define COMPILER_7}
{$define KYLIX_3}
{$endif}
{$ifdef VER140}
{$define COMPILER_6}
{$define KYLIX_2}
{$endif}
{$ifdef KYLIX_1}
{$define KYLIX_1_UP}
{$endif}
{$ifdef KYLIX_2}
{$define KYLIX_2_UP}
{$endif}
{$ifdef KYLIX_3}
{$define KYLIX_2_UP}
{$define KYLIX_3_UP}
{$endif}
{$endif Win32}
// Compiler defines not specific to a particlular platform.
{$ifdef COMPILER_1}
{$define COMPILER_1_UP}
{$endif}
{$ifdef COMPILER_2}
{$define COMPILER_1_UP}
{$define COMPILER_2_UP}
{$endif}
{$ifdef COMPILER_3}
{$define COMPILER_1_UP}
{$define COMPILER_2_UP}
{$define COMPILER_3_UP}
{$endif}
{$ifdef COMPILER_4}
{$define COMPILER_1_UP}
{$define COMPILER_2_UP}
{$define COMPILER_3_UP}
{$define COMPILER_4_UP}
{$endif}
{$ifdef COMPILER_5}
{$define COMPILER_1_UP}
{$define COMPILER_2_UP}
{$define COMPILER_3_UP}
{$define COMPILER_4_UP}
{$define COMPILER_5_UP}
{$endif}
{$ifdef COMPILER_6}
{$define COMPILER_1_UP}
{$define COMPILER_2_UP}
{$define COMPILER_3_UP}
{$define COMPILER_4_UP}
{$define COMPILER_5_UP}
{$define COMPILER_6_UP}
{$endif}
{$ifdef COMPILER_7}
{$define COMPILER_1_UP}
{$define COMPILER_2_UP}
{$define COMPILER_3_UP}
{$define COMPILER_4_UP}
{$define COMPILER_5_UP}
{$define COMPILER_6_UP}
{$define COMPILER_7_UP}
{$endif}
{$ifdef COMPILER_8}
{$define COMPILER_1_UP}
{$define COMPILER_2_UP}
{$define COMPILER_3_UP}
{$define COMPILER_4_UP}
{$define COMPILER_5_UP}
{$define COMPILER_6_UP}
{$define COMPILER_7_UP}
{$define COMPILER_8_UP}
{$endif}
{$ifdef COMPILER_9}
{$define COMPILER_1_UP}
{$define COMPILER_2_UP}
{$define COMPILER_3_UP}
{$define COMPILER_4_UP}
{$define COMPILER_5_UP}
{$define COMPILER_6_UP}
{$define COMPILER_7_UP}
{$define COMPILER_8_UP}
{$define COMPILER_9_UP}
{$endif}
{$ifdef COMPILER_10}
{$define COMPILER_1_UP}
{$define COMPILER_2_UP}
{$define COMPILER_3_UP}
{$define COMPILER_4_UP}
{$define COMPILER_5_UP}
{$define COMPILER_6_UP}
{$define COMPILER_7_UP}
{$define COMPILER_8_UP}
{$define COMPILER_9_UP}
{$define COMPILER_10_UP}
// Backwards compatibility
{$define DELPHI_2_UP}
{$define DELPHI_3_UP}
{$define DELPHI_4_UP}
{$define DELPHI_5_UP}
{$define DELPHI_6_UP}
{$define DELPHI_7_UP}
{$define DELPHI_8_UP}
{$define DELPHI_9_UP}
{$define CPPB_3_UP}
{$define CPPB_4_UP}
{$define CPPB_5_UP}
{$define CPPB_6_UP}
{$endif}
//----------------------------------------------------------------------------------------------------------------------

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.

35
components/virtualtreeview/VTConfig.inc Normal file
View File

@ -0,0 +1,35 @@
// 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}
{.$define TntSupport} // Added by Igor Afanasyev to support unicode-aware inplace editors. This implementation uses
// Troy Wolbrink's TNT controls, which can be found at:
// http://home.ccci.org/wolbrink/tnt/delphi_unicode_controls.htm.
//Lazarus port options
{$define EnableOLE}
{.$define EnableNativeTVM}
{.$define EnablePrint}
{$define NeedWindows}
{.$define EnableAdvancedGraphics}
{.$define EnableHeader}
{.$define EnableTimer}
{.$define EnableAccessible}

251
components/virtualtreeview/VTHeaderPopup.pas Normal file
View File

@ -0,0 +1,251 @@
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.
//----------------------------------------------------------------------------------------------------------------------
{$I Compilers.inc}
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.

32072
components/virtualtreeview/VirtualTrees.pas Normal file
View File

File diff suppressed because it is too large Load Diff

103
components/virtualtreeview/demos/mininal/Main.lfm Normal file
View File

@ -0,0 +1,103 @@
object MainForm: TMainForm
Left = 353
Height = 481
Top = 172
Width = 425
HorzScrollBar.Page = 424
VertScrollBar.Page = 480
ActiveControl = VST
Caption = 'Simple Virtual Treeview demo'
Font.Height = -11
Font.Name = 'MS Sans Serif'
OnCreate = FormCreate
object Label1: TLabel
Left = 12
Height = 14
Top = 12
Width = 117
Caption = 'Last operation duration:'
Color = clNone
ParentColor = False
end
object VST: TVirtualStringTree
Left = 8
Height = 318
Top = 36
Width = 397
Anchors = [akTop, akLeft, akRight, akBottom]
Colors.BorderColor = clWindowText
Colors.HotColor = clBlack
Header.AutoSizeIndex = -1
Header.Font.Height = -11
Header.Font.Name = 'MS Sans Serif'
Header.MainColumn = -1
Header.Options = [hoColumnResize, hoDrag]
HintAnimation = hatNone
IncrementalSearch = isAll
RootNodeCount = 100
TabOrder = 0
TreeOptions.AnimationOptions = [toAnimatedToggle]
TreeOptions.AutoOptions = [toAutoDropExpand, toAutoTristateTracking]
TreeOptions.MiscOptions = [toEditable, toInitOnSave, toToggleOnDblClick, toWheelPanning]
TreeOptions.PaintOptions = [toShowButtons, toShowRoot, toShowTreeLines, toThemeAware, toUseBlendedImages]
TreeOptions.SelectionOptions = [toMultiSelect, toCenterScrollIntoView]
OnFreeNode = VSTFreeNode
OnGetText = VSTGetText
OnInitNode = VSTInitNode
Columns = <>
end
object ClearButton: TButton
Left = 97
Height = 25
Top = 421
Width = 129
Anchors = [akLeft, akBottom]
BorderSpacing.InnerBorder = 4
Caption = 'Clear tree'
OnClick = ClearButtonClick
TabOrder = 1
end
object AddOneButton: TButton
Left = 96
Height = 25
Top = 361
Width = 130
Anchors = [akLeft, akBottom]
BorderSpacing.InnerBorder = 4
Caption = 'Add node(s) to root'
OnClick = AddButtonClick
TabOrder = 2
end
object Edit1: TEdit
Left = 8
Height = 21
Top = 377
Width = 81
Anchors = [akLeft, akBottom]
TabOrder = 3
Text = '1'
end
object Button1: TButton
Tag = 1
Left = 96
Height = 25
Top = 389
Width = 130
Anchors = [akLeft, akBottom]
BorderSpacing.InnerBorder = 4
Caption = 'Add node(s) as children'
OnClick = AddButtonClick
TabOrder = 4
end
object CloseButton: TButton
Left = 330
Height = 25
Top = 421
Width = 75
Anchors = [akRight, akBottom]
BorderSpacing.InnerBorder = 4
Caption = 'Close'
OnClick = CloseButtonClick
TabOrder = 5
end
end

40
components/virtualtreeview/demos/mininal/Main.lrs Normal file
View File

@ -0,0 +1,40 @@
{ This is an automatically generated lazarus resource file }
LazarusResources.Add('TMainForm','FORMDATA',[
'TPF0'#9'TMainForm'#8'MainForm'#4'Left'#3'a'#1#6'Height'#3#225#1#3'Top'#3#172
+#0#5'Width'#3#169#1#18'HorzScrollBar.Page'#3#168#1#18'VertScrollBar.Page'#3
+#224#1#13'ActiveControl'#7#3'VST'#7'Caption'#6#28'Simple Virtual Treeview de'
+'mo'#11'Font.Height'#2#245#9'Font.Name'#6#13'MS Sans Serif'#8'OnCreate'#7#10
+'FormCreate'#0#6'TLabel'#6'Label1'#4'Left'#2#12#6'Height'#2#14#3'Top'#2#12#5
+'Width'#2'u'#7'Caption'#6#24'Last operation duration:'#5'Color'#7#6'clNone'
+#11'ParentColor'#8#0#0#18'TVirtualStringTree'#3'VST'#4'Left'#2#8#6'Height'#3
+'>'#1#3'Top'#2'$'#5'Width'#3#141#1#7'Anchors'#11#5'akTop'#6'akLeft'#7'akRigh'
+'t'#8'akBottom'#0#18'Colors.BorderColor'#7#12'clWindowText'#15'Colors.HotCol'
+'or'#7#7'clBlack'#20'Header.AutoSizeIndex'#2#255#18'Header.Font.Height'#2#245
+#16'Header.Font.Name'#6#13'MS Sans Serif'#17'Header.MainColumn'#2#255#14'Hea'
+'der.Options'#11#14'hoColumnResize'#6'hoDrag'#0#13'HintAnimation'#7#7'hatNon'
+'e'#17'IncrementalSearch'#7#5'isAll'#13'RootNodeCount'#2'd'#8'TabOrder'#2#0
+#28'TreeOptions.AnimationOptions'#11#16'toAnimatedToggle'#0#23'TreeOptions.A'
+'utoOptions'#11#16'toAutoDropExpand'#22'toAutoTristateTracking'#0#23'TreeOpt'
+'ions.MiscOptions'#11#10'toEditable'#12'toInitOnSave'#18'toToggleOnDblClick'
+#14'toWheelPanning'#0#24'TreeOptions.PaintOptions'#11#13'toShowButtons'#10't'
+'oShowRoot'#15'toShowTreeLines'#12'toThemeAware'#18'toUseBlendedImages'#0#28
+'TreeOptions.SelectionOptions'#11#13'toMultiSelect'#22'toCenterScrollIntoVie'
+'w'#0#10'OnFreeNode'#7#11'VSTFreeNode'#9'OnGetText'#7#10'VSTGetText'#10'OnIn'
+'itNode'#7#11'VSTInitNode'#7'Columns'#14#0#0#0#7'TButton'#11'ClearButton'#4
+'Left'#2'a'#6'Height'#2#25#3'Top'#3#165#1#5'Width'#3#129#0#7'Anchors'#11#6'a'
+'kLeft'#8'akBottom'#0#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#10'Clea'
+'r tree'#7'OnClick'#7#16'ClearButtonClick'#8'TabOrder'#2#1#0#0#7'TButton'#12
+'AddOneButton'#4'Left'#2'`'#6'Height'#2#25#3'Top'#3'i'#1#5'Width'#3#130#0#7
+'Anchors'#11#6'akLeft'#8'akBottom'#0#25'BorderSpacing.InnerBorder'#2#4#7'Cap'
+'tion'#6#19'Add node(s) to root'#7'OnClick'#7#14'AddButtonClick'#8'TabOrder'
+#2#2#0#0#5'TEdit'#5'Edit1'#4'Left'#2#8#6'Height'#2#21#3'Top'#3'y'#1#5'Width'
+#2'Q'#7'Anchors'#11#6'akLeft'#8'akBottom'#0#8'TabOrder'#2#3#4'Text'#6#1'1'#0
+#0#7'TButton'#7'Button1'#3'Tag'#2#1#4'Left'#2'`'#6'Height'#2#25#3'Top'#3#133
+#1#5'Width'#3#130#0#7'Anchors'#11#6'akLeft'#8'akBottom'#0#25'BorderSpacing.I'
+'nnerBorder'#2#4#7'Caption'#6#23'Add node(s) as children'#7'OnClick'#7#14'Ad'
+'dButtonClick'#8'TabOrder'#2#4#0#0#7'TButton'#11'CloseButton'#4'Left'#3'J'#1
+#6'Height'#2#25#3'Top'#3#165#1#5'Width'#2'K'#7'Anchors'#11#7'akRight'#8'akBo'
+'ttom'#0#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#5'Close'#7'OnClick'#7
+#16'CloseButtonClick'#8'TabOrder'#2#5#0#0#0
]);

190
components/virtualtreeview/demos/mininal/Main.pas Normal file
View File

@ -0,0 +1,190 @@
unit Main;
{$MODE Delphi}
{$define DEBUG}
// Demonstration project for TVirtualStringTree to generally show how to get started.
// Written by Mike Lischke.
interface
uses
{$ifdef DEBUG}
vtlogger, ipcchannel,
{$endif}
LCLIntf, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
VirtualTrees, StdCtrls, ExtCtrls, LResources, Buttons;
type
TMainForm = class(TForm)
VST: TVirtualStringTree;
ClearButton: TButton;
AddOneButton: TButton;
Edit1: TEdit;
Button1: TButton;
Label1: TLabel;
CloseButton: TButton;
procedure FormCreate(Sender: TObject);
procedure ClearButtonClick(Sender: TObject);
procedure AddButtonClick(Sender: TObject);
procedure VSTGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;
var Text: WideString);
procedure VSTFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode);
procedure VSTInitNode(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode;
var InitialStates: TVirtualNodeInitStates);
procedure CloseButtonClick(Sender: TObject);
end;
var
MainForm: TMainForm;
//----------------------------------------------------------------------------------------------------------------------
implementation
type
// This is a very simple record we use to store data in the nodes.
// Since the application is responsible to manage all data including the node's caption
// this record can be considered as minimal requirement in all VT applications.
// Extend it to whatever your application needs.
PMyRec = ^TMyRec;
TMyRec = record
Caption: WideString;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TMainForm.FormCreate(Sender: TObject);
begin
{$ifdef DEBUG}
Logger.ActiveClasses:=[lcScroll];
Logger.Channels.Add(TIPCChannel.Create);
Logger.Clear;
Logger.MaxStackCount:=10;
{$endif}
// Let the tree know how much data space we need.
VST.NodeDataSize := SizeOf(TMyRec);
// Set an initial number of nodes.
VST.RootNodeCount := 20;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TMainForm.ClearButtonClick(Sender: TObject);
var
Start: Cardinal;
begin
Screen.Cursor := crHourGlass;
try
Start := GetTickCount;
VST.Clear;
Label1.Caption := Format('Last operation duration: %d ms', [GetTickCount - Start]);
finally
Screen.Cursor := crDefault;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TMainForm.AddButtonClick(Sender: TObject);
var
Count: Cardinal;
Start: Cardinal;
begin
// Add some nodes to the treeview.
Screen.Cursor := crHourGlass;
with VST do
try
Start := GetTickCount;
case (Sender as TButton).Tag of
0: // add to root
begin
Count := StrToInt(Edit1.Text);
RootNodeCount := RootNodeCount + Count;
end;
1: // add as child
if Assigned(FocusedNode) then
begin
Count := StrToInt(Edit1.Text);
ChildCount[FocusedNode] := ChildCount[FocusedNode] + Count;
Expanded[FocusedNode] := True;
InvalidateToBottom(FocusedNode);
end;
end;
Label1.Caption := Format('Last operation duration: %d ms', [GetTickCount - Start]);
finally
Screen.Cursor := crDefault;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TMainForm.VSTGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;
var Text: WideString);
var
Data: PMyRec;
begin
// A handler for the OnGetText event is always needed as it provides the tree with the string data to display.
// Note that we are always using WideString.
Data := Sender.GetNodeData(Node);
if Assigned(Data) then
Text := Data.Caption;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TMainForm.VSTFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode);
var
Data: PMyRec;
begin
Data := Sender.GetNodeData(Node);
// Explicitely free the string, the VCL cannot know that there is one but needs to free
// it nonetheless. For more fields in such a record which must be freed use Finalize(Data^) instead touching
// every member individually.
if Assigned(Data) then
Data.Caption := '';
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TMainForm.VSTInitNode(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode;
var InitialStates: TVirtualNodeInitStates);
var
Data: PMyRec;
begin
with Sender do
begin
Data := GetNodeData(Node);
// Construct a node caption. This event is triggered once for each node but
// appears asynchronously, which means when the node is displayed not when it is added.
Data.Caption := Format('Level %d, Index %d', [GetNodeLevel(Node), Node.Index]);
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TMainForm.CloseButtonClick(Sender: TObject);
begin
Close;
end;
//----------------------------------------------------------------------------------------------------------------------
initialization
{$i Main.lrs}
end.

1
components/virtualtreeview/demos/mininal/Minimal.exe.Manifest Normal file
View File

@ -0,0 +1 @@
<?xml version="1.0" encoding="UTF-8" standalone="yes"?> <assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> <assemblyIdentity processorArchitecture="*" version="5.1.0.0" type="win32" name="Microsoft.Windows.Shell.shell32"/> <description>Windows Shell</description> <dependency> <dependentAssembly> <assemblyIdentity type="win32" name="Microsoft.Windows.Common-Controls" version="6.0.0.0" publicKeyToken="6595b64144ccf1df" language="*" processorArchitecture="*" /> </dependentAssembly> </dependency> </assembly>

83
components/virtualtreeview/demos/mininal/minimal_lcl.lpi Normal file
View File

@ -0,0 +1,83 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="\"/>
<Version Value="5"/>
<General>
<Flags>
<AlwaysBuild Value="False"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<IconPath Value="./"/>
<TargetFileExt Value=".exe"/>
</General>
<VersionInfo>
<ProjectVersion Value=""/>
</VersionInfo>
<PublishOptions>
<Version Value="2"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<RequiredPackages Count="3">
<Item1>
<PackageName Value="virtualtreeview_package"/>
</Item1>
<Item2>
<PackageName Value="miscutils_package"/>
</Item2>
<Item3>
<PackageName Value="LCL"/>
</Item3>
</RequiredPackages>
<Units Count="3">
<Unit0>
<Filename Value="minimal_lcl.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="minimal_lcl"/>
</Unit0>
<Unit1>
<Filename Value="fmain.pas"/>
<ComponentName Value="Form1"/>
<IsPartOfProject Value="True"/>
<ResourceFilename Value="fmain.lrs"/>
<UnitName Value="fmain"/>
</Unit1>
<Unit2>
<Filename Value="Main.pas"/>
<ComponentName Value="MainForm"/>
<HasResources Value="True"/>
<IsPartOfProject Value="True"/>
<ResourceFilename Value="Main.lrs"/>
<UnitName Value="Main"/>
</Unit2>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<PathDelim Value="\"/>
<SearchPaths>
<OtherUnitFiles Value="E:\subversion\luipack\trunk\virtualtreeview\"/>
</SearchPaths>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
</CONFIG>

18
components/virtualtreeview/demos/mininal/minimal_lcl.lpr Normal file
View File

@ -0,0 +1,18 @@
program minimal_lcl;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms
{ add your units here }, Main, miscutils_package, virtualtreeview_package;
begin
Application.Initialize;
Application.CreateForm(TMainForm, MainForm);
Application.Run;
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;

235
components/virtualtreeview/lclfunctions.inc Normal file
View File

@ -0,0 +1,235 @@
//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
procedure ChangeBiDiModeAlignment(var Alignment: TAlignment);
begin
case Alignment of
taLeftJustify: Alignment := taRightJustify;
taRightJustify: Alignment := taLeftJustify;
end;
end;
function INDEXTOOVERLAYMASK(i : longint) : longint;
{ return type might be wrong }
begin
INDEXTOOVERLAYMASK:=i shl 8;
end;
function MAKEROP4(fore,back : longint) : DWORD;
begin
MAKEROP4:=DWORD((DWORD(back shl 8) and $FF000000) or DWORD(fore));
end;
function Failed(Status : HRESULT) : BOOL;
begin
Failed:=Status and HRESULT($80000000)<>0;
end;
function MapWindowPoints(hWndFrom, hWndTo: HWND; lpPoints: PPoint; cPoints: UINT): Integer;
var
I:integer;
FromRect,ToRect: TRect;
begin
Logger.AddCheckPoint(lcDummyFunctions,'MapWiindowsPoints');
//todo: implement result
GetWindowRect(hWndFrom,FromRect);
GetWindowRect(hWndTo,ToRect);
for i:=0 to cPoints - 1 do
begin
(lpPoints+i)^.x:=(FromRect.Left - ToRect.Left) + (lpPoints+i)^.x;
(lpPoints+i)^.y:=(FromRect.Top - ToRect.Top) + (lpPoints+i)^.y;
end;
end;
{$ifndef NeedWindows}
//Dummy function. Used in many places
function ImageList_DrawEx(himl:THandle; i:longint; hdcDst:HDC; x:longint;
y:longint;dx:longint; dy:longint; rgbBk:COLORREF; rgbFg:COLORREF; fStyle:UINT):Boolean;
begin
Logger.AddCheckPoint(lcDummyFunctions,'ImageList_DrawEx');
end;
//Used in TVirtualTreeColumns.AnimatedResize
function GetWindowDC(hWnd:HWND):HDC;
begin
Logger.AddCheckPoint(lcDummyFunctions,'GetWindowDC');
end;
//Used in TVTDragImage.DragTo, TVirtualTreeColumns.AnimatedResize, TBaseVirtualTree.ToggleCallback,
//TBaseVirtualTree.TileBackground
function ScrollDC(hDC:HDC; dx:longint; dy:longint; var lprcScroll:TRECT;
var lprcClip:TRECT;hrgnUpdate:HRGN; lprcUpdate:PRECT):Boolean;
begin
Logger.AddCheckPoint(lcDummyFunctions,'ScrollDC');
end;
// TCustomVirtualTreeOptions.SetPaintOptions, TVTHeader.Invalidate, TVTColors.SetColor
//CMEnabledChanged, TBaseVirtualTree.WMEnable, TBaseVirtualTree.WMVScroll,
// TBaseVirtualTree.UpdateWindowAndDragImage, TBaseVirtualTree.RepaintNode
function RedrawWindow(hWnd:HWND; lprcUpdate:PRECT; hrgnUpdate:HRGN;
flags:LongWord):Boolean; overload;
begin
Logger.AddCheckPoint(lcDummyFunctions,'RedrawWindow');
end;
function RedrawWindow(hWnd:HWND; var lprcUpdate:TRECT; hrgnUpdate:HRGN;
flags:UINT):Boolean; overload;
begin
end;
//Used in LimitPaintingToArea
function LPtoDP(_para1:HDC; _para2:PPOINT; _para3:longint):Boolean;
begin
Logger.AddCheckPoint(lcDummyFunctions,'LPtoDP');
end;
//Used to the brush of dottedline
function CreatePatternBrush(_para1:HBITMAP):HBRUSH;
var
ALog: TLogBrush;
begin
Logger.AddCheckPoint(lcDummyFunctions,'CreatePatternBrush');
//lcl_todo
with ALog do
begin
lbStyle:=0;
lbColor:=0;
lbHatch:=0;
end;
Result:=CreateBrushIndirect(ALog);
end;
function GetBkColor(_para1:HDC):COLORREF;
begin
Logger.AddCheckPoint(lcDummyFunctions,'GetBkColor');
end;
function ImageList_DragShowNolock(fShow:Boolean): Boolean;
begin
Logger.AddCheckPoint(lcDummyFunctions,'ImageList_DragShowNoLock');
end;
function GetKeyboardState(lpKeyState:PBYTE):Boolean;
begin
Logger.AddCheckPoint(lcDummyFunctions,'GetKeyboardState');
end;
function ToAscii(uVirtKey:UINT; uScanCode:UINT; lpKeyState:PBYTE;
lpChar: PChar; uFlags:UINT):longint;
begin
Logger.AddCheckPoint(lcDummyFunctions,'ToAscii');
end;
function SystemParametersInfo(uiAction:UINT; uiParam:UINT;
pvParam:Pointer; fWinIni:UINT):Boolean;
begin
Logger.AddCheckPoint(lcDummyFunctions,'SystemParameterInfo');
end;
function SetTimer(hWnd:HWND; nIDEvent:UINT; uElapse:UINT; lpTimerFunc:Pointer):UINT;
begin
Logger.AddCheckPoint(lcDummyFunctions,'SetTimer');
end;
function SubtractRect(lprcDst:TRECT; lprcSrc1:TRECT; lprcSrc2:TRECT):Boolean;
begin
Logger.AddCheckPoint(lcDummyFunctions,'SubtractRect');
end;
function DeferWindowPos(hWinPosInfo:THandle; hWnd:THandle; hWndInsertAfter:THandle;
x:longint; y:longint;cx:longint; cy:longint; uFlags:UINT):THandle;
begin
Logger.AddCheckPoint(lcDummyFunctions,'DeferWindowPos');
end;
function BeginDeferWindowPos(nNumWindows:longint):THandle;
begin
Logger.AddCheckPoint(lcDummyFunctions,'BeginDeferWindowPos');
end;
function EndDeferWindowPos(hWinPosInfo:THandle):Boolean;
begin
Logger.AddCheckPoint(lcDummyFunctions,'EndDeferWindowpos');
end;
function GetLocaleInfo(Locale:DWord; LCType:DWord; lpLCData:PChar; cchData:longint):longint;
begin
Logger.AddCheckPoint(lcDummyFunctions,'GetLocaleInfo');
end;
function GetACP:UINT;
begin
Logger.AddCheckPoint(lcDummyFunctions,'GetACP');
end;
function MultiByteToWideChar(CodePage:UINT; dwFlags:DWORD; lpMultiByteStr:PChar;
cchMultiByte:longint; lpWideCharStr:PWideChar; cchWideChar:longint):longint;
begin
Logger.AddCheckPoint(lcDummyFunctions,'MultiByteToWideChar');
end;
function GetKeyboardLayout(dwLayout:DWORD):THandle;
begin
Logger.AddCheckPoint(lcDummyFunctions,'GetKeyboardLayout');
end;
function DefWindowProc(hWnd:HWND; Msg:UINT; wParam:WPARAM; lParam:LPARAM):LRESULT;
begin
Logger.AddCheckPoint(lcDummyFunctions,'DefWindowProc');
end;
function GetDCEx(hWnd:HWND; hrgnClip:HRGN; flags:DWORD):HDC;
begin
Logger.AddCheckPoint(lcDummyFunctions,'GetDCEx');
end;
function OffsetRgn(_para1:HRGN; _para2:longint; _para3:longint):longint;
begin
Logger.AddCheckPoint(lcDummyFunctions,'OffsetRegion');
end;
function SetBrushOrgEx(_para1:HDC; _para2:longint; _para3:longint; _para4:PPOINT):Boolean;
begin
Logger.AddCheckPoint(lcDummyFunctions,'SetBrushOrgEx');
end;
{$endif}

6
components/virtualtreeview/lcltypes.inc Normal file
View File

@ -0,0 +1,6 @@
//TBiDiMode = (bdLeftToRight, bdRightToLeft, bdRightToLeftNoAlign, bdRightToLeftReadingOnly);

176
components/virtualtreeview/port.log Normal file
View File

@ -0,0 +1,176 @@
Port started in 26/01/07
1) Remove Delphi/Windows dependencies
* Determine what windows functions are used. Store in windows_functions.txt
* Undefine ThemeSupport in VTConfig.inc
* Comment OleAcc unit from uses
* Convert windows messages to LCL correspondent. Store in windows_messages.txt
* toShowButtons duplicated in DefaultPaintOptions (Delphi compiles this!!)
* unclosed comment in OLE Drag definitions
* VTV uses OLE to drag and drop and clipboard. Necessary to see how LCL handle this. For now enclose all
clipboard and drag and drop ole under ifdefs
* added {$mode delphi}{$H+}
* Change header of TEnumFormatETC, TVTDragManager, TVTDataObject to match fpc
* Add Types unit (TSize)
* THintWindow.IsHintMsg is not implemented in LCL. Comment the code
* Commented Consts and AxCtrls units in implementation
* Isolated NC functions. They are used to paint the header
* Isolated GetControlsAlignment. (Is not used in the LCL)
* Commented TStringEditLink HideSelection and OEMConvert published formats
* Added lcltypes.inc
* Added TBidiMode and BidiMode property set default to LTR
* Commented Bevel* properties publishing
* Commented ParentBidiMode property
* Commented implementation of RaiseLastOSError
* Added missing clipboard constants
* Added LCLIntf unit
* Replaced GetClipboardFormatName by ClipboardFormatToMimeType in RegisterVTClipboardFormat
* Replaced RegisterClipboardFormat by ClipboardRegisterFormat
* Added win32 color constants
* Removed ISWin2k and XP since was not used. Assume IsWinNt true
* Removed Global HintFont var used to < Delphi4. Use Screen.HintFont.
* Commented the global imagelists code. Will be implemented later
* Added dummy GetTextAlign function
* Added simple ExtTextOutW and GetTextExtentPoint32W functions. Will be revisited later
* Commented code that was using GetCurrentObject
* Commented code for a bug in the Delphi package code
* Changed way to get NeedToUnitialize. Removed succeeded
* Replaced LoadCursor by LoadCursorFromLazarusResource.
* Added virtualtrees.lrs
* Changed WorkEvent from THandle to TEvent
* Added INFINITE constant
* Removed RaiseLastOSError
* Changed typecast of EnterStates in TWorkerThread.ChangeTreeStates
* Changed parameter of ReleaseStgMedium to a Pointer
* Replaced unkForRelease for PunkForRelease in TStgMedium records, similar with stm and stg
* Isolated DragFunctions dependent of windows
* replaced lstrLenW by fpc way
* Replace Windows.DrawTextW by customized
* Added TVirtualTreeHintWindow.BidiMode property
* Replace UpdateBounds by SetBounds in Hint show routine
* In TCustomVirtualTreeOptions.SetMiscOptions called RecreateWnd
* Commented ValidateRect functions
* Implemented procedure ChangeBiDiModeAlignment
* Isolated code from TVTDragImage.MakeAlphaChannel
* In LoadFromStream changed typecast to longword
* Added dummy ImageList_DrawEx implementation
* Replaced ZeroMemory by FillChar
* Commented BevelKind in PaintHeadder
* Implemented TBaseVirtualTree.UseRightToLeftAlignment dummy function
* Isolated Header messages handling
* Added missing SetWindowPos constants
* Implemented MapWindowPoints
* Added dummy RedrawWindow function
* Commented call to DestroyWindowHandle in Destroy. Probably will not be necessary since the header will be
in the client area
* Used Application.ProcessMessages in InterruptValidation instead of direct call
* Added dummy LPtoDP
* Replaced LoadBitmap by LoadFromLazarusResource
* Added dummy CreatePatternBrush
* Added Dummy GetBkColor
* Replaced Reader.ReadStr by Reader.ReadString
* Added WM_SETREDRAW constant
* Added MAKEROP4
* Added dummy ImageList_DragShowNolock
* Replaced GetUpdateRect in WMPaint
* Added dummy ToAscii and GetKeyboardState
* Added WHEEL_ constants
* Added Dummy SystemParametersInfo
* Added Dummy SetTimer, isolated timer functions
* Isolated CreateParams function
* Added Failed function
* Added dummy SubtractRect function
* Replaced Canvas.TextFlags by TextStyle
* Added LResources unit
* Used the PackArray Implmentation from original port
* The TCanvas of VCL does not has width and height as LCL does. This cause conflict with "with" operator
* Implemented TOLEStream
* Fixed bug in LCL.GetScrollPos
* Fixed Draw problems due to TCanvas.Color
* Fixed Align problems of TVirtualNode (Hint from original port)
* Fixed MouseWheel
#Major Tasks#
< > General Painting
[ ] The NodeBitmap width/Height is not reseted when erasing the background
< > Define the UNICODE support schema. Probably change from widestring to ansistring and let LCL do the rest
[ ] Use GetTextExtentPoint instead of GetTextExtentPoint32 since the later is a wrapper to the former in LCL
[ ] For now all rendering will be done with DrawTextW wrapper > Windows.DrawTextW
< > Find a way to mantain OLE drag and Drop in windows
[ ] Also maintain OLE ClipBoard?? Necessary??
< > Replace TWMTimer since is only called in win32. Or implement in GTK Intf?
< > Implement Imagelist handling
< > GetCurrentObject used for blending does not exists in LCL. Add it?
[ ] Gtk.GetObject does not return dmBits (is always nil)
< > Implement the header
[ ] BevelEdges is used to paint the Header. See if is worth implementing it
[ ] Process the header messages or do another way
[ ] See if DestroyWindowHandle is necessary in Destroy
< > Bidi Support
[ ]Properly Implement TBaseVirtualTree.UseRightToLeftAlignment
#Secondary Tasks#
< > (low) OleAcc: MSAA (Accessibility)
< > WMContextMenu: replace by DoContextPopup??. Add to LCL??
[ ] Fix Double MouseRUp
[ ] in line 2042 of callback simplify
< > pceltFetched in TEnumFormatEtc.Next is declared as ULong in fpc but PLongInt in Delphi
< > Implement THintWindow.IsHintMsg ?
< > Add TLMEnable ??
< > Replace WMSetFont since LM_SETFONT is not used in LCL
<*> Replace RaiseLastOSError. Is used in only one place -> Removed
< > IsWinNT is currently set to True. See if will support win98 and how do it
< > See what todo with GetTextAlign. Implement in LCL??
< > Thread support
[ ] Replace TVTCriticalSection by SyncObjs.TCriticalSection??
[ ] See appropriate value for INFINITE constant in Linux/BSD etc
< > TWorkerThread.ChangeTreeStates uses SendMessage. See if it works both in win and linux
< > In fpc TStgMedium records have PunkForRelease instead of unkForRelease, same for stm and stg
< > Add a way to replace TBitmap.Scanline and all advanced graphics routines
[ ] Use TLazIntfImage?
[ ] Properly implement CreatePatternBrush or find a way to paint the lines
< > Implement GetBkColor in LCL
< > Begin/EndUpdate uses WM_SETREDRAW message to avoid painting. See a crossplatform way of doing it
<*> Translate MAKEROP4 from C to Pascal. Done copied from fpc
< > TCMMouseWheel is not used in Lazarus. Remove
< > Revise CM* functions and messages
< > Implement SubtractRect
< > Implement WMSetFont
< > Implement PackArray using asm
[ ] Wait for fpc2.2
[ ] Adapt for fpc
[ ] Create versions for not i386
#Checks#
< > See if getting the length of PWideChar by typecasting to WideString is correct
< > See if the Hint is being show in the correct place
< > See the effect of using RecreateWnd (in TCustomVirtualTreeOptions.SetMiscOptions)
< > WM_NCPAINT: see the behavior under LCL
< > TVMGet* functions: probably it can be ignored, since is windows specific and not necessary at all
< > See if WM_COPY can be mapped to LM_COPYTOCLIP
< > See WM_ENABLE,WM_GETDLGCODE behavior under lcl/win32
< > See function of WM_GETOBJECT and if is necessary to add to LCL
< > See the difference between TWMPaint and TLMPaint
< > TWMPrint and WM_PRINT. See if is necessary
< > In SetCursor uses TLMessage. Investigate
< > See if GetRGBColor is necessary. Probably not. If so remove color constants
< > Found no way to replace ValidateRect in Hint Window animation. See a way to replace it
< > See if the typecasts to longword in TVirtualTreeColumn.LoadFromStream is correct
< > See te meaning of Bevel* properties see what values it should be in LCL
< > See if MapWindowPoints is returning correct values
< > See if Application.ProcessMessages in InterruptValidation will work (WM_QUIT handling??)
< > see if windows.GetUpdateRect is equal to PaintStruct in WM Paint
< > In TWMKillfocus the code to nullify the active control is probably not necessary
< > See if DeleteObject is necessary in AdjustCursorPanning
< > See if WHEEL_ constants are valids under gtk
< > See if is necessary WM_SYSCOLORCHANGE
< > See if is necessary handle LM_SETCURSOR (not used in LCL)
< > See how replace CreateParams
< > See if Canvas Respect TextStyle properties and if is necessary to set the bk in PaintNormalText
< > IStream.SetSize expects ULARGE_INTEGER instead of LARGE_INTEGER
< > Remove TRect copy in FillRect
< > In paint tree avoid using TBitmap.Canvas since it does a check each time is called
< > Why there's a extra 1 in the NodeBitmap that clears the backGround
< > See code duplicate in TBitmap.SetWidthHeight
< > Document problem of TCanvas.Color
< > Document differences between WMMouseWheel

BIN
components/virtualtreeview/resources/VT_HEADERSPLIT.cur Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 326 B

BIN
components/virtualtreeview/resources/VT_MOVEALL.cur Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 326 B

BIN
components/virtualtreeview/resources/VT_MOVEE.cur Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 766 B

BIN
components/virtualtreeview/resources/VT_MOVEEW.cur Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 766 B

BIN
components/virtualtreeview/resources/VT_MOVEN.cur Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 766 B

BIN
components/virtualtreeview/resources/VT_MOVENE.cur Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 766 B

BIN
components/virtualtreeview/resources/VT_MOVENS.cur Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 766 B

BIN
components/virtualtreeview/resources/VT_MOVENW.cur Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 766 B

BIN
components/virtualtreeview/resources/VT_MOVES.cur Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 766 B

BIN
components/virtualtreeview/resources/VT_MOVESE.cur Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 766 B

BIN
components/virtualtreeview/resources/VT_MOVESW.cur Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 766 B

BIN
components/virtualtreeview/resources/VT_MOVEW.cur Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 766 B

BIN
components/virtualtreeview/resources/VT_XPBUTTONMINUS.bmp Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 308 B

BIN
components/virtualtreeview/resources/VT_XPBUTTONPLUS.bmp Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 308 B

1
components/virtualtreeview/resources/createres.bat Normal file
View File

@ -0,0 +1 @@
lazres ..\virtualtrees.lrs VT_HEADERSPLIT.cur VT_MOVEALL.cur VT_MOVEE.cur VT_MOVEEW.cur VT_MOVEN.cur VT_MOVENE.cur VT_MOVENS.cur VT_MOVENW.cur VT_MOVES.cur VT_MOVESE.cur VT_MOVESW.cur VT_MOVEW.cur VT_XPBUTTONPLUS.bmp VT_XPBUTTONMINUS.bmp

50
components/virtualtreeview/virtualtreeview_package.lpk Normal file
View File

@ -0,0 +1,50 @@
<?xml version="1.0"?>
<CONFIG>
<Package Version="2">
<PathDelim Value="\"/>
<Name Value="virtualtreeview_package"/>
<CompilerOptions>
<Version Value="5"/>
<PathDelim Value="\"/>
<SearchPaths>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Files Count="2">
<Item1>
<Filename Value="VirtualTrees.lrs"/>
<Type Value="LRS"/>
</Item1>
<Item2>
<Filename Value="VirtualTrees.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="VirtualTrees"/>
</Item2>
</Files>
<Type Value="RunAndDesignTime"/>
<RequiredPkgs Count="3">
<Item1>
<PackageName Value="multiloglaz"/>
</Item1>
<Item2>
<PackageName Value="miscutils_package"/>
</Item2>
<Item3>
<PackageName Value="LCL"/>
</Item3>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)\"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
</PublishOptions>
</Package>
</CONFIG>

21
components/virtualtreeview/virtualtreeview_package.pas Normal file
View File

@ -0,0 +1,21 @@
{ 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, LazarusPackageIntf;
implementation
procedure Register;
begin
RegisterUnit('VirtualTrees', @VirtualTrees.Register);
end;
initialization
RegisterPackage('virtualtreeview_package', @Register);
end.

71
components/virtualtreeview/vtlogger.pas Normal file
View File

@ -0,0 +1,71 @@
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;
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.