treeintf.pas

是 delphi6的函数库

    Result := Item.GetNamePath;
end;

function TSprig.Name: string;
begin
  Result := UniqueName;
end;

procedure TSprig.PrepareMenu(const AItems: IMenuItems);
begin
  //
end;

function TSprig.SeekParent(AItem: TPersistent; Recurse: Boolean): TSprig;
begin
  Result := nil;
  if AItem <> nil then
  begin
    if (Parent <> nil) and
       (Parent.Item = AItem) then
      Result := Parent
      
    else if Owner <> nil then
      Result := Owner.Find(AItem, Recurse);

    if Result = nil then
    begin
      if Root <> nil then
        Result := Root.Find(AItem, Recurse);
      if Result = nil then
        Result := Root;
    end;
  end
  else
    Result := Root;
end;

function TSprig.SeekParent(const AName: string; Recurse: Boolean): TSprig;
begin
  Result := nil;
  if AName <> '' then
  begin
    if (Parent <> nil) and
       AnsiSameText(Parent.Name, AName) then
      Result := Parent

    else if Owner <> nil then
      Result := Owner.Find(AName, Recurse);

    if Result = nil then
    begin
      if Root <> nil then
        Result := Root.Find(AName, Recurse);
      if Result = nil then
        Result := Root;
    end;
  end
  else
    Result := Root;
end;

function TSprig.SeekParent(const AName: string; AClass: TClass;
  Recurse: Boolean): TSprig;
begin
  Result := Root;
  if (AName <> '') and
     (AClass <> nil) then
  begin
    if (Parent <> nil) and
       (Parent.Item <> nil) and
       (Parent.Item is AClass) and
       AnsiSameText(Parent.Name, AName) then
      Result := Parent

    else if Owner <> nil then
      Result := Owner.Find(AName, AClass, Recurse);

    if Result = nil then
    begin
      if Root <> nil then
        Result := Root.Find(AName, AClass, Recurse);
      if Result = nil then
        Result := Root;
    end;
  end
  else
    Result := Root;
end;

function TSprig.Transient: Boolean;
begin
  Result := False;
end;

type
  THackTreeView = class(TCustomTreeView)
  end;

function TSprig.TreeNodeFor(ATreeView: TCustomTreeView): TTreeNode;
var
  LParent: TTreeNode;
begin
  if TreeNode = nil then
  begin
    EnsureUpdate;
    LParent := nil;
    if Parent <> nil then
      LParent := Parent.TreeNode;
    FTreeNode := THackTreeView(ATreeView).Items.AddNode(
      TSprigTreeNode.Create(THackTreeView(ATreeView).Items),
      LParent, Caption, Self, naAddChild);
    //FTreeNode := THackTreeView(ATreeView).Items.AddChildObject(LParent, Caption, Self);
  end;
  Result := TreeNode;
end;

procedure TSprig.VisualRefresh;
  function Trimmed(const AText: string): string;
  begin
    if Length(AText) >= 80 then
      Result := Copy(AText, 1, 76) + '... ' { Do not localize }
    else
      Result := AText;
  end;
begin
  if TreeNode <> nil then
    with TreeNode do
    begin
      if Self.FCaption <> Self.Caption then
        Self.FCaption := Trimmed(Self.Caption);
      Text := Self.FCaption;
      ImageIndex := Self.ImageIndex;
      SelectedIndex := Self.ImageIndex;
      StateIndex := Self.StateIndex;
      //HasChildren := Self.Count > 0;
    end;
end;

function TSprig.CaptionFor(const AName, ALabel, AClass: string): string;
begin
  Result := AName;
  if ALabel <> '' then
  begin
    if Result = '' then
      Result := '<?>'; // DO NOT LOCALIZE
    Result := Format('%s {%s}', [Result, ALabel]); // DO NOT LOCALIZE
  end;
  if GShowClassNameInTreeView then
  begin
    if AClass = '' then
      Result := Format('%s (%s)', [Result, AClass]) // DO NOT LOCALIZE
    else if Item <> nil then
      Result := Format('%s (%s)', [Result, Item.ClassName]); // DO NOT LOCALIZE
  end;
end;

function TSprig.PaletteOver(ASprigClass: TSprigClass; AClass: TClass): Boolean;
begin
  Result := False;
  if ASprigClass <> nil then
    Result := ASprigClass.PaletteOverTo(Self, AClass);
end;

class function TSprig.PaletteOverTo(AParent: TSprig; AClass: TClass): Boolean;
var
  LProp: PPropInfo;
