Update VirtualTreeview component to 4.7.0, released on Aug 24, 2008.

components/virtualtreeview/Design/VirtualTreesReg.pas

@@ -561,7 +561,7 @@ begin
        'AutoScroll*',
        'ButtonStyle',
        'DefaultNodeHeight',
-       '*Images*', 'OnGetImageIndex',
+       '*Images*', 'OnGetImageIndex', 'OnGetImageText',
        'Header',
        'Indent',
        'LineStyle', 'OnGetLineStyle',
@@ -583,7 +583,7 @@ begin
 
     RegisterPropertiesInCategory({$ifdef COMPILER_5} THelpCategory, {$endif} {$ifdef COMPILER_6_UP} sHelpCategoryName, {$endif COMPILER_6_UP}
       TBaseVirtualTree,
-      ['Hint*', 'On*Hint*', 'On*Help*']);
+      ['AccessibleName', 'Hint*', 'On*Hint*', 'On*Help*']);
 
     RegisterPropertiesInCategory({$ifdef COMPILER_5} TDragNDropCategory, {$endif} {$ifdef COMPILER_6_UP} sDragNDropCategoryName, {$endif COMPILER_6_UP}
       TBaseVirtualTree,

components/virtualtreeview/Source/VTAccessibility.pas

@@ -0,0 +1,714 @@
+unit VTAccessibility;
+
+//----------------------------------------------------------------------------------------------------------------------
+//
+// Version 4.7.0
+//
+
+// This unit implements iAccessible interfaces for the VirtualTree visual components
+// and the currently focused node.
+//
+// Written by Marco Zehe. (c) 2007
+
+{$I Compilers.inc}
+
+interface
+
+uses
+  Windows, Classes, ActiveX,
+  {$ifndef COMPILER_10_UP}
+    MSAAIntf, // MSAA support for Delphi up to 2005
+  {$else}
+    oleacc, // MSAA support in Delphi 2006 or higher
+  {$endif COMPILER_10_UP}
+  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 SysUtils, 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.
+// if not set, tries the name and class name properties.
+// 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 if FVirtualTree.Name <> '' then
+        pszName := FVirtualTree.Name
+      else if FVirtualTree.ClassName <> '' then
+             pszName := FVirtualTree.ClassName
+      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.
+var
+  kind: TVTImageKind;
+  sTemp: WideString;
+begin
+  pszName := '';
+  Result := S_FALSE;
+  if varChild = childid_self then
+  begin
+    if FVirtualTree <> nil then
+      if FVirtualTree.FocusedNode <> nil then
+      begin
+        for kind := ikNormal to ikOverlay do
+        begin
+          sTemp := FVirtualTree.ImageText[FVirtualTree.FocusedNode, Kind, FVirtualTree.Header.MainColumn];
+          if sTemp <> '' then
+            pszName := pszName + sTemp  + '  ';
+        end;
+        pszName := 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, sTemp2: WideString;
+  kind: TVTImageKind;
+begin
+  pszDescription := '';
+  Result := S_FALSE;
+  if varChild = childid_self then
+  begin
+    if FVirtualTree <> nil then
+      if FVirtualTree.FocusedNode <> nil then
+      begin
+        if IncludeMainColumn then
+        begin
+          for kind := ikNormal to ikOverlay do
+          begin
+            sTemp2 := FVirtualTree.ImageText[FVirtualTree.FocusedNode, Kind, FVirtualTree.Header.MainColumn];
+            if sTemp2 <> '' then
+              sTemp2 := sTemp2 + '  ';
+          end;
+          pszDescription := sTemp2 + FVirtualTree.Text[FVirtualTree.FocusedNode, FVirtualTree.Header.MainColumn]
+           +'; ';
+        end;
+        for I := 0 to FVirtualTree.Header.Columns.Count - 1 do
+          if (FVirtualTree.Header.MainColumn <> I) and (coVisible in FVirtualTree.Header.Columns[I].Options) then
+          begin
+            for kind := ikNormal to ikOverlay do
+            begin
+              sTemp2 := FVirtualTree.ImageText[FVirtualTree.FocusedNode, Kind, I];
+              if sTemp2 <> '' then
+                sTemp := sTemp2 + '  ';
+            end;
+            sTemp := 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 IDefaultAccessibleProvider = nil then
+  begin
+    IDefaultAccessibleProvider := TVTDefaultAccessibleProvider.Create;
+    GetAccessibilityFactory.RegisterAccessibleProvider(IDefaultAccessibleProvider);
+  end;
+  if IDefaultAccessibleItemProvider = nil then
+  begin
+    IDefaultAccessibleItemProvider := TVTDefaultAccessibleItemProvider.Create;
+    GetAccessibilityFactory.RegisterAccessibleProvider(IDefaultAccessibleItemProvider);
+  end;
+  if IMultiColumnAccessibleProvider = nil then
+  begin
+    IMultiColumnAccessibleProvider := TVTMultiColumnAccessibleItemProvider.Create;
+    GetAccessibilityFactory.RegisterAccessibleProvider(IMultiColumnAccessibleProvider);
+  end;
+finalization
+    GetAccessibilityFactory.UnRegisterAccessibleProvider(IMultiColumnAccessibleProvider);
+    IMultiColumnAccessibleProvider := nil;
+      GetAccessibilityFactory.UnRegisterAccessibleProvider(IDefaultAccessibleItemProvider);
+    IDefaultAccessibleItemProvider := nil;
+    GetAccessibilityFactory.UnRegisterAccessibleProvider(IDefaultAccessibleProvider);
+    IDefaultAccessibleProvider := nil;
+end.
+
+
+

components/virtualtreeview/Source/VTAccessibilityFactory.pas

@@ -0,0 +1,171 @@
+unit VTAccessibilityFactory;
+
+//----------------------------------------------------------------------------------------------------------------------
+//
+// Version 4.7.0
+//
+
+// 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 the unit's initialization.
+// You only need to add the unit to your project, and voil<69>, you have an accessible string tree!
+//
+// Written by Marco Zehe. (c) 2007
+
+{$I Compilers.inc}
+
+interface
+
+uses
+  {$ifndef COMPILER_10_UP}
+    MSAAIntf, // MSAA support for Delphi up to 2005
+  {$else}
+    oleacc, // MSAA support in Delphi 2006 or higher
+  {$endif COMPILER_10_UP}
+  Classes, 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;
+
+function GetAccessibilityFactory: TVTAccessibilityFactory;
+
+implementation
+
+var
+  VTAccessibleFactory: TVTAccessibilityFactory = nil;
+  AccessibilityAvailable: boolean = false;
+  
+
+{ 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;
+  {$ifndef COMPILER_10_UP}
+    FreeAccLibrary;
+  {$endif COMPILER_10_UP}
+  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;
+
+function GetAccessibilityFactory: TVTAccessibilityFactory;
+
+// Accessibility helper function to create a singleton class that will create or return
+// the IAccessible interface for the tree and the focused node.
+
+begin
+  // first, check if we've loaded the library already
+  if not AccessibilityAvailable then
+    {$ifndef COMPILER_10_UP}
+      AccessibilityAvailable := InitAccLibrary;
+    {$else}
+      AccessibilityAvailable := True;
+    {$endif COMPILER_10_UP}
+  if AccessibilityAvailable then
+  begin
+    // Check to see if the class has already been created.
+    if VTAccessibleFactory = nil then
+      VTAccessibleFactory := TVTAccessibilityFactory.Create;
+    result := VTAccessibleFactory;
+  end
+  else
+    result := nil;
+end;
+
+
+initialization
+
+finalization
+  VTAccessibleFactory.free;
+end.

components/virtualtreeview/Source/VTHeaderPopup.pas

@@ -1,6 +1,9 @@
 unit VTHeaderPopup;
 
 //----------------------------------------------------------------------------------------------------------------------
+//
+// Version 4.7.0
+//
 // 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
@@ -62,6 +65,11 @@ unit VTHeaderPopup;
 
 {$I Compilers.inc}
 
+{$ifdef COMPILER_12_UP}
+  {$WARN IMPLICIT_STRING_CAST       OFF}
+  {$WARN IMPLICIT_STRING_CAST_LOSS  OFF}
+{$endif COMPILER_7_UP}
+
 interface
 
 uses

components/virtualtreeview/packages/delphi11/VirtualTreesR.dpk

@@ -34,7 +34,12 @@ requires
 
 contains
   VirtualTrees in '..\..\Source\VirtualTrees.pas',
-  VTHeaderPopup in '..\..\Source\VTHeaderPopup.pas';
+  VTHeaderPopup in '..\..\Source\VTHeaderPopup.pas',
+  VTAccessibilityFactory in '..\..\Source\VTAccessibilityFactory.pas',
+  VTAccessibility in '..\..\Source\VTAccessibility.pas';
+  // @note, Ansgar: MSAAIntf.pas is not included in the distribution,
+  //                but anyway only needed for Delphi up to 2005
+  //, MSAAIntf in '..\..\Source\MSAAIntf.pas';
 
 end.
 

components/virtualtreeview/packages/delphi11/VirtualTreesR.dproj

@@ -95,10 +95,12 @@
       <MainSource>MainSource</MainSource>
     </DelphiCompile>
     <DCCReference Include="..\..\Source\VirtualTrees.pas" />
+    <DCCReference Include="..\..\Source\VTAccessibility.pas" />
+    <DCCReference Include="..\..\Source\VTAccessibilityFactory.pas" />
     <DCCReference Include="..\..\Source\VTHeaderPopup.pas" />
     <DCCReference Include="TntUnicodeVcl.dcp" />
     <DCCReference Include="vcl.dcp" />
     <DCCReference Include="vclx.dcp" />
   </ItemGroup>
   <Import Project="$(MSBuildBinPath)\Borland.Delphi.Targets" />
-</Project>
+</Project>

source/childwin.pas

@@ -424,8 +424,8 @@ type
         HintText: WideString);
     procedure ProcessSqlLog;
     procedure ListCommandStatsBeforeCellPaint(Sender: TBaseVirtualTree;
-        TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; CellRect:
+      TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;
-        TRect);
+      CellPaintMode: TVTCellPaintMode; CellRect: TRect; var ContentRect: TRect);
     procedure ListProcessesChange(Sender: TBaseVirtualTree; Node: PVirtualNode);
     procedure editFilterVTChange(Sender: TObject);
     procedure ListColumnsDblClick(Sender: TObject);
@@ -4597,8 +4597,8 @@ end;
   Draw a progress bar on it to visualize its percentage value.
 }
 procedure TMDIChild.ListCommandStatsBeforeCellPaint(Sender: TBaseVirtualTree;
-    TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; CellRect:
+  TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;
-    TRect);
+  CellPaintMode: TVTCellPaintMode; CellRect: TRect; var ContentRect: TRect);
 var
   percent : Extended;
   barwidth, cellwidth: Integer;