treeintf.pas

是 delphi6的函数库

  procedure MakeExpanded(ANode: TTreeNode);
  begin
    if ANode <> nil then
    begin
      if not ANode.Expanded then
        ANode.Expanded := True;
      MakeExpanded(ANode.Parent);
    end;
  end;
begin
  if AItem.TreeNode <> nil then
  begin
    {if FExpandedItems.Count > 0 then
    begin
      I := FExpandedItems.IndexOf(AItem.Path);
      if I >= 0 then
      begin
        FExpandedItems.Delete(I);
        AItem.Expanded := True;
      end;
    end;}
    if AItem.Expanded or
       (AItem = Self) then
      MakeExpanded(AItem.TreeNode);
  end;
end;

procedure TRootSprig.StoreExpandState(AItem: TSprig);
begin
  with AItem do
    Expanded := (TreeNode <> nil) and
                (TreeNode.Expanded) and
                (TreeNode.IsVisible);
end;

procedure TRootSprig.StoreTreeState;
begin
  if TreeView <> nil then
    ForEach(StoreExpandState);
end;

procedure TRootSprig.DepopulateTreeView(AItem: TSprig);
begin
  with AItem do
  begin
    Expanded := (TreeNode <> nil) and
                (TreeNode.Expanded) and
                (TreeNode.IsVisible);
    ClearTreeNode;
  end;
end;

procedure TRootSprig.RefreshTreeView;
begin
  BeginUpdate;
  if RepopulateNeeded then
    Repopulate;
  if TreeView <> nil then
    ForEach(PreRefreshTreeView, PostRefreshTreeView);
  EndUpdate;
end;

function TRootSprig.GetDesigner(out ADesigner: IDesigner): Boolean;
begin
  ADesigner := Designer;
  Result := ADesigner <> nil;
end;

procedure TRootSprig.ItemDeleted(AItem: TPersistent);
var
  LSprig: TSprig;
begin
  LSprig := Find(AItem);
  if (LSprig <> nil) and
     (LSprig <> Self) and
     (not LSprig.Invalid) then
  begin
    LSprig.Invalidate;
    FRepopulateNeeded := True;
  end;
end;

procedure TRootSprig.ItemInserted;
begin
  FRepopulateNeeded := True;
end;

procedure TRootSprig.ItemsModified(AForceRepopulate: Boolean);
begin
  if AForceRepopulate then
    FRepopulateNeeded := True;
  if SprigDesigner <> nil then
  begin
    SprigDesigner.BeforeItemsModified;
    try
      RefreshTreeView;
    finally
      SprigDesigner.AfterItemsModified;
    end;
  end;
end;

function TRootSprig.AcceptsClass(AClass: TClass): Boolean;
begin
  Result := AClass.InheritsFrom(TComponent);
end;

procedure TRootSprig.BeginUpdate;
begin
  Inc(FUpdateLocks);
end;

procedure TRootSprig.EndUpdate;
begin
  if FUpdateLocks > 0 then
  begin
    Dec(FUpdateLocks);
    if (FUpdateLocks = 0) and (FNeedUpdate) then
    begin
      if TreeView <> nil then
        THackTreeView(TreeView).Items.EndUpdate;
      FNeedUpdate := False;
    end;
  end;
end;

procedure TRootSprig.EnsureUpdate;
begin
  if (FUpdateLocks > 0) and (not FNeedUpdate) then
  begin
    if TreeView <> nil then
      THackTreeView(TreeView).Items.BeginUpdate;
    FNeedUpdate := True;
  end;
end;

procedure TRootSprig.SetSprigDesigner(const ASprigDesigner: ISprigDesigner);
var
  LSprigDesigner: ISprigDesigner;
begin
  if SprigDesigner <> nil then
  begin
    Assert(FUpdateLocks = 0);
    ForEach(nil, DepopulateTreeView);
    LSprigDesigner := SprigDesigner;
    FSprigDesigner := nil;
    LSprigDesigner.RootSprig := nil;
    //LSprigDesigner.Collection := nil;
  end;
  FSprigDesigner := ASprigDesigner;
  FUpdateLocks := 0;
  FNeedUpdate := False;
  if SprigDesigner <> nil then
    RefreshTreeView;
end;

function TRootSprig.TreeView: TCustomTreeView;
begin
  Result := nil;
  if SprigDesigner <> nil then
    Result := SprigDesigner.GetTreeView;