begin
  Result := False;
  if ParentProperty <> '' then
  begin
    LProp := GetPropInfo(AClass.ClassInfo, ParentProperty, [tkClass]);
    if LProp <> nil then
      Result := (AParent is TRootSprig) or
                (AParent.Item is GetTypeData(LProp^.PropType^)^.ClassType);
  end;
end;

function TSprig.Path: string;
begin
  Result := UniqueName;
  if Parent <> nil then
    Result := Format('%s\%s', [Parent.Path, Result]); // DO NOT LOCALIZE
end;

function TSprig.DeleteStyle: TSprigDeleteStyle;
const
  cDeleteStyle: array [Boolean] of TSprigDeleteStyle = (dsAbort, dsNormal);
begin
  Result := cDeleteStyle[Item <> nil];
end;

function TSprig.CustomDelete: Boolean;
begin
  Result := False;
end;

function TSprig.ItemClass: TClass;
begin
  Result := nil;
  if Item <> nil then
    Result := Item.ClassType;
end;

class function TSprig.ParentProperty: string;
begin
  Result := '';
end;

procedure TSprig.FigureParent;
var
  LProp: PPropInfo;
  LParentItem: TPersistent;
begin
  // assume nowhere!
  LParentItem := nil;

  // if we actually point to something
  if Item <> nil then
  begin

    // parent property based?
    if ParentProperty <> '' then
    begin
      LProp := GetPropInfo(Item, ParentProperty, [tkClass]);
      if LProp <> nil then
        LParentItem := TPersistent(GetObjectProp(Item, LProp, TPersistent));
    end;

    // still nothing but we have a component
    if (LParentItem = nil) and
       (Item is TComponent) then
      LParentItem := TComponent(Item).GetParentComponent;
  end;

  // plug in!
  if LParentItem <> nil then
    SeekParent(LParentItem).Add(Self)
  else if Owner <> nil then
    Owner.Add(Self)
  else
    Root.Add(Self);
end;

procedure TSprig.FigureChildren;
var
  LProps: TPropList;
  LProp: TObject;
  LPropCount, I: Integer;
  LParent: TSprig;
  LParentClass: TSprigClass;
begin
  // something to do?
  if (Item <> nil) and not FCollectionsDone then
  begin
    FCollectionsDone := True;

    // grab the list of properties
    LPropCount := GetPropList(Item.ClassInfo, [tkClass], @LProps);

    // we need to make this a optimized as possible
    for I := 0 to LPropCount - 1 do
    begin

      // got a collection?
      LProp := TObject(GetOrdProp(Item, LProps[I]));
      if (LProp is TCollection) and
         (GetUltimateOwner(TCollection(LProp)) <> nil) then
      begin

        // does it exists already?
        LParent := Find(TCollection(LProp), False);
        if LParent = nil then
        begin
          LParentClass := FindBestSprigClass(TCollection(LProp).ClassType, TCollectionSprig);
          if LParentClass <> nil then
          begin
            LParent := LParentClass.Create(TCollection(LProp));
            TCollectionSprig(LParent).FPropName := LProps[I].Name;
            TCollectionSprig(LParent).FOwner := Self;

            // made some additions
            Add(LParent);
          end;
        end;
      end;
    end;
  end;
end;

function TSprig.FocusItem: TPersistent;
begin
  Result := Item;
  if (Result = nil) and
     (Parent <> nil) then
    Result := Parent.FocusItem;
end;

function SortBySprigItemIndex(Node1, Node2: TTreeNode; lParam: Integer): Integer; stdcall;
begin
  Result := TSprig(Node1.Data).ItemIndex -
            TSprig(Node2.Data).ItemIndex;
end;

procedure TSprig.SortItems;
begin
  if (TreeNode <> nil) and
     (TreeNode.HasChildren) then
    if SortByIndex then
      TreeNode.CustomSort(@SortBySprigItemIndex, 0)
    else
      TreeNode.CustomSort(nil, 0);
end;

function TSprig.SortByIndex: Boolean;
begin
  Result := False;
end;

function TSprig.ItemIndex: Integer;
begin
  Result := 0;
end;

procedure TSprig.Reparent;
begin
  // we don't care
end;

function TSprig.ShowRegisteredMenus: Boolean;
begin
  Result := Item <> nil;
end;

procedure TSprig.ReparentChildren;
var
  I: Integer;
begin
  for I := Count - 1 downto 0 do
    Items[I].Reparent;
end;

function TSprig.IncludeIndexInCaption: Boolean;
begin
  Result := False;
end;

