From 4b4ed875f29e6452da82efc47c645f8c1efdfe42 Mon Sep 17 00:00:00 2001 From: Ansgar Becker Date: Sat, 30 May 2020 18:47:35 +0200 Subject: [PATCH] Update VirtualTree component to their current master state --- .../Source/VirtualTrees.Accessibility.pas | 1593 +++++++++-------- .../Source/VirtualTrees.StyleHooks.pas | 2 +- .../virtualtreeview/Source/VirtualTrees.pas | 145 +- 3 files changed, 892 insertions(+), 848 deletions(-) diff --git a/components/virtualtreeview/Source/VirtualTrees.Accessibility.pas b/components/virtualtreeview/Source/VirtualTrees.Accessibility.pas index a557392f..81a86ab1 100644 --- a/components/virtualtreeview/Source/VirtualTrees.Accessibility.pas +++ b/components/virtualtreeview/Source/VirtualTrees.Accessibility.pas @@ -1,796 +1,797 @@ -unit VirtualTrees.Accessibility; - -// This unit implements iAccessible interfaces for the VirtualTree visual components -// and the currently focused node. -// -// Written by Marco Zehe. (c) 2007 - -interface - -uses - Winapi.Windows, System.Classes, Winapi.ActiveX, System.Types, Winapi.oleacc, - VirtualTrees, VirtualTrees.AccessibilityFactory, Vcl.Controls; - -type - TVirtualTreeAccessibility = class(TInterfacedObject, IDispatch, IAccessible) - private - FVirtualTree: TVirtualStringTree; - public - constructor Create(AVirtualTree: TVirtualStringTree); - - { 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; - 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; - function Get_accFocus(out pvarChild: OleVariant): HRESULT; stdcall; - end; - - TVTMultiColumnItemAccessibility = class(TVirtualTreeItemAccessibility, IAccessible) - strict 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) - public - function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible; - end; - - TVTDefaultAccessibleItemProvider = class(TInterfacedObject, IVTAccessibleProvider) - public - function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible; - end; - - TVTMultiColumnAccessibleItemProvider = class(TInterfacedObject, IVTAccessibleProvider) - public - function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible; - end; - -implementation - -uses - System.SysUtils, Vcl.Forms, System.Variants, System.Math; - -type - -/// For getting access to protected members of this class -THackVirtualStringTree = class(TVirtualStringTree) -end; - -{ TVirtualTreeAccessibility } -//---------------------------------------------------------------------------------------------------------------------- -constructor TVirtualTreeAccessibility.Create(AVirtualTree: TVirtualStringTree); -// assigns the parent and current fields, and lets the control's IAccessible object know its address. -begin - inherited Create; - FVirtualTree := AVirtualTree; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -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 - else if VarType(varchild) = VT_I4 then - begin - // return the location of the focused node - if (FVirtualTree <> nil) and (FVirtualTree.AccessibleItem <> nil) then - begin - Result := FVirtualTree.AccessibleItem.accLocation(pxLeft, pyTop, pcxWidth, pcyHeight, CHILDID_SELF); - 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; - -//---------------------------------------------------------------------------------------------------------------------- -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 - pvarChild := FVirtualTree.AccessibleItem - else - pvarChild := childid_self; - result := S_OK; - 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 - else if varType(varChild) = VT_I4 then - begin - // return the name for the inner accessible item - if (FVirtualTree <> nil) and (FVirtualTree.AccessibleItem <> nil) then - begin - Result := FVirtualTree.AccessibleItem.Get_accName(CHILDID_SELF, pszName); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeAccessibility.Get_accParent(out ppdispParent: IDispatch): HResult; -// Returns false, the tree itself does not have a parent. -var - hParent: HWND; -begin - Result := E_INVALIDARG; - ppdispParent := nil; - - // Addition - Simon Moscrop 7/5/2009 - if (FVirtualTree.HandleAllocated) then - begin - (* return the accesible object from the 'parent' which is the window of the - tree itself! (This doesn't initially appear correct but it seems to - be exactly what all the other controls do! To verfify try pointing the - ms accessibility explorer at a simple button control which has been dropped - onto a form. - *) - hParent := FVirtualTree.Handle; - RESULT := AccessibleObjectFromWindow(hParent,CHILDID_SELF,IID_IAccessible,pointeR(ppDispParent)); - end; -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 - else if VarType(varChild) = VT_I4 then - begin - // return the role of the inner accessible object - if (FVirtualTree <> nil) and (FVirtualTree.FocusedNode <> nil) then - pvarRole := ROLE_SYSTEM_OUTLINEITEM - else - RESULT := S_FALSE; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeAccessibility.accSelect(flagsSelect: Integer; varChild: OleVariant): HResult; -var - lIndexToSelect: Cardinal; - i: Integer; - lNode: PVirtualNode; -begin - lIndexToSelect := varChild; - if lIndexToSelect >= Self.FVirtualTree.TotalCount then - Exit(E_INVALIDARG); - lNode := FVirtualTree.GetFirst(); - for i := 0 to Integer(lIndexToSelect) - 1 do - lNode := FVirtualTree.GetNext(lNode); - Result := E_NOTIMPL; - if (flagsSelect and SELFLAG_TAKEFOCUS) <> 0then begin - FVirtualTree.FocusedNode := lNode; - Result := S_OK; - end;//if SELFLAG_TAKEFOCUS - if (flagsSelect and SELFLAG_TAKESELECTION) <> 0 then begin - FVirtualTree.ClearSelection(); - FVirtualTree.Selected[lNode] := True; - Result := S_OK; - end;//if SELFLAG_TAKEFOCUS - if (flagsSelect and SELFLAG_ADDSELECTION) <> 0 then begin - FVirtualTree.Selected[lNode] := True; - Result := S_OK; - end; - if (flagsSelect and SELFLAG_REMOVESELECTION) <> 0 then begin - FVirtualTree.Selected[lNode] := False; - Result := S_OK; - end; - if (flagsSelect and SELFLAG_EXTENDSELECTION) <> 0 then begin - THackVirtualStringTree(FVirtualTree).HandleClickSelection(FVirtualTree.FocusedNode, lNode, [ssShift], False); - Result := S_OK; - end; -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 - else if VarType(VarChild) = VT_I4 then - begin - // return the state of the inner accessible item - if (FVirtualTree <> nil) and (FVirtualTree.AccessibleItem <> nil) then - begin - Result := FVirtualTree.AccessibleItem.Get_accState(CHILDID_SELF, pVarState); - 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 - RESULT := S_FALSE; - - pszValue := ''; - if VarType(varChild) = VT_I4 then - if varChild = CHILDID_SELF then - Result := S_FALSE - else if (FVirtualTree <> nil) and (FVirtualTree.AccessibleItem <> nil) then - RESULT := FVirtualTree.AccessibleItem.Get_accValue(CHILDID_SELF,pszValue); -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, FVirtualTree.Header.Columns.GetFirstVisibleColumn, True, False);//Use first visible column instead of -1 - 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; - -//---------------------------------------------------------------------------------------------------------------------- -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_accFocus(out pvarChild: OleVariant): HResult; -begin - // must override this or we get an infinite loop when using MS narrator - // when navigating using the arrow keys. - RESULT := S_FALSE; - if FVirtualTree.FocusedNode <> nil then - begin - pvarChild := CHILDID_SELF; - RESULT := S_OK; - end; -end; - -function TVirtualTreeItemAccessibility.Get_accName(varChild: OleVariant; out pszName: WideString): HResult; -// the name is the node's caption. -var - kind: TVTImageKind; - ImgText: 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 - ImgText := FVirtualTree.ImageText[FVirtualTree.FocusedNode, Kind, FVirtualTree.Header.MainColumn]; - if ImgText <> '' then - pszName := pszName + ImgText + ' '; - 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; - 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; - ImgText: 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 - ImgText := FVirtualTree.ImageText[FVirtualTree.FocusedNode, Kind, FVirtualTree.Header.MainColumn]; - if ImgText <> '' then - ImgText := ImgText + ' '; - end; - pszDescription := ImgText + 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 - ImgText := FVirtualTree.ImageText[FVirtualTree.FocusedNode, Kind, I]; - if ImgText <> '' then - ImgText := ImgText + ' '; - end; - ImgText := ImgText + FVirtualTree.Text[FVirtualTree.FocusedNode, I]; - if ImgText <> '' then - pszDescription := pszDescription - +FVirtualTree.Header.Columns[I].Text - +': ' - + ImgText - +'; '; - 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 - DefaultAccessibleProvider: TVTDefaultAccessibleProvider; - DefaultAccessibleItemProvider: TVTDefaultAccessibleItemProvider; - MultiColumnAccessibleProvider: TVTMultiColumnAccessibleItemProvider; - -initialization - if DefaultAccessibleProvider = nil then - begin - DefaultAccessibleProvider := TVTDefaultAccessibleProvider.Create; - TVTAccessibilityFactory.GetAccessibilityFactory.RegisterAccessibleProvider(DefaultAccessibleProvider); - end; - if DefaultAccessibleItemProvider = nil then - begin - DefaultAccessibleItemProvider := TVTDefaultAccessibleItemProvider.Create; - TVTAccessibilityFactory.GetAccessibilityFactory.RegisterAccessibleProvider(DefaultAccessibleItemProvider); - end; - if MultiColumnAccessibleProvider = nil then - begin - MultiColumnAccessibleProvider := TVTMultiColumnAccessibleItemProvider.Create; - TVTAccessibilityFactory.GetAccessibilityFactory.RegisterAccessibleProvider(MultiColumnAccessibleProvider); - end; -finalization - TVTAccessibilityFactory.GetAccessibilityFactory.UnRegisterAccessibleProvider(MultiColumnAccessibleProvider); - MultiColumnAccessibleProvider := nil; - TVTAccessibilityFactory.GetAccessibilityFactory.UnRegisterAccessibleProvider(DefaultAccessibleItemProvider); - DefaultAccessibleItemProvider := nil; - TVTAccessibilityFactory.GetAccessibilityFactory.UnRegisterAccessibleProvider(DefaultAccessibleProvider); - DefaultAccessibleProvider := nil; - -end. - - - +unit VirtualTrees.Accessibility; + +// This unit implements iAccessible interfaces for the VirtualTree visual components +// and the currently focused node. +// +// Written by Marco Zehe. (c) 2007 + +interface + +uses + Winapi.Windows, System.Classes, Winapi.ActiveX, System.Types, Winapi.oleacc, + VirtualTrees, VirtualTrees.AccessibilityFactory, Vcl.Controls; + +type + TVirtualTreeAccessibility = class(TInterfacedObject, IDispatch, IAccessible) + private + FVirtualTree: TVirtualStringTree; + public + constructor Create(AVirtualTree: TVirtualStringTree); + /// Register the default accessible provider of Virtual TreeView + class procedure RegisterDefaultAccessibleProviders(); + + { 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; + 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; + function Get_accFocus(out pvarChild: OleVariant): HRESULT; stdcall; + end; + + TVTMultiColumnItemAccessibility = class(TVirtualTreeItemAccessibility, IAccessible) + strict 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) + public + function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible; + end; + + TVTDefaultAccessibleItemProvider = class(TInterfacedObject, IVTAccessibleProvider) + public + function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible; + end; + + TVTMultiColumnAccessibleItemProvider = class(TInterfacedObject, IVTAccessibleProvider) + public + function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible; + end; + +implementation + +uses + System.SysUtils, Vcl.Forms, System.Variants, System.Math; + +type + +/// For getting access to protected members of this class +THackVirtualStringTree = class(TVirtualStringTree) +end; + +{ TVirtualTreeAccessibility } +//---------------------------------------------------------------------------------------------------------------------- +constructor TVirtualTreeAccessibility.Create(AVirtualTree: TVirtualStringTree); +// assigns the parent and current fields, and lets the control's IAccessible object know its address. +begin + inherited Create; + FVirtualTree := AVirtualTree; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +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 + else if VarType(varchild) = VT_I4 then + begin + // return the location of the focused node + if (FVirtualTree <> nil) and (FVirtualTree.AccessibleItem <> nil) then + begin + Result := FVirtualTree.AccessibleItem.accLocation(pxLeft, pyTop, pcxWidth, pcyHeight, CHILDID_SELF); + 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; + +//---------------------------------------------------------------------------------------------------------------------- +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 + pvarChild := FVirtualTree.AccessibleItem + else + pvarChild := childid_self; + result := S_OK; + 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 + else if varType(varChild) = VT_I4 then + begin + // return the name for the inner accessible item + if (FVirtualTree <> nil) and (FVirtualTree.AccessibleItem <> nil) then + begin + Result := FVirtualTree.AccessibleItem.Get_accName(CHILDID_SELF, pszName); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- +function TVirtualTreeAccessibility.Get_accParent(out ppdispParent: IDispatch): HResult; +// Returns false, the tree itself does not have a parent. +var + hParent: HWND; +begin + Result := E_INVALIDARG; + ppdispParent := nil; + + // Addition - Simon Moscrop 7/5/2009 + if (FVirtualTree.HandleAllocated) then + begin + (* return the accesible object from the 'parent' which is the window of the + tree itself! (This doesn't initially appear correct but it seems to + be exactly what all the other controls do! To verfify try pointing the + ms accessibility explorer at a simple button control which has been dropped + onto a form. + *) + hParent := FVirtualTree.Handle; + RESULT := AccessibleObjectFromWindow(hParent,CHILDID_SELF,IID_IAccessible,pointeR(ppDispParent)); + end; +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 + else if VarType(varChild) = VT_I4 then + begin + // return the role of the inner accessible object + if (FVirtualTree <> nil) and (FVirtualTree.FocusedNode <> nil) then + pvarRole := ROLE_SYSTEM_OUTLINEITEM + else + RESULT := S_FALSE; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- +function TVirtualTreeAccessibility.accSelect(flagsSelect: Integer; varChild: OleVariant): HResult; +var + lIndexToSelect: Cardinal; + i: Integer; + lNode: PVirtualNode; +begin + lIndexToSelect := varChild; + if lIndexToSelect >= Self.FVirtualTree.TotalCount then + Exit(E_INVALIDARG); + lNode := FVirtualTree.GetFirst(); + for i := 0 to Integer(lIndexToSelect) - 1 do + lNode := FVirtualTree.GetNext(lNode); + Result := E_NOTIMPL; + if (flagsSelect and SELFLAG_TAKEFOCUS) <> 0then begin + FVirtualTree.FocusedNode := lNode; + Result := S_OK; + end;//if SELFLAG_TAKEFOCUS + if (flagsSelect and SELFLAG_TAKESELECTION) <> 0 then begin + FVirtualTree.ClearSelection(); + FVirtualTree.Selected[lNode] := True; + Result := S_OK; + end;//if SELFLAG_TAKEFOCUS + if (flagsSelect and SELFLAG_ADDSELECTION) <> 0 then begin + FVirtualTree.Selected[lNode] := True; + Result := S_OK; + end; + if (flagsSelect and SELFLAG_REMOVESELECTION) <> 0 then begin + FVirtualTree.Selected[lNode] := False; + Result := S_OK; + end; + if (flagsSelect and SELFLAG_EXTENDSELECTION) <> 0 then begin + THackVirtualStringTree(FVirtualTree).HandleClickSelection(FVirtualTree.FocusedNode, lNode, [ssShift], False); + Result := S_OK; + end; +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 + else if VarType(VarChild) = VT_I4 then + begin + // return the state of the inner accessible item + if (FVirtualTree <> nil) and (FVirtualTree.AccessibleItem <> nil) then + begin + Result := FVirtualTree.AccessibleItem.Get_accState(CHILDID_SELF, pVarState); + 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 + RESULT := S_FALSE; + + pszValue := ''; + if VarType(varChild) = VT_I4 then + if varChild = CHILDID_SELF then + Result := S_FALSE + else if (FVirtualTree <> nil) and (FVirtualTree.AccessibleItem <> nil) then + RESULT := FVirtualTree.AccessibleItem.Get_accValue(CHILDID_SELF,pszValue); +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, FVirtualTree.Header.Columns.GetFirstVisibleColumn, True, False);//Use first visible column instead of -1 + 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; + +//---------------------------------------------------------------------------------------------------------------------- +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_accFocus(out pvarChild: OleVariant): HResult; +begin + // must override this or we get an infinite loop when using MS narrator + // when navigating using the arrow keys. + RESULT := S_FALSE; + if FVirtualTree.FocusedNode <> nil then + begin + pvarChild := CHILDID_SELF; + RESULT := S_OK; + end; +end; + +function TVirtualTreeItemAccessibility.Get_accName(varChild: OleVariant; out pszName: WideString): HResult; +// the name is the node's caption. +var + kind: TVTImageKind; + ImgText: 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 + ImgText := FVirtualTree.ImageText[FVirtualTree.FocusedNode, Kind, FVirtualTree.Header.MainColumn]; + if ImgText <> '' then + pszName := pszName + ImgText + ' '; + 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; + 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; + ImgText: 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 + ImgText := FVirtualTree.ImageText[FVirtualTree.FocusedNode, Kind, FVirtualTree.Header.MainColumn]; + if ImgText <> '' then + ImgText := ImgText + ' '; + end; + pszDescription := ImgText + 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 + ImgText := FVirtualTree.ImageText[FVirtualTree.FocusedNode, Kind, I]; + if ImgText <> '' then + ImgText := ImgText + ' '; + end; + ImgText := ImgText + FVirtualTree.Text[FVirtualTree.FocusedNode, I]; + if ImgText <> '' then + pszDescription := pszDescription + +FVirtualTree.Header.Columns[I].Text + +': ' + + ImgText + +'; '; + 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 + DefaultAccessibleProvider: TVTDefaultAccessibleProvider; + DefaultAccessibleItemProvider: TVTDefaultAccessibleItemProvider; + MultiColumnAccessibleProvider: TVTMultiColumnAccessibleItemProvider; + +class procedure TVirtualTreeAccessibility.RegisterDefaultAccessibleProviders(); +begin + if DefaultAccessibleProvider = nil then + begin + DefaultAccessibleProvider := TVTDefaultAccessibleProvider.Create; + TVTAccessibilityFactory.GetAccessibilityFactory.RegisterAccessibleProvider(DefaultAccessibleProvider); + end; + if DefaultAccessibleItemProvider = nil then + begin + DefaultAccessibleItemProvider := TVTDefaultAccessibleItemProvider.Create; + TVTAccessibilityFactory.GetAccessibilityFactory.RegisterAccessibleProvider(DefaultAccessibleItemProvider); + end; + if MultiColumnAccessibleProvider = nil then + begin + MultiColumnAccessibleProvider := TVTMultiColumnAccessibleItemProvider.Create; + TVTAccessibilityFactory.GetAccessibilityFactory.RegisterAccessibleProvider(MultiColumnAccessibleProvider); + end; +end; + + +initialization + TVirtualTreeAccessibility.RegisterDefaultAccessibleProviders(); + +end. + + + diff --git a/components/virtualtreeview/Source/VirtualTrees.StyleHooks.pas b/components/virtualtreeview/Source/VirtualTrees.StyleHooks.pas index 97cf20d5..41b727e8 100644 --- a/components/virtualtreeview/Source/VirtualTrees.StyleHooks.pas +++ b/components/virtualtreeview/Source/VirtualTrees.StyleHooks.pas @@ -93,7 +93,7 @@ type procedure MouseLeave; override; procedure PaintScroll; override; function PointInTreeHeader(const P: TPoint): Boolean; - procedure UpdateScroll; + procedure UpdateScroll;{$if CompilerVersion >= 34}override;{$ifend} public constructor Create(AControl: TWinControl); override; destructor Destroy; override; diff --git a/components/virtualtreeview/Source/VirtualTrees.pas b/components/virtualtreeview/Source/VirtualTrees.pas index c437c791..ca633600 100644 --- a/components/virtualtreeview/Source/VirtualTrees.pas +++ b/components/virtualtreeview/Source/VirtualTrees.pas @@ -1,4 +1,3 @@ - unit VirtualTrees; // The contents of this file are subject to the Mozilla Public License @@ -72,6 +71,7 @@ interface {$HPPEMIT '#pragma comment(lib, "VirtualTreesR")'} {$endif} {$HPPEMIT '#pragma comment(lib, "Shell32")'} +{$HPPEMIT '#pragma link "VirtualTrees.Accessibility"'} uses Winapi.Windows, Winapi.oleacc, Winapi.Messages, System.SysUtils, Vcl.Graphics, @@ -86,7 +86,7 @@ type {$ENDIF} const - VTVersion = '7.3.0'; + VTVersion = '7.4.0' deprecated 'This const is going to be removed in a future version'; const VTTreeStreamVersion = 3; @@ -1048,6 +1048,7 @@ type function GetOwner: TVirtualTreeColumns; reintroduce; procedure ReadHint(Reader: TReader); procedure ReadText(Reader: TReader); + procedure SetCollection(Value: TCollection); override; property HasImage: Boolean read FHasImage; property ImageRect: TRect read FImageRect; public @@ -1355,7 +1356,7 @@ type function DoHeightTracking(var P: TPoint; Shift: TShiftState): Boolean; virtual; function DoHeightDblClickResize(var P: TPoint; Shift: TShiftState): Boolean; virtual; procedure DoSetSortColumn(Value: TColumnIndex; pSortDirection: TSortDirection); virtual; - procedure DragTo(P: TPoint); + procedure DragTo(P: TPoint); virtual; procedure FixedAreaConstraintsChanged(Sender: TObject); function GetColumnsClass: TVirtualTreeColumnsClass; virtual; function GetOwner: TPersistent; override; @@ -2576,7 +2577,7 @@ type procedure DoColumnClick(Column: TColumnIndex; Shift: TShiftState); virtual; procedure DoColumnDblClick(Column: TColumnIndex; Shift: TShiftState); virtual; procedure DoColumnResize(Column: TColumnIndex); virtual; - procedure DoColumnVisibilityChanged(const Column: TColumnIndex; Visible: Boolean); + procedure DoColumnVisibilityChanged(const Column: TColumnIndex; Visible: Boolean); virtual; function DoCompare(Node1, Node2: PVirtualNode; Column: TColumnIndex): Integer; virtual; function DoCreateDataObject: IDataObject; virtual; function DoCreateDragManager: IVTDragManager; virtual; @@ -3005,7 +3006,7 @@ type procedure CopyToClipboard; virtual; procedure CutToClipboard; virtual; procedure DeleteChildren(Node: PVirtualNode; ResetHasChildren: Boolean = False); - procedure DeleteNode(Node: PVirtualNode); overload; inline; + procedure DeleteNode(Node: PVirtualNode; pReIndex: Boolean = True); overload; inline; procedure DeleteNodes(const pNodes: TNodeArray); procedure DeleteSelectedNodes; virtual; function Dragging: Boolean; @@ -3371,6 +3372,7 @@ type Column: TColumnIndex; CellText: string; StaticText: string; + StaticTextAlignment: TAlignment; ExportType: TVTExportType; constructor Create(pNode: PVirtualNode; pColumn: TColumnIndex; pExportType: TVTExportType = TVTExportType.etNone); end; @@ -3414,7 +3416,7 @@ type FPreviouslySelected: TStringList; procedure InitializeTextProperties(var PaintInfo: TVTPaintInfo); // [IPK] - private to protected procedure PaintNormalText(var PaintInfo: TVTPaintInfo; TextOutFlags: Integer; Text: string); virtual; // [IPK] - private to protected - procedure PaintStaticText(const PaintInfo: TVTPaintInfo; TextOutFlags: Integer; const Text: string); virtual; // [IPK] - private to protected + procedure PaintStaticText(const PaintInfo: TVTPaintInfo; pStaticTextAlignment: TAlignment; const Text: string); virtual; // [IPK] - private to protected procedure AdjustPaintCellRect(var PaintInfo: TVTPaintInfo; var NextNonEmpty: TColumnIndex); override; function CanExportNode(Node: PVirtualNode): Boolean; function CalculateStaticTextWidth(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const Text: string): Integer; virtual; @@ -6436,9 +6438,16 @@ begin inherited Create(Collection); - FWidth := Owner.FDefaultWidth; - FLastWidth := Owner.FDefaultWidth; - FPosition := Owner.Count - 1; + if Assigned(Owner) then begin + FWidth := Owner.FDefaultWidth; + FLastWidth := Owner.FDefaultWidth; + FPosition := Owner.Count - 1; + end; +end; + +procedure TVirtualTreeColumn.SetCollection(Value: TCollection); +begin + inherited; // Read parent bidi mode and color values as default values. ParentBiDiModeChanged; ParentColorChanged; @@ -8282,12 +8291,21 @@ end; //---------------------------------------------------------------------------------------------------------------------- procedure TVirtualTreeColumns.Notify(Item: TCollectionItem; Action: System.Classes.TCollectionNotification); - +var + I: Integer; begin if Action in [cnExtracting, cnDeleting] then + begin + // Adjust all positions larger than the deleted column's position. Fixes #959 + for I := 0 to Count - 1 do begin + if Items[I].Position > TVirtualTreeColumn(Item).Position then + Items[I].Position := Items[I].Position - 1; + end;//for I + with Header.Treeview do if not (csLoading in ComponentState) and (FFocusedColumn = Item.Index) then FFocusedColumn := NoColumn; + end;// if cnDeleting end; //---------------------------------------------------------------------------------------------------------------------- @@ -10320,7 +10338,7 @@ begin begin NewWidth := FTrackPoint.X - XPos; NextColumn := FColumns.GetPreviousVisibleColumn(FColumns.FTrackIndex); - end + end else begin NewWidth := XPos - FTrackPoint.X; @@ -11832,12 +11850,14 @@ begin Result := StyleServices.GetSystemColor(FColors[Index]); cBorderColor: if (seBorder in FOwner.StyleElements) then - Result := StyleServices.GetSystemColor(FColors[Index]); + Result := StyleServices.GetSystemColor(FColors[Index]) + else + Result := FColors[Index]; cHotColor: if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemHot), ecTextColor, Result) then Result := StyleServices.GetSystemColor(FColors[Index]); cHeaderHotColor: - if not StyleServices.GetElementColor(StyleServices.GetElementDetails(thHeaderItemNormal), ecTextColor, Result) then + if not StyleServices.GetElementColor(StyleServices.GetElementDetails(thHeaderItemHot), ecTextColor, Result) then Result := StyleServices.GetSystemColor(FColors[Index]); cSelectionTextColor: if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemSelected), ecTextColor, Result) then @@ -20689,10 +20709,11 @@ begin begin if DeltaX <> 0 then begin + UpdateHorizontalScrollBar(suoRepaintScrollBars in Options); if (suoRepaintHeader in Options) and (hoVisible in FHeader.FOptions) then FHeader.Invalidate(nil); if not (tsSizing in FStates) and (FScrollBarOptions.ScrollBars in [System.UITypes.TScrollStyle.ssHorizontal, System.UITypes.TScrollStyle.ssBoth]) then - UpdateHorizontalScrollBar(suoRepaintScrollBars in Options); + UpdateVerticalScrollBar(suoRepaintScrollBars in Options); end; if (DeltaY <> 0) and ([tsThumbTracking, tsSizing] * FStates = []) then @@ -20923,7 +20944,7 @@ end; //---------------------------------------------------------------------------------------------------------------------- -function TBaseVirtualTree.DoValidateCache: Boolean; +function TBaseVirtualTree.DoValidateCache(): Boolean; // This method fills the cache, which is used to speed up searching for nodes. // The strategy is simple: Take the current number of visible nodes and distribute evenly a number of marks @@ -20980,14 +21001,14 @@ begin while not (tsStopValidation in FStates) do begin // If the cache is full then stop the loop. - if (Integer(Index) > Length(FPositionCache)) then // ADDED: 17.09.2013 - Veit Zimmermann - Break; // ADDED: 17.09.2013 - Veit Zimmermann + if (Integer(Index) >= Length(FPositionCache)) then + Break; if (EntryCount mod CacheThreshold) = 0 then begin // New cache entry to set up. with FPositionCache[Index] do begin - Node := CurrentNode; // 2 EAccessViolation seen here in TreeSize V4.3.1 (Write of address 00000000) + Node := CurrentNode; // 2 EAccessViolation seen here in TreeSize V4.3.1, 1 in V4.4.0 (Write of address 00000000) AbsoluteTop := CurrentTop; end; Inc(Index); @@ -21504,10 +21525,14 @@ begin begin if (SelectedCount = 0) and not SelectionLocked then begin - if Assigned(FNextNodeToSelect) then - Selected[FNextNodeToSelect] := True - else - Selected[GetFirstVisible] := True; + if not Assigned(FNextNodeToSelect) then + begin + FNextNodeToSelect := GetFirstVisible; + // Avoid selecting a disabled node, see #954 + while Assigned(FNextNodeToSelect) and IsDisabled[FNextNodeToSelect] do + FNextNodeToSelect := GetNextVisible(FNextNodeToSelect); + end; + Selected[FNextNodeToSelect] := True; Self.ScrollIntoView(Self.GetFirstSelected, False); end;// if nothing selected EnsureNodeFocused(); @@ -22524,7 +22549,7 @@ begin NewCheckState := DetermineNextCheckState(HitInfo.HitNode.CheckType, HitInfo.HitNode.CheckState); if (ssLeft in KeysToShiftState(Message.Keys)) and DoChecking(HitInfo.HitNode, NewCheckState) then begin - if (Self.SelectedCount > 1) and (Selected[HitInfo.HitNode]) then + if (Self.SelectedCount > 1) and (Selected[HitInfo.HitNode]) and not (toSyncCheckboxesWithSelection in TreeOptions.SelectionOptions) then SetCheckStateForAll(NewCheckState, True) else DoCheckClick(HitInfo.HitNode, NewCheckState); @@ -22830,7 +22855,7 @@ begin // Fix: Any parent check state must be propagated here. // Because the CheckType is normally set in DoInitNode // by the App. - if Node.CheckType in [ctTriStateCheckBox] then + if (Node.CheckType = ctTriStateCheckBox) and (toAutoTristateTracking in FOptions.FAutoOptions) then begin ParentCheckState := Self.GetCheckState(Node.Parent); SelfCheckState := Self.GetCheckState(Node); @@ -22841,7 +22866,9 @@ begin and (Parent <> FRoot) then SetCheckState(Node, Node.Parent.CheckState); - end; + end + else if (toSyncCheckboxesWithSelection in TreeOptions.SelectionOptions) then + Node.CheckType := TCheckType.ctCheckBox; if ivsDisabled in InitStates then Include(States, vsDisabled); @@ -23117,11 +23144,11 @@ end; //---------------------------------------------------------------------------------------------------------------------- -procedure TBaseVirtualTree.InternalClearSelection; +procedure TBaseVirtualTree.InternalClearSelection(); var Count: Integer; - + lNode: PVirtualNode; begin // It is possible that there are invalid node references in the selection array // if the tree update is locked and changes in the structure were made. @@ -23139,11 +23166,12 @@ begin while FSelectionCount > 0 do begin Dec(FSelectionCount); + lNode := FSelection[FSelectionCount]; //sync path note: deselect when click on another or on outside area - Exclude(FSelection[FSelectionCount].States, vsSelected); - if SyncCheckstateWithSelection[FSelection[FSelectionCount]] then - checkstate[FSelection[FSelectionCount]] := csUncheckedNormal; - DoRemoveFromSelection(FSelection[FSelectionCount]); + Exclude(lNode.States, vsSelected); + if SyncCheckstateWithSelection[lNode] then + CheckState[lNode] := csUncheckedNormal; + DoRemoveFromSelection(lNode); end; ResetRangeAnchor; FSelection := nil; @@ -23399,7 +23427,7 @@ begin //sync path note: deselect when overlapping drawselection is made Exclude(Node.States, vsSelected); if SyncCheckstateWithSelection[Node] then - checkstate[Node] := csUncheckedNormal; + Node.CheckState := csUncheckedNormal; // Avoid using SetCheckState() as it handles toSyncCheckboxesWithSelection as well. Inc(PAnsiChar(FSelection[Index])); DoRemoveFromSelection(Node); AdviseChangeEvent(False, Node, crIgnore); @@ -24625,7 +24653,7 @@ begin //sync path note: deselect when a ctrl click removes a selection Exclude(Node.States, vsSelected); if SyncCheckstateWithSelection[Node] then - checkstate[Node] := csUncheckedNormal; + Node.CheckState := csUncheckedNormal; // Avoid using SetCheckState() as it handles toSyncCheckboxesWithSelection as well. if FindNodeInSelection(Node, Index, -1, -1) and (Index < FSelectionCount - 1) then Move(FSelection[Index + 1], FSelection[Index], (FSelectionCount - Index - 1) * SizeOf(Pointer)); @@ -25305,7 +25333,7 @@ end; //---------------------------------------------------------------------------------------------------------------------- -procedure TBaseVirtualTree.UpdateHeaderRect; +procedure TBaseVirtualTree.UpdateHeaderRect(); // Calculates the rectangle the header occupies in non-client area. // These coordinates are in window rectangle. @@ -25320,8 +25348,10 @@ begin FHeaderRect := Rect(0, 0, Width, Height); // Consider borders... - Size := GetBorderDimensions; - InflateRect(FHeaderRect, Size.cx, Size.cy); + if HandleAllocated then begin // Prevent preliminary creation of window handle, see issue #933 + Size := GetBorderDimensions(); + InflateRect(FHeaderRect, Size.cx, Size.cy); + end; // ... and bevels. OffsetX := BorderWidth; @@ -26519,9 +26549,9 @@ begin end; end; -procedure TBaseVirtualTree.DeleteNode(Node: PVirtualNode); +procedure TBaseVirtualTree.DeleteNode(Node: PVirtualNode; pReIndex: Boolean = True); begin - DeleteNode(Node, True, False); + DeleteNode(Node, pReIndex, False); end; //---------------------------------------------------------------------------------------------------------------------- @@ -30855,7 +30885,7 @@ begin NodeBitmap.Free; end;//try..finally - if (ChildCount[nil] = 0) and (FEmptyListMessage <> '') then + if (FEmptyListMessage <> '') and ((ChildCount[nil] = 0) or (GetFirstVisible = nil)) then begin // output a message if no items are to display Canvas.Font := Self.Font; @@ -30865,7 +30895,7 @@ begin R.Right := R.Left + Width - 2; R.Bottom := Height -2; TargetCanvas.Font.Color := clGrayText; - TargetCanvas.TextRect(R, FEmptyListMessage, [tfNoClip, tfLeft, tfWordBreak]); + TargetCanvas.TextRect(R, FEmptyListMessage, [tfNoClip, tfLeft, tfWordBreak, tfExpandTabs]); end; DoAfterPaint(TargetCanvas); @@ -32013,7 +32043,15 @@ var begin Window := Handle; DC := GetDC(Handle); - Self.Brush.Color := FColors.BackGroundColor; + + if (toShowBackground in FOptions.FPaintOptions) and Assigned(FBackground.Graphic) then + Self.Brush.Style := bsClear + else + begin + Self.Brush.Style := bsSolid; + Self.Brush.Color := FColors.BackGroundColor; + end; + Brush := Self.Brush.Handle; if (Mode1 <> tamNoScroll) and (Mode2 <> tamNoScroll) then @@ -32947,8 +32985,8 @@ begin // check NextNode, otherwise we got AV if NextNode <> nil then begin - // Continue editing next node - ClearSelection; + // Continue editing next node + Tree.ClearSelection(); Tree.Selected[NextNode] := True; if Tree.CanEdit(Tree.FocusedNode, Tree.FocusedColumn) then Tree.DoEdit; @@ -33576,8 +33614,7 @@ end; //---------------------------------------------------------------------------------------------------------------------- -procedure TCustomVirtualStringTree.PaintStaticText(const PaintInfo: TVTPaintInfo; TextOutFlags: Integer; - const Text: string); +procedure TCustomVirtualStringTree.PaintStaticText(const PaintInfo: TVTPaintInfo; pStaticTextAlignment: TAlignment; const Text: string); // This method retrives and draws the static text bound to a particular node. @@ -33617,12 +33654,17 @@ begin Canvas.Font.Color := FColors.DisabledColor; R := ContentRect; - if Alignment = taRightJustify then begin - Dec(R.Right, NodeWidth + FTextMargin); - DrawFormat := DrawFormat or DT_RIGHT + if pStaticTextAlignment = taRightJustify then begin + DrawFormat := DrawFormat or DT_RIGHT; + Dec(R.Right, FTextMargin); + if PaintInfo.Alignment = taRightJustify then + Dec(R.Right, NodeWidth); // room for node text end - else - Inc(R.Left, NodeWidth + FTextMargin); + else begin + Inc(R.Left, FTextMargin); + if PaintInfo.Alignment = taRightJustify then + Inc(R.Left, NodeWidth); // room for node text + end; if Canvas.TextFlags and ETO_OPAQUE = 0 then SetBkMode(Canvas.Handle, TRANSPARENT) @@ -34018,6 +34060,7 @@ begin lEventArgs := TVSTGetCellTextEventArgs.Create(PaintInfo.Node, PaintInfo.Column); lEventArgs.CellText := FDefaultText; + lEventArgs.StaticTextAlignment := PaintInfo.Alignment; DoGetText(lEventArgs); // Paint the normal text first... @@ -34026,7 +34069,7 @@ begin // ... and afterwards the static text if not centered and the node is not multiline enabled. if (Alignment <> taCenter) and not (vsMultiline in PaintInfo.Node.States) and (toShowStaticText in TreeOptions.FStringOptions) and not lEventArgs.StaticText.IsEmpty then - PaintStaticText(PaintInfo, TextOutFlags, lEventArgs.StaticText); + PaintStaticText(PaintInfo, lEventArgs.StaticTextAlignment, lEventArgs.StaticText); finally RestoreFontChangeEvent(PaintInfo.Canvas); end;