end;

{ TSprigType }

constructor TSprigType.Create(const AClass: TClass; const ASprigClass: TSprigClass);
begin
  inherited Create;
  FClass := AClass;
  FSprigClass := ASprigClass;
  FGroup := CurrentGroup;
end;

function TSprigType.Score(const AClass: TClass): Integer;
begin
  Result := High(Integer);
  if AClass.InheritsFrom(FClass) then
    Result := CountGenerations(FClass, AClass);
end;

{ TSprigIntfType }

constructor TSprigIntfType.Create(const AInterfaces: TGUIDArray;
  const ASprigClass: TSprigClass);
begin
  inherited Create;
  FInterfaces := AInterfaces;
  FSprigClass := ASprigClass;
  FGroup := CurrentGroup;
end;

function TSprigIntfType.Match(const AClass: TClass): Boolean;
var
  I: Integer;
begin
  for I := 0 to Length(FInterfaces) - 1 do
    if not Supports(AClass, FInterfaces[I]) then
    begin
      Result := False;
      Exit;
    end;
  Result := True;
end;

{ TSprigTypeList }

procedure TSprigTypeList.Add(const AClass: TClass; const ASprigClass: TSprigClass);
begin
  FList.Insert(0, TSprigType.Create(AClass, ASprigClass));
end;

procedure TSprigTypeList.Add(const AInterfaces: TGUIDArray;
  const ASprigClass: TSprigClass);
begin
  FInterfaceList.Insert(0, TSprigIntfType.Create(AInterfaces, ASprigClass));
end;

procedure TSprigTypeList.ClearCache;
begin
  FLastClass := nil;
  FLastSprigClass := nil;
end;

constructor TSprigTypeList.Create;
begin
  inherited;
  FList := TObjectList.Create;
  FInterfaceList := TObjectList.Create;
end;

destructor TSprigTypeList.Destroy;
begin
  FList.Free;
  FInterfaceList.Free;
  inherited;
end;

procedure TSprigTypeList.FreeEditorGroup(AGroup: Integer);
var
  I: Integer;
begin
  ClearCache;
  for I := FList.Count - 1 downto 0 do
    if TSprigType(FList[I]).FGroup = AGroup then
      FList.Delete(I);
  for I := FInterfaceList.Count - 1 downto 0 do
    if TSprigIntfType(FInterfaceList[I]).FGroup = AGroup then
      FInterfaceList.Delete(I);
end;

function TSprigTypeList.Match(const AClass: TClass): TSprigClass;
begin
  Result := MatchCache(AClass);
  if Result = nil then
    Result := MatchClass(AClass);
end;

function TSprigTypeList.MatchCache(const AClass: TClass): TSprigClass;
begin
  Result := nil;
  if FLastClass = AClass then
    Result := FLastSprigClass;
end;

function TSprigTypeList.MatchClass(const AClass: TClass): TSprigClass;
var
  I, LBestScore, LScore: Integer;
begin
  Result := nil;
  for I := 0 to FInterfaceList.Count - 1 do
    if TSprigIntfType(FInterfaceList[I]).Match(AClass) then
    begin
      Result := TSprigIntfType(FInterfaceList[I]).SprigClass;
      Break;
    end;
  if Result = nil then
  begin
    LBestScore := High(Integer);
    for I := 0 to FList.Count - 1 do
    begin
      LScore := TSprigType(FList[I]).Score(AClass);
      if LScore < LBestScore then
      begin
        LBestScore := LScore;
        Result := TSprigType(FList[I]).SprigClass;
      end;
    end;
  end;
  if Result <> nil then
  begin
    FLastClass := AClass;
    FLastSprigClass := Result;
  end;
end;

{ TDragSprig }

procedure TDragSprigs.Add(ASprig: TSprig);
begin
  FSprigs.Add(ASprig);
end;

constructor TDragSprigs.Create(AControl: TControl);
begin
  inherited Create(AControl);
  FSprigs := TList.Create;
end;

destructor TDragSprigs.Destroy;
begin
  FSprigs.Free;
  inherited;
end;

function TDragSprigs.GetSprig(Index: Integer): TSprig;
begin
  Result := TSprig(FSprigs[Index]);
end;

function TDragSprigs.Count: Integer;
begin
  Result := FSprigs.Count;
end;

{ TPropertySprig }

function TPropertySprig.DeleteStyle: TSprigDeleteStyle;
begin
  Result := dsAbort;
