这种treeview 如何实现？ (100分)

我有二个数据库，结构如下：

编号 名称 编号 名称 上级编号
p1 aaa f1 a1 p1
p2 bbb f2 a2 f1
p3 ccc f3 a3 f2
... f4 a4 f3
f5 a5 p1
f6 a6 f1
f7 a7 f2
f8 a8 f3
f9 a9 f6
...
需要生成的treeview 如下：

|- p1_aaa -----|- f1_a1 ---|- f2_a2
| | |- f6_a6 ----f7_a7
| |- f5_a5
|
|- p2_bbb
|
|- p3_ccc

请教各位高手，如何实现？

其实你的两张表可以和到一张表中
Oracle SQLServer 有这样的例子,(例如:雇员表)
可以这样建表

MeID Name FatherID
1 a Null
2 b 1
3 c 1
4 d 2
5 e 3
实现是这样:
数据集先要按 FatherID,MeID 排序.
然后循环此数据集
var
NewNode:TNode;
FatherNode:TNode;
begin
do while not eof
if FatherID is null then 增加第一个节点;
else
先获取 FatherNode
增加子节点;
Next;
end;

如何获取 FatherNode ?
循环 已经加载的节点 如果节点的 MeID = NewNode.FatherID

-------------------------------------------
这是个比较低效率的算法,后面的朋友会告诉你一些高效的算法.

再增加一个字段，就象双链表那样来完成。

可不可以先增加根目录，在增加下一级子目录（全部),然后在该全部子目录中循环，
增加下一级子目录...

是否可行，如何实现？

这些都在数据不太多的情况下有效，但是多了就不起什么好的作用了
我有原码可以给你一个

expect说得对，你的两个表可以合为一个表的
在每次TreeNode的Change中查找当前节点的子节点
即查询所有上级编号为当前TreeNode中所存记录的编号的数据
然后用AddChildObject方法加到当前节点下
这样虽然与数据库的交互次数会很多（每次节点加子节点时）
但速度还是很快的！

仅供参考：
//FLevels是树中节点相关的数据表、主键、显示字段等信息
//如果UseSingleTable 则表明树是从单一表中构造的，即通过“编号”=“上级编号”这种形式关连上下级
procedure TDBTreeView.Change(Node: TTreeNode);
var
IsEnd: Boolean;
begin
if csLoading in ComponentState then Exit;
Items.BeginUpdate;
try
inherited Change(Node);
if not Node.HasChildren then
ExpandChildren(Node);
if UseSingleTable then
IsEnd := not Node.HasChildren
else
IsEnd := (Node.Level = FLevels.Count) and (Node.Level <> 0);

DoChangeNode(Self, Node, IsEnd, GetFilterStr(Node));
finally
Items.EndUpdate;
end;
end;

procedure TDBTreeNav.ExpandChildren(CurNode: TTreeNode);
var
P: PStoreID;
NodeText, TableName, SQLText: string;
begin
if FLevels.Count = 0 then Exit; { No level ,eg: Project Table }

if FOracleQuery <> nil then
with FOracleQuery do
begin
Clear;
SQLText := GetSQLText(CurNode);
if SQLText = '' then Exit;
SQL.Text := SQLText;
Execute;
while not Eof do
begin
New(P);
P^.Id := FieldAsInteger(0);
NodeText := FieldAsString(1);
if NodeText = '' then NodeText := NullCharForTreeView;
if UseSingleTable then
TableName := FLevels[0].TableName
else
begin
if CurNode.Level <= 1 then //第一级是纯文字描述
TableName := FLevels[0].TableName
else
TableName := FLevels[CurNode.Level - 1].TableName
end;
if CanAddValue(TableName, NodeText) then
Self.Items.AddChildObject(CurNode, NodeText, P);
Next;
end;
CurNode.Expand(False);
end;
end;

大美虫,请发 mail : yam3368@21cn.com 多谢

大美虫：
可否也给我一个，谢谢。
sujian@elong.com

我现在在用这个，不过感觉不是很好，请have a look.

unit treefunc;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, ComCtrls, DB, Forms, Dialogs;

function TreeFindItem(Sender: TTreeView; NodeItem: TTreeNode; Name: String): TTreeNode;
function TreeAddItem(Sender: TTreeView; ItemList: TStrings; Bookmark: TBookmark; Resort: Boolean): TTreeNode;
function TreeGetItem(Sender: TTreeView; ItemList: TStrings): TTreeNode;
procedure TreeDeleteItem(Sender: TTreeView; ItemList: TStrings; Level: Integer);

implementation


function TreeAddItem(Sender: TTreeView; ItemList: TStrings; Bookmark: TBookmark; Resort: Boolean): TTreeNode;
var
ThisNode, Node: TTreeNode;
I: Integer;
begin
Node := nil; //nil = level 0 has no parent node
//this is checked by TreeFindItem
for I := 0 to Itemlist.count -1 do
begin
ThisNode := TreeFindItem(Sender, node, Itemlist);
if ThisNode <> nil then Node := ThisNode else
begin
if I < Itemlist.count -1 then
begin
if I = 0 then Node := Sender.items.Add(Node, Itemlist)
else Node := Sender.items.AddChild(Node, Itemlist);
end else
begin
if I = 0 then Node := Sender.items.AddObject(Node, Itemlist, Bookmark)
else Node := Sender.items.AddChildObject(Node, Itemlist, Bookmark);
end;
Node.stateIndex := Node.level + 1;
if Resort and (Node.parent <> nil) then Node.parent.alphasort;
end;
end;
Result := Node;
end;

function TreeFindItem(Sender: TTreeView; NodeItem: TTreeNode; Name: String): TTreeNode;
begin
if NodeItem = nil then NodeItem := Sender.items.getfirstnode
else NodeItem := NodeItem.getfirstchild;
//NodeItem is now the first item of the desired level
//if this level has no items, NodeItem is nil

if (NodeItem <> nil) and (NodeItem.text <> Name) then
repeat
NodeItem := NodeItem.getnextsibling;
until (NodeItem = nil) or (NodeItem.text = Name);
Result := NodeItem;
end;

function TreeGetItem(Sender: TTreeView; ItemList: TStrings): TTreeNode;
begin
Result := TreeAddItem(Sender, Itemlist, nil, false);
end;

