Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым

TTreeView – компонент для показа dataset в виде дерева с сохранением

01.01.2007
{ **** 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.