fpc 2.6.2
Ubuntu 13.10 i386
Создал визуальный компонент на основе TTreeView с динамической подгрузкой ветвей дерева из БД.
- Код: Выделить всё
unit DBDynTreeView;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, ComCtrls,
pqconnection, sqldb,
dbfunc, keyvalue, extsqlquery;
type
THookStringList = class(TStringList);
THookConnection = class(TPQConnection);
{ TDBDynTreeView }
TDBDynTreeView = class(TTreeView)
private
FKey: String;
FConnection: TPQConnection;
FSQL: TStringList;
procedure SetConnection(AValue: TPQConnection);
procedure SetKey(AValue: String);
procedure SetSQL(AValue: TStringList);
{ Private declarations }
protected
{ Protected declarations }
public
{ Public declarations }
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
procedure Fill(Node: TTreeNode);
published
{ Published declarations }
property SQL: TStringList read FSQL write SetSQL;
property Key: String read FKey write SetKey;
property Connection: TPQConnection read FConnection write SetConnection;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Data Controls',[TDBDynTreeView]);
end;
{ TDBDynTreeView }
procedure TDBDynTreeView.SetConnection(AValue: TPQConnection);
begin
if FConnection=AValue then Exit;
FConnection:=AValue;
end;
procedure TDBDynTreeView.SetSQL(AValue: TStringList);
begin
if FSQL=AValue then Exit;
FSQL:=AValue;
end;
procedure TDBDynTreeView.SetKey(AValue: String);
begin
if FKey=AValue then Exit;
FKey:=AValue;
end;
constructor TDBDynTreeView.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
FConnection:=TPQConnection.Create(Self);
FConnection.SetSubComponent(true);
FSQL:=TStringList.Create();
//Include(THookConnection(FConnection).FComponentStyle, csSubComponent);
end;
destructor TDBDynTreeView.Destroy;
begin
FConnection.Free;
FConnection:=nil;
FSQL.Free;
FSQL:=nil;
inherited Destroy;
end;
procedure TDBDynTreeView.Fill(Node: TTreeNode);
var
Query: TExtSQLQuery;
NewNode : TTreeNode;
NodeData: TKeyValue;
begin
if (Node <> nil) and (Node.HasChildren) then
if (Node.GetFirstChild.Data = nil) then
Node.DeleteChildren
else
Exit;
try
Query := TExtSQLQuery.Create(Self, FConnection);
if (Node = nil) then
Query.SQL.Text := FSQL.Text + ' is null'
else
Query.SQL.Text := FSQL.Text + ' = ''' + TKeyValue(Node.Data).Code + '''';
Query.Open;
while not Query.Eof do
begin
NodeData:=TKeyValue.Create(Query.Fields[0].AsString, Query.Fields[1].AsString);
if Assigned(Node) then begin
NewNode := Items.AddChildObject(Node, NodeData.Value, NodeData);
end
else begin
NewNode := Items.AddObject(Node, NodeData.Value, NodeData);
end;
Items.AddChildObject(NewNode, '', nil);
// коментарий убрать, если нужно грузить всё дерево целиком
// Fill(NewNode);
Query.Next;
end;
finally
Query.Destroy;
end;
end;
end.
Для упрощения вызова запроса на получение данных из БД использую компонент ExtSQLQuery:
- Код: Выделить всё
unit ExtSQLQuery;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, sqldb;
type
{ TExtSQLQuery }
TExtSQLQuery = class(TSQLQuery)
private
{ Private declarations }
FTrans: TSQLTransaction;
protected
{ Protected declarations }
public
{ Public declarations }
constructor Create(TheOwner: TComponent); override;
constructor Create(TheOwner: TComponent; Conn: TSQLConnection);
destructor Destroy; override;
published
{ Published declarations }
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('SQLdb',[TExtSQLQuery]);
end;
{ TExtSQLQuery }
constructor TExtSQLQuery.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
end;
constructor TExtSQLQuery.Create(TheOwner: TComponent; Conn: TSQLConnection);
begin
Self.Create(TheOwner);
FTrans:=TSQLTransaction.Create(TheOwner);
FTrans.DataBase:=Conn;
Self.DataBase:=Conn;
Self.Transaction:=FTrans;
end;
destructor TExtSQLQuery.Destroy;
begin
FTrans.Commit;
Self.Close;
Self.DataBase:=nil;
FTrans.DataBase:=nil;
FTrans.Free;
FTrans:=nil;
inherited Destroy;
end;
end.
Загрузка корневых веток в DBDynTreeView происходит без ошибок. Без ошибок же загружается всё дерево целиком, когда убираю коментарий на рекурсивный вызов Fill(NewNode).
Ошибка "Access violation" вываливается при повторной попытке вызвать DBDynTreeView.Fill(NewNode) по событию раскрытия ветви. Возникает в конструкторе:
- Код: Выделить всё
constructor TExtSQLQuery.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
end;
Кусок основного модуля:
- Код: Выделить всё
...
type
{ TMainForm }
TMainForm = class(TForm)
...
ServicesTreeView: TDBDynTreeView;
...
procedure TMainForm.DBDynTreeViewExpanding(Sender: TObject; Node: TTreeNode;
var AllowExpansion: Boolean);
begin
TDBDynTreeView(TObject).Fill(Node);
end;
...
procedure TMainForm.AfterConnect;
begin
....
ServicesTreeView.Connection := Conn;
ServicesTreeView.SQL.Add('select uuid, disp from services_hlist where parent ') ;
ServicesTreeView.Fill(nil);
ЧЯДНТ?