procedure TreeDeleteItem(Sender: TTreeView; ItemList: TStrings; Level: Integer);
var
Node, Parent: TTreeNode;
begin
Node := TreeGetItem(Sender, ItemList);
while Node.level >= Level do
begin
Parent := Node.parent;
Node.delete;
if (Parent = nil) or (Parent.hasChildren) then break;
Node := Parent;
end;
end;


end.

在treeview单元中：
function TKnowForm.GetFieldList: TStringList;
begin
FieldList.clear;
FieldList.add('第'+IntToStr(STrToInt(DataModule1.KnowTable.fieldbyname('zjbh').asstring) Div 100)+'章 '+DataModule1.KnowTable.fieldbyname('zbt').asstring);
FieldList.add('第'+IntToStr(STrToInt(DataModule1.KnowTable.fieldbyname('zjbh').asstring) Mod 100)+'节 '+DataModule1.KnowTable.fieldbyname('jbt').asstring);
FieldList.add(DataModule1.KnowTable.fieldbyname('zsdmc').AsString+'('+DataModule1.KnowTable.fieldbyname('zsdbh').asstring+')');
Result := FieldList;
end;


procedure TknowForm.TreeView1Change(Sender: TObject; Node: TTreeNode);
begin
DataModule1.KnowDataSource.enabled := Node.data <> nil;
if DataModule1.KnowDataSource.enabled then
DataModule1.KnowTable.gotobookmark(node.data);
end;

请各位大虾帮忙looking。

实际上一次建完也很好的。设置一下显示器的属性。
先在后台将数据展开，着是一个很标准的BOM结构啊（不过还没BOM复杂）

各路英雄有礼了！
再下对此问题有独道的见解，请各路英雄看过来！
其实不但不用建两个表，在一个表里也无需设父结点和子结点两个字段，只要将结点代号
按一定规律实行编码，建树时再按这个编码规律从表中恢复成树。

暂以PARADOX表为例：
BookDirs.db
Code (Key Index Field) Name
A000 社会科学类 // 后三位是000为根结点
A100 哲学 // 后二位是00为二级结点
A101 马克主义原理
A200 历史
B000 自然科学类

生成的TreeView为：
－A000 社会科学类 //在节点上加入结点编码是为了以后判断点击节点时方便
-A100 哲学
-A101 马克主义原理
-A200 历史
-B000 自然科学类

生成树的代码为：

procedure TAMdept.GenTree();
var gc,gc1,gc2:string;
nd,ndc:TTreenode;
begin
TreeView.items.Clear;
with BookDirs do
begin
indexname:='Code';
first;
while not eof do
begin
gc:=copy(FieldByName('Code').AsString,2,3);
gc1:=copy(FieldByName('Code').AsString,2,1);
gc2:=copy(FieldByName('Code').AsString,3,2);
if gc='000' then nd:=TreeView.items.add(nil,FieldByName('Code').AsString+' '+FieldByName('Name').AsString)
else if (gc1<>'0') and (gc2='00') then ndc:=TreeView.items.addchild(nd,FieldByName('Code').AsString+' '+FieldByName('Name').AsString)
else TreeView.items.addchild(ndc,FieldByName('Code').AsString+' '+FieldByName('Name').AsString);
Next;
end;
end;
end;


多级树生成也可以此为例，主要是结点代码的编码规律问题。

to：Blueman

准备将编码做几个字节呢？如果事先根本不知道级数，不会用5000个字节吧

我的问题已经解决，以上大虾的方法给了我一些提示，但都不是最简单的方法

查找以前delphibbs 贴子，发现对这个问题，曹晓刚大虾的方法很实用，用此法
一解决我的问题

方法如下：

type pInt = ^integer;

procedure TForm1.Button1Click(Sender: TObject);
var ParentNode,Node : TTreeNode;
id : pInt;
begin
table.open;
table.first;
while not table.eof do
begin
//使用Node.data域来存放id,以用于find;
ParentNode:=FindNodeByID(T1,table.FieldByName('PARENT').asInteger);
new(id);
id^:=table.FieldByName('ID').asInteger;
Node:=T1.items.AddChildObject(ParentNode,table.FieldByName('NAME').asString,id);
table.Next;
end;
table.close;
end;

Function TForm1.FindNodeByID(T:TTreeView; id:integer):TTreeNode;
var i:integer;
begin
result:=nil;
for i:=0 to T.Items.Count-1 do
if integer(T.Items.Data^)=id
then begin
result := T.Items;
exit;
end;
end;

要注意在free TreeView之前要把items.data^先释放掉。不然就会有内存泄漏。

我是自己申请了内存来存放id的。
在你用完了这个Treeview,比如在窗口关闭时，要先dispose它。
procedure Tform1.FormClose;
var i:integer;
begin
for i:=0 to T1.items.count-1 do
begin
dispose(T1.items.data);
T1.items.data:=nil;
end;
end;

各位大虾，看看这个方法是不是最简单，还有没有更好的？

treeview的数据库其实只定义level和caption就可, 只是数据的顺序不能乱

treeview的数据库其实只定义level和caption就可, 只是数据的顺序不能乱
我正在编一个程序， 就需用这个问题， 有意可来信索取。zjrpost@263.net

我也编了一个差不多的程序。
表结构如下：
　lbcode varchar(10) 　类别代码
lbname varchar(40)
lbparent varchar(10) 上级类别代码

lbcode lbname lbparent
A001 类别的说明 NULL
A002 A001
A003 A001
A004 NUll 表示无上级

生成 A001 - A002
|- A003
A004

本人反对用代码的结构来区分上下级 如：A001-1 ,A001-2
用单独的colume 类进行分级定义更好。

源代码如下：
unit u_leibie;// 2001.06.22

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ComCtrls, ToolWin, ImgList, Db, Grids, DBGrids, ExtCtrls, DBCtrls,ADODB, DBTables,
Menus, StdCtrls, Buttons, Mask;