procedure TSprig.SetExpanded(const Value: Boolean);
begin
  if FExpanded <> Value then
  begin
    FExpanded := Value;
    if Expanded and
       (Parent <> nil) then
      Parent.Expanded := True;
  end;
end;

procedure TSprig.Invalidate;
var
  I: Integer;
begin
  if not Invalid then
  begin
    FInvalid := True;

    // remove ourselve from the root index
    if Root <> nil then
      Root.RemoveItem(Self);

    // don't point there anymore
    FItem := nil;
    for I := Count - 1 downto 0 do
      Items[I].Invalidate;
  end;
end;

procedure TSprig.SelectItems(const AItems: array of TPersistent; ARuntimeChange: Boolean);
begin
  if Root <> nil then
    Root.SelectItems(AItems, ARuntimeChange);
end;

function TSprig.Parents(ASprig: TSprig): Boolean;
begin
  repeat
    Result := ASprig = Self;
    ASprig := ASprig.Parent;
  until (Result = True) or
        (ASprig = nil);
end;

procedure TSprig.DesigntimeChange;
begin
  if Root <> nil then
    Root.DesigntimeChange;
end;

procedure TSprig.RuntimeChange;
begin
  if Root <> nil then
    Root.RuntimeChange;
end;

function TSprig.GetDesigner(out ADesigner: IDesigner): Boolean;
begin
  if Root <> nil then
    Result := Root.GetDesigner(ADesigner)
  else
    Result := False;
end;

function TSprig.GetImageIndex: TImageIndex;
begin
  Result := FImageIndex;
  if Ghosted then
    Inc(Result, CGhostedOffset);
end;

procedure TSprig.SetImageIndex(const Value: TImageIndex);
begin
  FImageIndex := Value;
end;

function TSprig.GetStateIndex: TImageIndex;
const
  CStateIndex: array [Boolean] of TImageIndex = (CNoStateImage, CCheckOutStateImage);
begin
  Result := CStateIndex[AnyProblems];
end;

function TSprig.Construct(AClass: TComponentClass): TComponent;
var
  LDesigner: IDesigner;
  LParent: TPersistent;
begin
  Result := nil;
  if (Item <> nil) and
     (Item is TComponent) then
    LParent := Item
  else if Owner <> nil then
    LParent := Owner.Item
  else
    LParent := Root.Item;
  if (LParent is TComponent) and
     GetDesigner(LDesigner) then
    Result := LDesigner.CreateComponent(AClass, TComponent(LParent), 0, 0, 0, 0);
end;

procedure TSprig.BeginUpdate;
begin
  if Root <> nil then
    Root.BeginUpdate;
end;

procedure TSprig.EndUpdate;
begin
  if Root <> nil then
    Root.EndUpdate;
end;

procedure TSprig.EnsureUpdate;
begin
  if Root <> nil then
    Root.EnsureUpdate;
end;

function TSprig.Hidden: Boolean;
var
  LDesigner: IDesigner;
begin
  if not FHiddenTested and
     GetDesigner(LDesigner) then
  begin
    FHiddenTested := True;
    FHidden := not (Item is TComponent) or
               LDesigner.IsComponentHidden(TComponent(Item));
  end;
  Result := FHidden;
end;

function TSprig.Ghosted: Boolean;
begin
  Result := Hidden;
end;

function TSprig.CanMove(AUp: Boolean): Boolean;
var
  LSibling: TSprig;
begin
  Result := Assigned(Parent) and Parent.SortByIndex and
            Assigned(TreeNode) and Assigned(TreeNode.Parent);
  if Result then
  begin
    LSibling := nil;
    if AUp and (TreeNode.Index > 0) then
      LSibling := TSprig(TreeNode.Parent.Item[TreeNode.Index - 1].Data)
    else if not AUp and (TreeNode.Index < TreeNode.Parent.Count - 1) then
      LSibling := TSprig(TreeNode.Parent.Item[TreeNode.Index + 1].Data);
    Result := Assigned(LSibling) and LSibling.DragOver(Self)
  end;
end;

function TSprig.Move(AUp: Boolean): Boolean;
var
  LSibling: TSprig;
begin
  BeginUpdate;
  try
    if AUp then
      LSibling := TSprig(TreeNode.Parent.Item[TreeNode.Index - 1].Data)
    else
      LSibling := TSprig(TreeNode.Parent.Item[TreeNode.Index + 1].Data);
    Result := LSibling.DragDrop(Self);
    if Result then
      SelectItems([Item]);
  finally
    EndUpdate;