Автор: Валентин
WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> TreeView - компонент для показа dataset в виде дерева с сохранением

Цель создания: необходимость быстрого выбора товара из справочника в виде дерева.
Компонент для визуализации дерева из таблицы. привязка к полям не ведется.
Ключевое поле находится в node.stateindex.

Использует 4 иконки для узлов и позиций, где 0-невыбранный узел,
1- выбранный узел, 2- невыбранный пункт, 3- выбранный пункт.

Необходимо выбрать datasource. вписать id, parentid.
Заполнение методом MRRefresh.
Сохранение в файл методом
MRPSaveToFile(ProgPath+'NameTree.tree').
Загрузка из файла соответственно MRPLoadFromFile(ProgPath+'NameTree.tree').
Кроме того поддерживаются метода последовательно поиска в обоих направлениях.

Зависимости: Windows, Messages, SysUtils, Classes, Controls, ComCtrls,DB,DBCtrls
Автор:       Валентин, visor123@ukr.net, Днепропетровск
Copyright:   Собственная разработка.
Дата:        9 апреля 2003 г.
***************************************************** }

unit GRTreeView;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, ComCtrls, DB, DBCtrls,
  Dialogs;

type
  TMRGroupRec = record
    ID, MasterID, Level: integer;
    MainName: string;
  end;
  TMRGroup = class(TPersistent)
  private
    fCount: integer;
  protected
    procedure SetCount(value: integer);
  public
    items: array of TMRGroupRec;
    property Count: integer read fCount write SetCount;
    constructor Create;
    destructor destroy; override;
    procedure Clear;
    procedure Add(AID, AMasterID: integer; AMainName: string);
    function GetIndexByMasterID(AMasterID: integer): integer;
  end;
  TGRTreeView = class(TTreeView)
  private
    { Private declarations }
    fDataSource: TDataLink;
    fFeyField: TFieldDataLink;
    fMasterFeyField: TFieldDataLink;
    fNameField: TFieldDataLink;
    // fRootName:string;
    fSeparator: Char;
    fLock: Boolean;
    fSearchIndex: integer;
    function GetBufStart(Buffer: PChar; var Level: Integer): PChar;
  protected
    { Protected declarations }
    function GetDataSource: TDataSource;
    procedure SetDataSource(value: TDataSource);
    function GetKeyField: string;
    procedure SetKeyField(value: string);
    function GetMasterKeyField: string;
    procedure SetMasterKeyField(value: string);
    function GetNameField: string;
    procedure SetNameField(value: string);
    procedure SetSeparator(value: char);
    procedure GetImageIndex(Node: TTreeNode); override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor destroy; override;
    function MRRefresh: Boolean;
    procedure MRPLoadFromFile(const FileName: string); overload;
    procedure MRPLoadFromFile(const FileName: string; RootName: string);
      overload;
    procedure MRPLoadFromStream(Stream: TStream);
    procedure MRPSaveToFile(const FileName: string);
    procedure MRPSaveToStream(Stream: TStream);
    function MRGetIndexByText(AText: string): integer;
    function MRGetIndexByMasterID(MasterID: integer): integer;
    function MRGetIndexByMasterIDRecurse(MasterID: integer): integer;
    function MRSearchByText(AText: string; Next: Boolean = True; UseSearchIndex:
      Boolean = false): integer;
  published
    { Published declarations }
    property Separator: char read fSeparator write SetSeparator;
    property DataSource: TDataSource read GetDataSource write SetDataSource;
    property KeyField: string read GetKeyField write SetKeyField;
    property MasterField: string read GetMasterKeyField write SetMasterKeyField;
    property NameField: string read GetNameField write SetNameField;
  end;

procedure Register;

implementation
//var
// MGRGroup:array of TMRGroup;

procedure Register;
begin
  RegisterComponents('Visor', [TGRTreeView]);
end;

{ TGRTreeView }

constructor TGRTreeView.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  fDataSource := TDataLink.Create;
  fFeyField := TFieldDataLink.Create;
  fFeyField.Control := self;
  fMasterFeyField := TFieldDataLink.Create;
  fMasterFeyField.Control := self;
  fNameField := TFieldDataLink.Create;
  fNameField.Control := self;
  fSeparator := '^';
  fLock := false;
  HideSelection := false;
  fSearchIndex := -1;
end;

destructor TGRTreeView.destroy;
begin
  fNameField.Free;
  fNameField := nil;
  fFeyField.Free;
  fFeyField := nil;
  fDataSource.Free;
  fDataSource := nil;
  inherited;
end;