type
TF_LeiBie = class(TForm)
ToolBar1: TToolBar;
ToolButton1: TToolButton;
ToolButton2: TToolButton;
DataSource: TDataSource;
StatusBar1: TStatusBar;
PageControl1: TPageControl;
Panel1: TPanel;
TabSheet1: TTabSheet;
TabSheet2: TTabSheet;
DBGrid2: TDBGrid;
GroupBox1: TGroupBox;
TreeView: TTreeView;
GBox2: TGroupBox;
Panel2: TPanel;
DBNavigator1: TDBNavigator;
Label1: TLabel;
DBEdit1: TDBEdit;
Label2: TLabel;
DBEdit2: TDBEdit;
Label3: TLabel;
DBEdit3: TDBEdit;
Label4: TLabel;
DBEdit4: TDBEdit;
Label5: TLabel;
DBEdit5: TDBEdit;
PopupMenu1: TPopupMenu;
N11: TMenuItem;
N1: TMenuItem;
N21: TMenuItem;
N2: TMenuItem;
N31: TMenuItem;
N3: TMenuItem;
N41: TMenuItem;
Panel3: TPanel;
BitBtn1: TBitBtn;
BitBtn2: TBitBtn;
Panel4: TPanel;
Label6: TLabel;
DBEdit6: TDBEdit;
DBNavigator2: TDBNavigator;
procedure ToolButton1Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormActivate(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure ToolButton3Click(Sender: TObject);
procedure BitBtn1Click(Sender: TObject);
procedure BitBtn2Click(Sender: TObject);
procedure TabSheet1Enter(Sender: TObject);
procedure TreeViewClick(Sender: TObject);
procedure DBNavigator2Click(Sender: TObject; Button: TNavigateBtn);
procedure N11Click(Sender: TObject);
procedure N21Click(Sender: TObject);
procedure N41Click(Sender: TObject);
procedure PopupMenu1Popup(Sender: TObject);
procedure N31Click(Sender: TObject);
procedure FormKeyPress(Sender: TObject; var Key: Char);
procedure DBEdit5Exit(Sender: TObject);
procedure TreeViewChange(Sender: TObject; Node: TTreeNode);
private
{ Private declarations }
public
{ Public declarations }
procedure Write_LeiBie_DanWei(var LeiBie, DanWei :TADOTable);
procedure Refresh_Tree(Table:TADOTable; Tree:TTreeview; position:integer);
function Find_Node(lbcode:String):TTreeNode;
function Get_Node_Data(Node:TTreeNode;var lbcode, lbparent:String;
var lblevel:integer):Boolean;
function Gen_Next_LbCode(lbparent:String):string;
function Gen_INC_LbCode(lbCODE:String):string;
function Add_Current_Level(Node:TTreeNode):Boolean;
function Add_Next_Level(Node:TTreeNode):Boolean;
end;
PData = ^TData;
TData =Record
LBCode :String;
LBParent:String;
LBLevel:integer;
end ;
var
F_LeiBie: TF_LeiBie;
LBData : PData;

function rpos(msg:string; tagchar:String):integer ;
procedure Show_F_LeiBie;

implementation

{$R *.DFM}
uses
u_dm_now;

function rpos(msg:string; tagchar:string):integer ;
var i:integer;
begin
for i:= length(msg) downto 0 do
begin
if copy(msg, i, 1) = tagchar then
begin
Result := i ;
exit;
end
else
Result := 0;
end;
end;

procedure Show_F_LeiBie;
begin
try
F_LeiBie := TF_LeiBie.Create(nil);
F_LeiBie.ShowModal;
Finally
F_LeiBie.Free ;
end;
end;

function TF_LeiBie.Get_Node_Data(Node:TTreeNode;var lbcode, lbparent:String; var lblevel:integer):Boolean;
begin
lbcode := PData(Node.Data)^.LBCode;
lbparent:=PData(Node.Data)^.LBParent;
lblevel :=PData(Node.Data)^.LBLevel;
result := true;
end;

function TF_leiBie.Gen_INC_LbCode(lbCODE:String):string;
var
i,j:integer;
begin
j := rpos(lbcode, '-');
i := strtoint(copy(lbcode, j+ 1, length(lbcode) ));
Result :=copy(lbcode, 1, j) + inttostr(i +1);
end;

function TF_LeiBie.Gen_Next_LbCode(lbparent:String):string;
var
lbcode:string ;
q:TADOQuery;
i:integer ;
begin
q := TADOQuery.Create(nil);
q.Connection := dm_now.ADO_Now;
q.sql.add('select max(lbcode) as lbcode from '+ dm_now.at_leibie.TableName +
' where lbparent= '+ ''''+ lbparent + '''') ;
q.open;
if not q.RecordCount >0 then
begin
lbcode := q.fields[0].asstring;
i := strtoint(copy(lbcode, length(lbparent) +2, length(lbcode)- length(lbparent)));
inc(i);
end
else
i := 1;
lbcode := lbparent +'-'+ inttostr(i);
result := lbcode;
end;

function TF_LeiBie.Add_Current_Level(Node:TTreeNode):Boolean;
var
lbcode, lbparent:String;
lblevel :integer;
begin //在当前选择的Item　基础上为参考，增加同级类别。
//1:首先获取此级的有关数据
Get_Node_Data(Node,lbcode,lbparent,lblevel);

//2:设定要增加类别的应该先指定的数据, lbparent, lblevel 不变
// 关键是生成　ｌｂｃｏｄｅ的新的最大值
LBCode := Gen_INC_LBCode(LBCODE);

//3:
dm_now.at_leibie.Append ;
dm_now.at_leibie.FieldByName('lbcode').asstring := lbcode;
dm_now.at_leibie.FieldByName('lbparent').asstring := lbparent;
dm_now.at_leibie.FieldByName('lblevel').asinteger := lblevel;

end;

function TF_LeiBie.Add_Next_Level(Node:TTreeNode):Boolean;
var
lbcode, lbparent:String;
lblevel :integer;

begin //在当前选择的Item　基础上为参考，增加下级类别。
//1:首先获取当前级的有关数据
Get_Node_Data(Node,lbcode,lbparent,lblevel);

//2:设定要增加类别的应该先指定的数据
lbparent:= lbcode ;
lblevel := lblevel +1 ;
LBCode := Gen_Next_LBCode(LBParent);

//3:
dm_now.at_leibie.Append ;
dm_now.at_leibie.FieldByName('lbcode').asstring := lbcode;
dm_now.at_leibie.FieldByName('lbparent').asstring := lbparent;
dm_now.at_leibie.FieldByName('lblevel').asinteger := lblevel;

end;


procedure TF_LeiBie.ToolButton1Click(Sender: TObject);
begin
Close;
end;

procedure TF_LeiBie.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caFree;
end;

procedure TF_LeiBie.FormActivate(Sender: TObject);
begin
if dm_now.AT_LeiBie.Active = false then
dm_now.AT_LeiBie.Active := true ;
Refresh_Tree(dm_now.AT_LeiBie, TreeView, 0);
TreeView.setfocus;

end;

procedure TF_LeiBie.Write_LeiBie_DanWei(var LeiBie, DanWei :TADOTable);
var
dwcode, dwname:string;
begin
if LeiBie.Active = false then
LeiBie.Active := true ;
if DanWei.Active = false then
DanWei.Active := true ;
LeiBie.First;
while not LeiBie.Eof do
begin
dwcode := LeiBie.FieldByName('dwcode').AsString;
dwname := LeiBie.FieldByName('dwname').AsString;
if not DanWei.Locate('dwcode',dwcode,[]) then
begin
DanWei.Append;
DanWei.FieldByName('dwcode').AsString := dwcode ;
DanWei.FieldByName('dwflags').AsString := '000LB' ;
DanWei.FieldByName('dwlevel').AsString := '否' ;//表示：不是基层单位
end
else
DanWei.Edit ;

DanWei.FieldByName('dworder').AsInteger :=
LeiBie.FieldByName('dworder').AsInteger ;
DanWei.FieldByName('dwname').AsString := dwname ;
DanWei.FieldByName('dwjc').AsString := dwname ;
DanWei.FieldByName('dwpy').AsString := dwcode ;
DanWei.Post ;
StatusBar1.SimpleText :='处理：'+ dwcode+ ' '+dwname ;
LeiBie.Next;
end;
StatusBar1.SimpleText:= '处 理 完 毕 ！';
end;

procedure TF_LeiBie.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
//将　类别中定义的　类别所对应的　dwcode, dwname, 写入到 danwei 表中
// Write_LeiBie_DanWei(dm_now.at_LeiBie, dm_now.at_danwei);
CanClose := true;
end;

procedure TF_LeiBie.Refresh_Tree(Table:TADOTable; Tree:TTreeView; position:integer);
var
node, newnode:TTreenode;
begin
TreeView.Items.Clear ;
//按数据表中的记录刷新TreeView控件。
with Table do
begin
Filter := 'lblevel=1';
Filtered := true ;
First;
while not Eof do
begin
node:=Tree.Items.Add(nil,FieldByName('lbname').AsString);
new(LBData);
LBData^.LBCode := FieldByName('lbcode').AsString;
LBData^.LBParent := FieldByName('lbParent').AsString;
LBData^.LBLevel := FieldByName('lblevel').AsInteger;
node.Data := LBData;
Next;
end;
//----

Filtered := false ;
Filter := 'lblevel<>1';
Filtered := true ;
First;
while not Eof do
begin
node := Find_Node(FieldByName('lbparent').AsString);
newnode:=TreeView.Items.AddChild(node,FieldByName('lbname').AsString);
new(LBData);
LBData^.LBCode := FieldByName('lbcode').AsString;
LBData^.LBParent := FieldByName('lbParent').AsString;
LBData^.LBLevel := FieldByName('lblevel').AsInteger;
newnode.Data := LBData;
Next;
end;
Filtered := false ;
end; //end -> with table

end;

procedure TF_LeiBie.ToolButton3Click(Sender: TObject);
begin
GBox2.Enabled := not GBox2.Enabled ;
end;

procedure TF_LeiBie.BitBtn1Click(Sender: TObject);
begin
Refresh_Tree(dm_now.AT_LeiBie, TreeView, 0);
TreeView.SetFocus;
end;

function TF_LeiBie.Find_Node(lbcode:String):TTreeNode;
var
node :TTreeNode;
i: integer;
begin
Result :=nil;
for i:= 0 to TreeView.Items.Count -1 do
begin
lbdata:= TreeView.Items.Item.Data;
if lbdata.LBCode = lbcode then
begin
Result :=TreeView.Items.Item;
exit;
end
else
Result :=nil;
end;
end;

procedure TF_LeiBie.BitBtn2Click(Sender: TObject);
var
lbcode:String;
node :TTreeNode;
begin
lbcode := '';
if inputquery('输入框','请输入类别编号：', lbcode) = false then abort ;
node := Find_Node(trim(uppercase(lbcode)));
if node =nil then
ShowMessage('没 有 发 现 相 应 类 别 编 码 ！')
else
begin
TreeView.Selected := Node;
TreeView.SetFocus;
TreeViewClick(Sender);
end;
end;

procedure TF_LeiBie.TabSheet1Enter(Sender: TObject);
var
node :TTreeNode;
begin
//如树控件已生成数据->
if TreeView.Items.Count >0 then
begin
node := Find_Node(DM_now.AT_LeiBie.FieldByName('lbcode').AsString);
if node <>nil then
begin
TreeView.Selected := node;
TreeView.SetFocus;
end;
end;

end;

procedure TF_LeiBie.TreeViewClick(Sender: TObject);
//var
// lbcode:String;
begin
// lbcode := Pdata(TreeView.Selected.Data)^.LBCode;
// dm_now.at_leibie.Locate('lbcode', lbcode,[loPartialKey]);
end;

procedure TF_LeiBie.DBNavigator2Click(Sender: TObject;
Button: TNavigateBtn);
var
lbcode :string;
node:ttreenode;
begin
if Button = nbpost then
begin
lbcode :=dm_now.at_leibie.FieldByname('lbcode').AsString;
dm_now.at_leibie.Refresh ;
Refresh_Tree(dm_now.AT_LeiBie, TreeView, 0);
node := Find_Node(lbcode);
if node <>nil then
begin
TreeView.Selected := Node;
TreeView.SetFocus;
TreeViewClick(Sender);
end;
//cancel

end;
end;

procedure TF_LeiBie.N11Click(Sender: TObject);
var
lbcode:String;
flag:boolean;
begin
lbcode := 'AA';
if Inputquery(' 输 入 框 ',' 请输入一级数据分类代码　　', lbcode) =false then abort;
dm_now.at_leibie.Append ;
dm_now.at_leibie.FieldByName('lbcode').asstring := lbcode;
DBEdit2.SetFocus ;

end;

procedure TF_LeiBie.N21Click(Sender: TObject);
var
lbparent,lbcode:String;
lblevel:integer;
flag:boolean;
begin
flag :=Add_Current_Level(TreeView.Selected ); //增加同级分类,成功返回 true.
DBEdit2.SetFocus ;
end;

procedure TF_LeiBie.N41Click(Sender: TObject);
begin
//删除时必须考虑到不同级别的情况，如有下级，则应删除所有的下级!
if messagedlg('是否删除数据分类：'+ dm_now.at_leibie.fieldbyname('lbname').asstring ,
mtconfirmation, [mbYes, mbNo],0 ) = mrYes then
begin
dm_now.at_leibie.DeleteRecords(arCurrent);
Refresh_Tree(dm_now.at_leibie,treeview, 0);
end;
end;

procedure TF_LeiBie.PopupMenu1Popup(Sender: TObject);
begin
if TreeView.Selected =nil then
begin
N11.Enabled := true;
N21.Enabled := false;
N31.Enabled := false;
N41.Enabled := false;
exit;
end;
if TreeView.Selected.Level =0 then
begin
N21.Enabled := false ;
N31.Enabled := true;
end
else
N21.Enabled := true ;
if TreeView.Selected.HasChildren = false then
N41.Enabled := true
else
N41.Enabled := false ;

end;

procedure TF_LeiBie.N31Click(Sender: TObject);
begin
Add_Next_Level(TreeView.Selected);
DBEdit2.SetFocus ;
end;

procedure TF_LeiBie.FormKeyPress(Sender: TObject; var Key: Char);
begin
if key= #13 then
SelectNext(ActiveControl, true, true);
end;

procedure TF_LeiBie.DBEdit5Exit(Sender: TObject);
begin
dbnavigator2.SetFocus ;
end;

procedure TF_LeiBie.TreeViewChange(Sender: TObject; Node: TTreeNode);
var
lbcode:String;
begin
lbcode := Pdata(TreeView.Selected.Data)^.LBCode;
dm_now.at_leibie.Locate('lbcode', lbcode,[loPartialKey]);
end;

end.

我自己写了一个现成的这种类型的构件,叫DBTreeView,谁要?

以下代码可以提高树. 数据库的存取速度。。。。。。。。。。。
sujm@public1.sz.js.cn
*****************************************************

unit FamilySet;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ComCtrls, Menus, ImgList, Db, DBTables;

type
TVillage=record file://村记录
vid:string; file://村ID
vname:string; file://村名
end;
PVillage=^TVillage; file://村指针

TTeam=record file://组记录
vid:string; file://村ID
tid:string; file://组ID
tname:string file://组名
end;
PTeam=^TTeam; file://组指针

TFamily=record file://用户记录
id:string; file://有线编号
vid:string; file://村镇编号
tid:string; file://组街编号
fname:string; file://户名
address:string; file://地址
tel:string; file://电话
terms:integer; file://终端数
sid:string; file://用户类别
bankid:string; file://银行帐号
regdate:TDate; file://开户日期
isvalid:boolean; file://有效否
end;
PFamily=^TFamily;

TfmFamily = class(TForm)
tv: TTreeView;
MainMenu: TMainMenu;
mmProcess: TMenuItem;
mmAppend: TMenuItem;
mmEdit: TMenuItem;
mmDelete: TMenuItem;
ImageList: TImageList;
N1: TMenuItem;
sqlVillage: TQuery;
sqlTeam: TQuery;
sqlFamily: TQuery;
mmRefresh: TMenuItem;
PopupMenu: TPopupMenu;
pmAppend: TMenuItem;
pmEdit: TMenuItem;
pmDelete: TMenuItem;
N6: TMenuItem;
pmRefresh: TMenuItem;
N2: TMenuItem;
mmExpandAll: TMenuItem;
mmCollapseAll: TMenuItem;
N3: TMenuItem;
pmExpandAll: TMenuItem;
pmCollapseAll: TMenuItem;
N4: TMenuItem;
mmUnValid: TMenuItem;
mmValid: TMenuItem;
N5: TMenuItem;
pmValid: TMenuItem;
pmUnvalid: TMenuItem;
mmUserPrint: TMenuItem;
mmPrintUsers: TMenuItem;
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure mmAppendClick(Sender: TObject);
procedure tvGetImageIndex(Sender: TObject; Node: TTreeNode);
procedure tvGetSelectedIndex(Sender: TObject; Node: TTreeNode);
procedure FormCreate(Sender: TObject);
procedure tvDeletion(Sender: TObject; Node: TTreeNode);
procedure mmEditClick(Sender: TObject);
procedure mmDeleteClick(Sender: TObject);
procedure mmRefreshClick(Sender: TObject);
procedure pmAppendClick(Sender: TObject);
procedure pmEditClick(Sender: TObject);
procedure pmDeleteClick(Sender: TObject);
procedure pmRefreshClick(Sender: TObject);
procedure mmExpandAllClick(Sender: TObject);
procedure mmCollapseAllClick(Sender: TObject);
procedure pmExpandAllClick(Sender: TObject);
procedure pmCollapseAllClick(Sender: TObject);
procedure mmUnValidClick(Sender: TObject);
procedure mmValidClick(Sender: TObject);
procedure pmUnvalidClick(Sender: TObject);
procedure pmValidClick(Sender: TObject);
procedure tvMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure mmPrintUsersClick(Sender: TObject);
private
{ Private declarations }
procedure ExpandTreeAll; file://镇、村、组、户 ,可能受机器限制，该函数不能成功。
public
{ Public declarations }
end;

var
fmFamily: TfmFamily;

implementation

uses NewVillage, NewTeam, NewFamily, catv_vars, ReportUser, UserPrint;
var tn0,tn1,tn2,tn3:TTreeNode; file://镇、村、组、户节点
aVillageVillage; file://一个村指针 （市镇）
aTeamTeam; file://一个组指针 （街道）
aFamilyFamily; file://一个户指针
{$R *.DFM}

procedure TfmFamily.ExpandTreeAll;
begin
tv.Items.Clear;
tn0:=tv.Items.Add(nil,_AreaName);
with sqlVillage do
begin
Close;
SQL.Clear;
SQL.Add('select vid,vname from village order by vid ') ;
Open;
while not eof do
begin
New(aVillage);
aVillage.vid:=FieldByName('vid').asstring;
aVillage.vname:=FieldByName('vname').asstring;
tn1:=tv.Items.AddChildObject(tn0,aVillage.vname,aVillage);
with sqlTeam do
begin
Close;
SQL.Clear;
SQL.Add('select vid,tid,tname from team where vid=:vid order by tid ');
ParamByName('vid').asstring:=aVillage.vid;
Open;
while not eof do
begin
New(aTeam);
aTeam.vid:=aVillage.vid;
aTeam.tid:=FieldByName('tid').asstring;
aTeam.tname:=FieldByName('tname').asstring;
tn2:=tv.Items.AddChildObject(tn1,aTeam.tname,aTeam);
with sqlFamily do
begin
Close;
SQL.Clear;
SQL.Add('select * from family where vid=:vid and tid=:tid order by id ');
ParamByName('vid').asstring:=aVillage.vid;
ParamByName('tid').asstring:=aTeam.tid;
Open;
while not eof do
begin
New(aFamily);
aFamily.id:=FieldByName('id').asstring;
aFamily.vid:=aVillage.vid;
aFamily.tid:=aTeam.tid;
aFamily.fname:=FieldByName('fname').asstring;
aFamily.address:=FieldByName('address').asstring;
aFamily.tel:=FieldByName('tel').asstring;
aFamily.bankid:=FieldByName('bankid').asstring;
aFamily.sid:=FieldByName('sid').asstring;
aFamily.terms:=FieldByName('terms').asinteger;
aFamily.regdate:=FieldByName('regdate').asdatetime;
aFamily.isvalid:=FieldByName('isvalid').asboolean;
tn3:=tv.Items.AddChildObject(tn2,aFamily.fname,aFamily);
Next;
end;
Close;
end;
Next;
end;
Close;
end;
Next;
end;
Close;
end;


end;


procedure TfmFamily.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action:=caFree;
end;

procedure TfmFamily.mmAppendClick(Sender: TObject);
var tn:TTreeNode;
id:string;
i:integer;
begin
tn:=tv.Selected;
if (tn=nil) then tn:=tn0; file://根节点：乡镇名称
if (tn.Level=3) then tn:=tn.Parent; file://选定户时取得所在组节点
case tn.Level of
0: file://选定乡镇，增加村
with TfmNewVillage.Create(nil) do
try
Caption:='增加新村/镇';
if not tn.HasChildren then
edtVid.Text:='01'
else
begin
id:=PVillage(tn.GetLastChild.Data)^.vid;
edtVid.Text:=Copy(IntToStr(StrToInt(id)+1+100),2,2);
end;
edtVname.Text:='';
ShowModal;
if (ModalResult=mrOK) then
begin
if (length(edtVid.Text)=1) then edtVid.Text:=Copy(IntToStr(StrToInt(edtVid.text)+100),2,2); file://补前导0
with sqlVillage do
begin
Close;
SQL.Clear;
SQL.Add('insert into village (vid,vname) values vid,:vname) ');
ParambyName('vid').asstring:=edtVid.Text;
ParamByName('vname').asstring:=edtVname.Text;
try
ExecSQL; file://先插入表中
New(aVillage); file://再增加树节点
aVillage.vid:=edtVid.Text;
aVillage.vname:=edtVname.Text;
tv.Items.AddChildObject(tn,edtVname.text,aVillage);
except
MessageDlg('增加新村/镇失败！',mtInformation,[mbOk],0);
end;
end;
end;
finally
free;
end;

1: file://选定村，增加组
with TfmNewTeam.Create(nil) do
try
Caption:='增加新组/街（'+PVillage(tn.data)^.vname+'）';
if not tn.HasChildren then
edtTid.Text:='01'
else
begin
id:=PTeam(tn.GetLastChild.Data)^.tid;
edtTid.Text:=Copy(IntToStr(StrToInt(id)+1+100),2,2);
end;
edtTname.Text:='';
ShowModal;
if (ModalResult=mrOK) then
begin
if (length(edtTid.Text)=1) then edtTid.Text:=Copy(IntToStr(StrToInt(edtTid.text)+100),2,2); file://补前导0
with sqlTeam do
begin
Close;
SQL.Clear;
SQL.Add('insert into team (vid,tid,tname) values vid,:tid,:tname) ');
ParambyName('vid').asstring:=PVillage(tn.data)^.vid;
ParamByName('tid').asstring:=edtTid.Text;
ParamByName('tname').asstring:=edtTname.Text;
try
ExecSQL; file://先插入表中
New(aTeam); file://再增加树节点
aTeam.vid:=PVillage(tn.data)^.vid;
aTeam.tid:=edtTid.Text;
aTeam.tname:=edtTname.Text;
tv.Items.AddChildObject(tn,edtTname.text,aTeam);
except
MessageDlg('增加新组/街失败！',mtInformation,[mbOk],0);
end;
end;
end;
finally
free;
end;

2: file://选定组，增加户
with TfmNewFamily.Create(nil) do
try
Caption:='增加新用户（'+PTeam(tn.data)^.tname+'）';
edtId.Text:='';
edtFname.Text:='';
edtAddress.Text:='';
edtTel.Text:='';
edtBankId.Text:='';
for i:=0 to Length(_sname)-1 do
cbSid.Items.Add(_sname); file://选择类别名称
cbSid.ItemIndex:=0;
edtTerms.Text:='1';
dtpRegDate.DateTime:=Date;
ShowModal;
if (ModalResult=mrOK) then
begin
with sqlFamily do
begin
Close;
SQL.Clear;
SQL.Add('insert into family (id,vid,tid,fname,address,tel,bankid,sid,terms,regdate,isvalid) values id,:vid,:tid,:fname,:address,:tel,:bankid,:sid,:terms,:regdate,:isvalid) ');
ParamByName('id').asstring:=edtId.Text;
ParambyName('vid').asstring:=PTeam(tn.data)^.vid;
ParambyName('tid').asstring:=PTeam(tn.data)^.tid;
ParamByName('fname').asstring:=edtFname.Text;
ParamByName('address').asstring:=edtAddress.Text;
ParamByName('tel').asstring:=edtTel.Text;
ParamByName('bankid').asstring:=edtBankId.Text;
ParamByName('sid').asstring:=_sid[cbSid.itemindex]; file://保存类别编号
ParamByName('terms').asinteger:=StrTOIntDef(edtTerms.text,1);
ParamByName('regdate').asstring:=DateToStr(dtpRegDate.Date); file://不直接用日期型，防止错误
ParamByName('isvalid').asboolean:=True;
try
ExecSQL; file://先插入表中
New(aFamily); file://再增加树节点
aFamily.id:=edtId.Text;
aFamily.vid:=PVillage(tn.Parent.data)^.vid;
aFamily.tid:=PTeam(tn.data)^.tid;
aFamily.fname:=edtFname.Text;
aFamily.address:=edtAddress.Text;
aFamily.tel:=edtTel.Text;
aFamily.bankid:=edtBankId.Text;
aFamily.sid:=_sid[cbSid.itemindex];
aFamily.terms:=StrTOIntDef(edtTerms.text,1);
aFamily.regdate:=dtpRegDate.Date;
aFamily.isvalid:=True;
tv.Items.AddChildObject(tn,edtFname.text,aFamily);
except
MessageDlg('增加新用户失败！',mtInformation,[mbOk],0);
end;
end;
end;
finally
free;
end;

end;

end;

procedure TfmFamily.tvGetImageIndex(Sender: TObject; Node: TTreeNode);
begin
If (Node.Level=3) then file://户 0:地区 1：村 2：组 3：户
if PFamily(Node.Data)^.isvalid then
Node.ImageIndex:=2 file://有效用户
else
Node.ImageIndex:=3 file://已注销用户
else if Node.Expanded then
Node.ImageIndex:=1
else Node.ImageIndex:=0;

end;

procedure TfmFamily.tvGetSelectedIndex(Sender: TObject; Node: TTreeNode);
begin
Node.SelectedIndex:=Node.ImageIndex;
end;

procedure TfmFamily.FormCreate(Sender: TObject);
begin
// InitTree;
ExpandTreeAll;
end;

procedure TfmFamily.tvDeletion(Sender: TObject; Node: TTreeNode);
begin
if Assigned(Node.Data) then
case Node.Level of
1:
Dispose(PVillage(Node.Data));
2:
Dispose(PTeam(Node.Data));
3:
Dispose(PFamily(Node.Data));
end;
end;

procedure TfmFamily.mmEditClick(Sender: TObject);
var tn:TTreeNode; //
i:integer;
begin
tn:=tv.Selected;
if ((tn=nil) or (tn.level=0)) then
begin
MessageDlg('请选定村组(镇街)或用户！',mtInformation,[mbOk],0);
Exit;
end;
case tn.Level of
1: file://选定村，修改村
with TfmNewVillage.Create(nil) do
try
Caption:='修改村/镇名';
edtVid.Text:=PVillage(tn.data)^.vid;
edtVname.Text:=PVillage(tn.data)^.vname;
edtVid.ReadOnly:=True;
ShowModal;
if (ModalResult=mrOK) then
begin
with sqlVillage do
begin
Close;
SQL.Clear;
SQL.Add('update village set vname=:vname where vid=:vid ');
ParambyName('vid').asstring:=edtVid.Text;
ParamByName('vname').asstring:=edtVname.Text;
try
ExecSQL; file://先更新表
tn.Text:=edtVName.Text; file://再修改树节点
PVillage(tn.data)^.vname:=edtVname.Text;
except
MessageDlg('修改村/镇名失败！',mtInformation,[mbOk],0);
end;
end;
end;
finally
free;
end;

2: file://选定组，修改组
with TfmNewTeam.Create(nil) do
try
Caption:='修改组/街名（'+tn.Parent.Text+'）';
edtTid.Text:=PTeam(tn.data)^.tid;
edtTname.Text:=PTeam(tn.data)^.tname;
edtTid.ReadOnly:=True;
ShowModal;
if (ModalResult=mrOK) then
begin
with sqlTeam do
begin
Close;
SQL.Clear;
SQL.Add('update team set tname=:tname where vid=:vid and tid=:tid ');
ParambyName('vid').asstring:=PVillage(tn.Parent.data)^.vid;
ParamByName('tid').asstring:=edtTid.Text;
ParamByName('tname').asstring:=edtTname.Text;
try
ExecSQL; file://先修改表
tn.text:=edtTName.Text; file://再修改树节点
PTeam(tn.data)^.tname:=edtTname.Text;
except
MessageDlg('修改组/街名失败！',mtInformation,[mbOk],0);
end;
end;
end;
finally
free;
end;

3: file://选定户，修改户
with TfmNewFamily.Create(nil) do
try
Caption:='修改用户（'+tn.Parent.Text+'）';
edtId.ReadOnly:=True;
for i:=0 to Length(_sname)-1 do
cbSid.Items.Add(_sname); file://选择类别名称

edtId.Text:=PFamily(tn.data)^.id;
edtFname.Text:=PFamily(tn.data)^.fname;
edtAddress.Text:=PFamily(tn.data)^.address;
edtTel.Text:=PFamily(tn.data)^.tel;
edtBankId.Text:=PFamily(tn.data)^.bankid;
edtTerms.Text:=IntToStr(PFamily(tn.data)^.terms);
dtpRegDate.DateTime:=PFamily(tn.data)^.regdate;
for i:=0 to Length(_sid)-1 do
if Pfamily(tn.data)^.sid=_sid then break;
cbSid.ItemIndex:=i;

ShowModal;
if (ModalResult=mrOK) then
begin
with sqlFamily do
begin
Close;
SQL.Clear;
SQL.Add('update family set fname=:fname,address=:address,tel=:tel,');
SQL.Add('bankid=:bankid,sid=:sid,terms=:terms,regdate=:regdate where id=:id');

ParamByName('id').asstring:=edtId.Text;
ParamByName('fname').asstring:=edtFname.Text;
ParamByName('address').asstring:=edtAddress.Text;
ParamByName('tel').asstring:=edtTel.Text;
ParamByName('bankid').asstring:=edtBankId.Text;
ParamByName('sid').asstring:=_sid[cbSid.itemindex]; file://保存类别编号
ParamByName('terms').asinteger:=StrTOIntDef(edtTerms.text,1);
ParamByName('regdate').asstring:=DateToStr(dtpRegDate.Date); file://不直接用日期型，防止错误

try
ExecSQL; file://修改表
tn.Text:=edtFname.Text; file://再修改树节点
PFamily(tn.data)^.fname:=edtFname.Text;
PFamily(tn.data)^.address:=edtAddress.Text;
PFamily(tn.data)^.tel:=edtTel.Text;
PFamily(tn.data)^.bankid:=edtBankid.Text;
PFamily(tn.data)^.sid:=_sid[cbSid.itemindex];
PFamily(tn.data)^.terms:=StrTOIntDef(edtTerms.text,1);
PFamily(tn.data)^.regdate:=dtpRegDate.Date;
except
MessageDlg('修改用户信息失败！',mtInformation,[mbOk],0);
end;
end;
end;
finally
free;
end;

end;

end;

procedure TfmFamily.mmDeleteClick(Sender: TObject);
var tn:TTreeNode;
begin
tn:=tv.Selected;
if ((tn=nil) or (tn.level=0)) then
begin
MessageDlg('请选定村组(镇街)或用户！',mtInformation,[mbOk],0);
Exit;
end;
if tn.HasChildren then
begin
MessageDlg('请先删除下级！',mtInformation,[mbOk],0);
Exit;
end;

if MessageDlg('是否删除"'+tn.text+'"？',mtConfirmation,[mbYes,mbNo],0)<>mrYes then Exit;

case tn.Level of
1: file://删除村
with sqlVillage do
begin
Close;
SQL.Clear;
SQL.Add('delete from village where vid=:vid ');
ParambyName('vid').asstring:=PVillage(tn.data)^.vid;
try
ExecSQL; file://先从表中删除
tn.Delete; file://再删除树节点
except
MessageDlg('删除失败！',mtInformation,[mbOk],0);
end;
end;

2: file://删除组
with sqlTeam do
begin
Close;
SQL.Clear;
SQL.Add('delete from team where vid=:vid and tid=:tid ');
ParambyName('vid').asstring:=PTeam(tn.data)^.vid;
ParamByName('tid').asstring:=PTeam(tn.data)^.tid;
try
ExecSQL; file://从表删除
tn.delete; file://再删除树节点
except
MessageDlg('删除失败！',mtInformation,[mbOk],0);
end;
end;

3: file://删除户
if MessageDlg('删除用户将丢失该用户的收费信息，是否删除？',mtWarning,[mbYes,mbNo],0)=mrYes then
with sqlFamily do
begin
Close;
SQL.Clear;
SQL.Add('delete from family where id=:id');
ParambyName('id').asstring:=PFamily(tn.data)^.id;
try
ExecSQL; file://从表删除
tn.delete; file://再删除树节点
except
MessageDlg('删除失败！',mtInformation,[mbOk],0);
end;
end;

end;

end;

procedure TfmFamily.mmRefreshClick(Sender: TObject);
begin
ExpandTreeAll;
end;

procedure TfmFamily.pmAppendClick(Sender: TObject);
begin
mmAppend.Click;
end;

procedure TfmFamily.pmEditClick(Sender: TObject);
begin
mmEdit.Click;
end;

procedure TfmFamily.pmDeleteClick(Sender: TObject);
begin
mmDelete.Click;
end;

procedure TfmFamily.pmRefreshClick(Sender: TObject);
begin
mmRefresh.Click;
end;

procedure TfmFamily.mmExpandAllClick(Sender: TObject);
begin
tv.FullExpand;
end;

procedure TfmFamily.mmCollapseAllClick(Sender: TObject);
begin
tv.FullCollapse;
end;

procedure TfmFamily.pmExpandAllClick(Sender: TObject);
begin
mmExpandALl.Click;
end;

procedure TfmFamily.pmCollapseAllClick(Sender: TObject);
begin
mmCollapseAll.Click;
end;

procedure TfmFamily.mmUnValidClick(Sender: TObject);
var tn:TTreeNode;
begin
tn:=tv.Selected;
if (tn=nil) or (tn.Level<3) or Pfamily(tn.data)^.isvalid=false then file://只处理未注销用户
Exit;
with sqlFamily do
begin
Close;
SQL.Clear;
SQL.Add(' update family set isvalid=false where id=:id') ;
ParamByName('id').asstring:=Pfamily(tn.data)^.id;
try
ExecSQL; file://先更新表
Pfamily(tn.data)^.isvalid:=false;
tv.Selected:=nil;tv.Selected:=tn; file://以改变图标
except
MessageDlg('注销用户失败！',mtInformation,[mbOk],0);
end;
end;

end;

procedure TfmFamily.mmValidClick(Sender: TObject);
var tn:TTreeNode;
begin
tn:=tv.Selected;
if (tn=nil) or (tn.Level<3) or Pfamily(tn.data)^.isvalid=True then file://只处理已注销用户
Exit;
with sqlFamily do
begin
Close;
SQL.Clear;
SQL.Add(' update family set isvalid=true where id=:id') ;
ParamByName('id').asstring:=Pfamily(tn.data)^.id;
try
ExecSQL; file://先更新表
Pfamily(tn.data)^.isvalid:=true;
tv.Selected:=nil;tv.Selected:=tn; file://以改变图标
except
MessageDlg('收回用户失败！',mtInformation,[mbOk],0);
end;
end;

end;

procedure TfmFamily.pmUnvalidClick(Sender: TObject);
begin
mmUnvalid.Click;
end;

procedure TfmFamily.pmValidClick(Sender: TObject);
begin
mmValid.Click;
end;

procedure TfmFamily.tvMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
var tn:TTreeNode;
begin
tn:=tv.GetNodeAt(x,y);
if (tn=nil) or (tn.Level<3) then
tv.Hint:=''
else
tv.Hint:= '编号:'+Pfamily(tn.data)^.id
+' 户名:'+Pfamily(tn.data)^.fname
+' 端数:'+IntToStr(Pfamily(tn.data)^.terms)
+' 开户:'+DateToStr(Pfamily(tn.data)^.regdate)
+' 类别:'+GetSname(Pfamily(tn.data)^.sid)
+' 帐号:'+Pfamily(tn.data)^.bankid
+' 地址:'+Pfamily(tn.data)^.address
+' 电话:'+Pfamily(tn.data)^.tel;
end;

procedure TfmFamily.mmPrintUsersClick(Sender: TObject);
begin
with TfmUserPrint.Create(nil) do
try
ShowModal;
finally
Free;
end;


end;

end.

多人接受答案了。