end;

function TPropertySprig.Ghosted: Boolean;
begin
  Result := False;
end;

{ TCollectionSprig }

function TCollectionSprig.DeleteStyle: TSprigDeleteStyle;
begin
  Result := dsCustom;
end;

function TCollectionSprig.CustomDelete: Boolean;
begin
  Result := TCollection(Item).Count > 0;
  if Result then
    TCollection(Item).Clear;
end;

function TCollectionSprig.Caption: string;
begin
  Result := CaptionFor(FPropName);
end;

procedure TCollectionSprig.FigureParent;
begin
  SeekParent(FOwner.Item);
end;

function TCollectionSprig.SortByIndex: Boolean;
begin
  Result := True;
end;

function TCollectionSprig.Name: string;
begin
  Result := Format(CCollectionName, [FPropName]);
end;

constructor TCollectionSprig.Create(AItem: TPersistent);
begin
  inherited;
  ImageIndex := CCollectionSprigImage;
end;

procedure TCollectionSprig.AddType(Index: Integer);
begin
  SelectItems([TCollection(Item).Add]);
end;

function TCollectionSprig.AddTypeCount: Integer;
begin
  Result := 1;
end;

resourcestring
  sAddCaption = 'Add item';

function TCollectionSprig.GetAddType(Index: Integer): string;
begin
  case Index of
    0: Result := sAddCaption;
  end;
end;

function TCollectionSprig.Owner: TSprig;
begin
  Result := FOwner;
end;

procedure TCollectionSprig.FigureChildren;
var
  I: Integer;
  LChildItem: TCollectionItem;
  LChild: TSprig;
  LChildClass: TSprigClass;
begin
  // let it go first
  inherited;

  // now lets loop through the component items
  for I := 0 to TCollection(Item).Count - 1 do
  begin

    // find the best class
    LChildItem := TCollection(Item).Items[I];
    LChild := Find(LChildItem, False);

    // if not then create it
    if LChild = nil then
    begin
      LChildClass := FindBestSprigClass(LChildItem.ClassType, TCollectionItemSprig);
      if LChildClass <> nil then
      begin
        LChild := LChildClass.Create(LChildItem);
        TCollectionItemSprig(LChild).FOwner := Self;

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

{ TCollectionItemSprig }

procedure TCollectionItemSprig.FigureParent;
begin
  SeekParent(FOwner.Item);
end;

function TCollectionItemSprig.Name: string;
begin
  Result := TCollectionItem(Item).DisplayName;
end;

function TCollectionItemSprig.ItemIndex: Integer;
begin
  Result := TCollectionItem(Item).Index;
end;

function TCollectionItemSprig.DragDropTo(AParent: TSprig): Boolean;
var
  LOrigIndex: Integer;
begin
  LOrigIndex := ItemIndex;
  if AParent.Parent = Parent then
    TCollectionItem(Item).Index := TCollectionItem(AParent.Item).Index;
  Result := LOrigIndex <> ItemIndex;
end;

function TCollectionItemSprig.DragOverTo(AParent: TSprig): Boolean;
begin
  Result := AParent.Parent = Parent;
end;

function TCollectionItemSprig.IncludeIndexInCaption: Boolean;
begin
  Result := True;
end;

procedure TCollectionItemSprig.AddType(Index: Integer);
begin
  Parent.AddType(Index);
end;

function TCollectionItemSprig.AddTypeCount: Integer;
begin
  Result := Parent.AddTypeCount;
end;

function TCollectionItemSprig.GetAddType(Index: Integer): string;
begin
  Result := Parent.AddTypes[Index];
end;

function TCollectionItemSprig.Owner: TSprig;
begin
  Result := FOwner;
end;

function TCollectionItemSprig.Ghosted: Boolean;
begin
  Result := False;
end;

{ TSprigIndex }

procedure TSprigIndex.Add(ASprig: TSprig);
var
  I, L: Integer;
begin
  L := WordRec(LongRec(ASprig.Item).Lo).Hi; // grab xxxxLLxx byte
  if FList[L] = nil then
    FList[L] := TList.Create;
  for I := 0 to TList(FList[L]).Count - 1 do
    if TList(FList[L]).Items[I] = ASprig then
      Assert(False);
  TList(FList[L]).Add(ASprig);
end;

constructor TSprigIndex.Create;
begin
  inherited;
  FList :