function TGRTreeView.GetBufStart(Buffer: PChar; var Level: Integer): PChar;
begin
  Level := 0;
  while Buffer^ in [' ', #9] do
  begin
    Inc(Buffer);
    Inc(Level);
  end;
  Result := Buffer;
end;

function TGRTreeView.GetDataSource: TDataSource;
begin
  Result := fDataSource.DataSource;
end;

procedure TGRTreeView.MRPLoadFromFile(const FileName: string);
var
  Stream: TStream;
  FNT, FNR, Ex: string;
begin
  if not FileExists(FileName) then
    Exit;
  Ex := ExtractFileExt(FileName);
  if Ex = '' then
  begin
    FNT := ExtractFileName(FileName) + '.tree';
    FNR := ExtractFileName(FileName) + '.ini';
  end
  else
  begin
    FNT := ExtractFileName(FileName);
    FNT := Copy(FNT, 0, pos('.', FNT) - 1);
    FNR := FNT + '.ini';
    FNT := FNT + '.tree';
  end;
  FNT := ExtractFilePath(FileName) + FNT;
  FNR := ExtractFilePath(FileName) + FNR;
  Stream := TFileStream.Create(FNT, fmOpenRead);
  try
    MRPLoadFromStream(Stream);
  finally
    Stream.Free;
  end;
end;

function TGRTreeView.MRGetIndexByText(AText: string): integer;
var
  i: integer;
begin
  if Items.Count = 0 then
  begin
    Result := -1;
    Exit;
  end;
  for i := 0 to Items.Count - 1 do
  begin
    if Items.Item[i].Text = AText then
    begin
      Result := i;
      Exit;
    end;
  end;
  Result := -1;
end;

procedure TGRTreeView.MRPLoadFromFile(const FileName: string;
  RootName: string);
var
  FNT, FNR, Ex: string;
  ANode: TTreeNode;
begin
  if not FileExists(FileName) then
    Exit;
  Ex := ExtractFileExt(FileName);
  if Ex = '' then
  begin
    FNT := ExtractFileName(FileName) + '.tree';
    FNR := ExtractFileName(FileName) + '.ini';
  end
  else
  begin
    FNT := ExtractFileName(FileName);
    FNT := Copy(FNT, 0, pos('.', FNT) - 1);
    FNR := FNT + '.ini';
    FNT := FNT + '.tree';
  end;
  FNT := ExtractFilePath(FileName) + FNT;
  FNR := ExtractFilePath(FileName) + FNR;
  if (not FileExists(FNT)) or (not FileExists(FNR)) then
  begin
    ANode := Items.Add(nil, RootName);
    ANode.StateIndex := 0;
    Self.MRPSaveToFile(FileName);
  end
  else
  begin
    MRPLoadFromFile(FileName);
  end;
end;

procedure TGRTreeView.MRPLoadFromStream(Stream: TStream);
var
  List: TStringList;
  ANode, NextNode: TTreeNode;
  ALevel, i, AStateIndex: Integer;
  CurrStr, Buff: string;
begin
  Items.Clear;
  List := TStringList.Create;
  Items.BeginUpdate;
  try
    try
      List.Clear;
      List.LoadFromStream(Stream);
      ANode := nil;
      for i := 0 to List.Count - 1 do
      begin
        CurrStr := GetBufStart(PChar(List[i]), ALevel);
        AStateIndex := -1;
        if pos(fSeparator, CurrStr) > 0 then
        begin
          Buff := Copy(CurrStr, pos(fSeparator, CurrStr) + 1, length(CurrStr) -
            pos(fSeparator, CurrStr));
          if Buff <> '' then
            AStateIndex := StrToInt(Buff);
          // Delete(CurrStr,pos(CurrStr,fSeparator),length(CurrStr)-pos(CurrStr,fSeparator)-1);
          buff := Copy(CurrStr, 0, pos(fSeparator, CurrStr) - 1);
          CurrStr := Buff;
        end;
        if ANode = nil then
        begin
          ANode := Items.AddChild(nil, CurrStr);
          if AStateIndex <> -1 then
            ANode.StateIndex := AStateIndex;
        end
        else if ANode.Level = ALevel then
        begin
          ANode := Items.AddChild(ANode.Parent, CurrStr);
          if AStateIndex <> -1 then
            ANode.StateIndex := AStateIndex;
        end
        else if ANode.Level = (ALevel - 1) then
        begin
          ANode := Items.AddChild(ANode, CurrStr);
          if AStateIndex <> -1 then
            ANode.StateIndex := AStateIndex;
        end
        else if ANode.Level > ALevel then
        begin
          NextNode := ANode.Parent;
          while NextNode.Level > ALevel do
            NextNode := NextNode.Parent;
          ANode := Items.AddChild(NextNode.Parent, CurrStr);
          if AStateIndex <> -1 then
            ANode.StateIndex := AStateIndex;
        end;
        // else TreeViewErrorFmt(sInvalidLevelEx, [ALevel, CurrStr]);
      end;
    finally
      Items.EndUpdate;
      List.Free;
    end;
  except
    Items.Owner.Invalidate; // force repaint on exception see VCL
    raise;
  end;
  if Items.Count > 0 then
    Items.Item[0].Expand(false);
end;

procedure TGRTreeView.MRPSaveToFile(const FileName: string);
var
  Stream: TStream;
  FNT, FNR, Ex: string;
begin
  Ex := ExtractFileExt(FileName);
  if Ex = '' then
  begin
    FNT := ExtractFileName(FileName) + '.tree';
    FNR := ExtractFileName(FileName) + '.ini';
  end
  else
  begin
    FNT := ExtractFileName(FileName);
    FNT := Copy(FNT, 0, pos('.', FNT) - 1);
    FNR := FNT + '.ini';
    FNT := FNT + '.tree';
  end;
  FNT := ExtractFilePath(FileName) + FNT;
  FNR := ExtractFilePath(FileName) + FNR;
  Stream := TFileStream.Create(FNT, fmCreate);
  try
    flock := True;
    MRPSaveToStream(Stream);
  finally
    Stream.Free;
    flock := false;
  end;
end;

procedure TGRTreeView.MRPSaveToStream(Stream: TStream);
const
  TabChar = #9;
  EndOfLine = #13#10;
var
i: Integer;
  ANode: TTreeNode;
  NodeStr: string;
begin
  if Items.Count > 0 then
  begin
    ANode := Items.Item[0];
    while ANode <> nil do
    begin
      NodeStr := '';
      for i := 0 to ANode.Level - 1 do
        NodeStr := NodeStr + TabChar;
      NodeStr := NodeStr + ANode.Text + fSeparator + IntToStr(ANode.StateIndex)
        + EndOfLine;
      Stream.Write(Pointer(NodeStr)^, Length(NodeStr));
      ANode := ANode.GetNext;
    end;
  end;
end;

function TGRTreeView.MRRefresh: boolean;
var
  i: integer;
  ANode, NextNode: TTreeNode;
  MGroup: TMRGroup;
begin
  if (fDataSource.DataSet = nil) or (KeyField = '') or (MasterField = '') or
    (NameField = '') then
  begin
    Result := false;
    Exit;
  end;
  if not fDataSource.DataSet.Active then
    fDataSource.DataSet.Open
  else
  begin
    fDataSource.DataSet.Close;
    fDataSource.DataSet.Open;
  end;

  fDataSource.DataSet.DisableControls;
  MGroup := TMRGroup.Create;
  MGroup.Clear;
  try
    while not fDataSource.DataSet.Eof do
    begin
      MGroup.Add(DataSource.DataSet.FieldByName(KeyField).AsInteger,
        DataSource.DataSet.FieldByName(MasterField).AsInteger,
        DataSource.DataSet.FieldByName(NameField).AsString);
      fDataSource.DataSet.Next;
    end;
    items.Clear;
    Items.BeginUpdate;
    fLock := True;
    ANode := nil;
    for i := 0 to MGroup.Count - 1 do
    begin
      if ANode = nil then
      begin
        ANode := Items.AddChild(nil, MGroup.Items[i].MainName);
        ANode.StateIndex := MGroup.items[i].ID;
      end
      else if ANode.Level = (MGroup.items[i].Level) then
      begin
        ANode := items.AddChild(ANode.Parent, MGroup.items[i].MainName);
        ANode.StateIndex := MGroup.items[i].ID;
      end
      else if ANode.Level = (MGroup.items[i].Level - 1) then
      begin
        ANode := Items.AddChild(ANode, MGroup.items[i].MainName);
        ANode.StateIndex := MGroup.items[i].ID;
      end
      else if ANode.Level > MGroup.items[i].Level then
      begin
        NextNode := ANode.Parent;
        while NextNode.Level > MGroup.items[i].Level do
          NextNode := NextNode.Parent;
        ANode := Items.AddChild(NextNode.Parent, MGroup.items[i].MainName);
        ANode.StateIndex := MGroup.items[i].ID;
      end;
      { else if ANode.Level > MGroup.items[i].Level then
              begin
                NextNode := ANode.Parent;
                while NextNode.Level > MGroup.items[i].Level do
                  NextNode := NextNode.Parent;
                ANode := Items.AddChild(NextNode.Parent, MGroup.items[i].MainName);
                ANode.StateIndex:=MGroup.items[i].ID;
              end;}
    end;
  finally
    fDataSource.DataSet.First;
    fDataSource.DataSet.EnableControls;
    //ShowMessage('Tree count='+IntToStr(Items.Count)+' MGroup count='+IntToStr(MGroup.Count));
    MGroup.Free;
    fLock := false;
  end;
  Items.EndUpdate;
  if Items.Count > 0 then
    Items.Item[0].Expand(false);
  Result := True;
end;

procedure TGRTreeView.SetDataSource(value: TDataSource);
begin
  fDataSource.DataSource := value;
end;

function TGRTreeView.MRGetIndexByMasterID(MasterID: integer): integer;
var
  i: integer;
begin
  if Items.Count = 0 then
  begin
    Result := -1;
    exit;
  end;
  for i := 0 to Items.Count - 1 do
  begin
    if Items.Item[i].StateIndex = MasterID then
    begin
      Result := i;
      Exit;
    end;
  end;
  Result := -1;
end;

function TGRTreeView.GetKeyField: string;
begin
  Result := fFeyField.FieldName;
end;

function TGRTreeView.GetMasterKeyField: string;
begin
  Result := fMasterFeyField.FieldName;
end;

function TGRTreeView.GetNameField: string;
begin
  Result := fNameField.FieldName;
end;

procedure TGRTreeView.SetKeyField(value: string);
begin
  fFeyField.FieldName := value;
end;

procedure TGRTreeView.SetMasterKeyField(value: string);
begin
  fMasterFeyField.FieldName := value;
end;

procedure TGRTreeView.SetNameField(value: string);
begin
  fNameField.FieldName := value;
end;

procedure TGRTreeView.SetSeparator(value: char);
begin
  fSeparator := value;
end;

procedure TGRTreeView.GetImageIndex(Node: TTreeNode);
begin
  if fLock then
    Exit;
  inherited;
  if Node.getFirstChild <> nil then
  begin
    Node.ImageIndex := 0;
    Node.SelectedIndex := 1;
  end
  else
  begin
    Node.ImageIndex := 2;
    Node.SelectedIndex := 3;
  end;
end;

function TGRTreeView.MRGetIndexByMasterIDRecurse(
  MasterID: integer): integer;
var
  i: integer;
begin
  if Items.Count = 0 then
  begin
    Result := -1;
    exit;
  end;
  for i := Items.Count - 1 downto 0 do
  begin
    if Items.Item[i].StateIndex = MasterID then
    begin
      Result := i;
      Exit;
    end;
  end;
  Result := -1;
end;

function TGRTreeView.MRSearchByText(AText: string; Next: Boolean = True;
  UseSearchIndex: Boolean = false): integer;
var
  i, iStart, iEnd: integer;
  sel: TList;
  f: boolean;
begin
  if Items.Count = 0 then
  begin
    Result := -1;
    fSearchIndex := -1;
    Exit;
  end;
  if Next then
  begin
    if (UseSearchIndex) and (fSearchIndex <> -1) then
      iStart := fSearchIndex + 1
    else
      iStart := 0;
    iEnd := Items.Count - 1;
  end
  else
  begin
    if (UseSearchIndex) and (fSearchIndex <> -1) then
      iStart := fSearchIndex - 1
    else
      iStart := Items.Count - 1;
    iEnd := 0;
  end;
  i := iStart;
  f := true;
  repeat
    if pos(AnsiUpperCase(AText), AnsiUpperCase(Items.Item[i].Text)) > 0 then
    begin
      Result := i;
      fSearchIndex := i;
      sel := TList.Create;
      sel.Add(Items.Item[i]);
      Select(Sel);
      sel.Free;
      Exit;
    end;
    if Next then
    begin
      inc(i);
      if i > iEnd then
        f := false;
    end
    else
    begin
      dec(i);
      if i < iEnd then
        f := false;
    end;
  until f <> true;
  Result := -1;
  fSearchIndex := -1;
end;

{ TMRGroup }

procedure TMRGroup.Add(AID, AMasterID: integer; AMainName: string);
var
  idx: integer;
begin
  inc(fCount);
  SetLength(items, fCount);
  items[fCount - 1].ID := AID;
  items[fCount - 1].MasterID := AMasterID;
  items[fCount - 1].MainName := AMainName;
  idx := GetIndexByMasterID(AMasterID);
  if idx = -1 then
  begin
    items[idx].Level := 0;
  end
  else
  begin
    items[fCount - 1].Level := items[idx].Level + 1;
  end;
end;

procedure TMRGroup.Clear;
begin
  items := nil;
  fCount := 0;
end;

constructor TMRGroup.Create;
begin
  inherited;
  fCount := 0;
end;

destructor TMRGroup.destroy;
begin
  items := nil;
  inherited;
end;

function TMRGroup.GetIndexByMasterID(AMasterID: integer): integer;
var
  i: integer;
begin
  if (fCount = 0) then
  begin
    Result := -1;
    Exit;
  end;
  for i := 0 to fCount - 1 do
  begin
    if items[i].ID = AMasterID then
    begin
      Result := i;
      Exit;
    end;
  end;
  Result := -1;
end;

procedure TMRGroup.SetCount(value: integer);
begin
  fCount := value;
end;

end.