Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
TreeView - компонент для показа dataset в виде дерева с сохранением

Автор: Валентин
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.
Проект Delphi World © Выпуск 2002 - 2024
Автор проекта: USU Software
Вы можете выкупить этот проект.