доступа после TStringEditLink разрушаться (TVirtualStringTree) - Лазарь пример

Question

Я пытаюсь реализовать редактор для VirtualStringTree на основе example из Lazarius

Можете ли вы сказать мне, почему я получаю нарушение прав доступа после TStringEditLink разрушается ?

В этом случае эта ошибка появляется только при нажатии ESCAPE или ENTER. Если я нажимаю одну ячейку на другую, ошибки нет.

Как наблюдение, я сею, что если я удалю код FEdit.Free с destructor TStringEditLink.Destroy, ошибка исчезнет.

У вас есть решение для этого?

пыльник полный код:

unit Unit2; 

interface 

uses 
    Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, 
    Vcl.Controls, Vcl.Forms, Vcl.Dialogs, VirtualTrees, EditorLink, Vcl.StdCtrls, 
    Vcl.ExtCtrls, Vcl.Imaging.jpeg; 

type 
    TTreeData = record 
    Fields: array of String; 
    end; 
    PTreeData = ^TTreeData; 

const 
    SizeVirtualTree = SizeOf(TTreeData); 

type 
    TForm2 = class(TForm) 
    VirtualTree: TVirtualStringTree; 
    procedure FormCreate(Sender: TObject); 
    procedure VirtualTreeClick(Sender: TObject); 
    procedure VirtualTreeCreateEditor(Sender: TBaseVirtualTree; 
     Node: PVirtualNode; Column: TColumnIndex; out EditLink: IVTEditLink); 
    procedure VirtualTreeEditing(Sender: TBaseVirtualTree; Node: PVirtualNode; 
     Column: TColumnIndex; var Allowed: Boolean); 
    procedure VirtualTreeFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode); 
    procedure VirtualTreeGetNodeDataSize(Sender: TBaseVirtualTree; 
     var NodeDataSize: Integer); 
    procedure VirtualTreeGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; 
     Column: TColumnIndex; TextType: TVSTTextType; var CellText: string); 
    procedure VirtualTreeNewText(Sender: TBaseVirtualTree; Node: PVirtualNode; 
     Column: TColumnIndex; NewText: string); 
    private 
    { Private declarations } 
    public 
    { Public declarations } 
    end; 

var 
    Form2: TForm2; 

implementation 

{$R *.dfm} 

procedure TForm2.FormCreate(Sender: TObject); 
var 
    Node: PVirtualNode; 
    LTreeData: PTreeData; 
begin 
    VirtualTree.Clear; 
    VirtualTree.BeginUpdate; 

    //node 1 
    Node:= VirtualTree.AddChild(nil,nil); 
    VirtualTree.ValidateNode(Node,False); 

    LTreeData:= VirtualTree.GetNodeData(Node); 
    SetLength(LTreeData^.Fields,3); 

    LTreeData^.Fields[0]:= 'John'; 
    LTreeData^.Fields[1]:= '2500'; 
    LTreeData^.Fields[2]:= 'Production'; 

    //node 2 
    Node:= VirtualTree.AddChild(nil,nil); 
    VirtualTree.ValidateNode(Node,False); 

    LTreeData:= VirtualTree.GetNodeData(Node); 
    SetLength(LTreeData^.Fields,3); 

    LTreeData^.Fields[0]:= 'Mary'; 
    LTreeData^.Fields[1]:= '2100'; 
    LTreeData^.Fields[2]:= 'HR'; 

    VirtualTree.EndUpdate; 
end; 

procedure TForm2.VirtualTreeClick(Sender: TObject); 
var 
    VT: TVirtualStringTree; 
    Click: THitInfo; 
begin 
    VT:= Sender as TVirtualStringTree; 
    VT.GetHitTestInfoAt(Mouse.CursorPos.X-VT.ClientOrigin.X, Mouse.CursorPos.Y-VT.ClientOrigin.Y, True, Click); 
    VT.EditNode(Click.HitNode,Click.HitColumn); 
end; 

procedure TForm2.VirtualTreeCreateEditor(Sender: TBaseVirtualTree; 
    Node: PVirtualNode; Column: TColumnIndex; out EditLink: IVTEditLink); 
begin 
    EditLink := TStringEditLink.Create; 
end; 

procedure TForm2.VirtualTreeEditing(Sender: TBaseVirtualTree; 
    Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean); 
begin 
    Allowed:= True; 
end; 

procedure TForm2.VirtualTreeFreeNode(Sender: TBaseVirtualTree; 
    Node: PVirtualNode); 
var 
    LTreeData: PTreeData; 
begin 
    LTreeData:= Sender.GetNodeData(Node); 
    Finalize(LTreeData^); 
end; 

procedure TForm2.VirtualTreeGetNodeDataSize(Sender: TBaseVirtualTree; 
    var NodeDataSize: Integer); 
begin 
    NodeDataSize:= SizeVirtualTree; 
end; 

procedure TForm2.VirtualTreeGetText(Sender: TBaseVirtualTree; 
    Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; 
    var CellText: string); 
var 
    LTreeData: PTreeData; 
begin 
    if Assigned(Node) and (Column > NoColumn) then 
    begin 
     LTreeData:= Sender.GetNodeData(Node); 
     CellText:= LTreeData^.Fields[Column]; 
    end; 
end; 

procedure TForm2.VirtualTreeNewText(Sender: TBaseVirtualTree; 
    Node: PVirtualNode; Column: TColumnIndex; NewText: string); 
var 
    LTreeData: PTreeData; 
begin 
    LTreeData:= Sender.GetNodeData(Node); 
    LTreeData^.Fields[Column]:= NewText; 
end; 

end. 

и EditorLink блок

unit EditorLink; 

interface 

uses 
    Classes, SysUtils, Forms, Controls, Graphics, Dialogs, 
    VirtualTrees, Messages, Windows, StdCtrls, Vcl.ExtCtrls; 

type 

    TStringEditLink = class(TInterfacedObject, IVTEditLink) 
    private 
    FEdit: TWinControl; 
    FTree: TVirtualStringTree; 
    FNode: PVirtualNode; 
    FColumn: Integer; 
    FStopping: Boolean; 
    protected 
    procedure EditKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); 
    public 
    destructor Destroy; override; 
    function BeginEdit: Boolean; stdcall; 
    function CancelEdit: Boolean; stdcall; 
    function EndEdit: Boolean; stdcall; 
    function GetBounds: TRect; stdcall; 
    function PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean; stdcall; 
    procedure ProcessMessage(var Message: TMessage); stdcall; 
    procedure SetBounds(R: TRect); stdcall; 
    end; 

implementation 

uses unit2; 

destructor TStringEditLink.Destroy; 
begin 
    FEdit.Free; //--> seems that due to this I get the access violation 
    inherited; 
end; 

procedure TStringEditLink.EditKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); 
begin 
    case Key of 
    VK_ESCAPE: 
     begin 
     FTree.CancelEditNode; 
     Key := 0; 
     FTree.setfocus; 
     end; 
    VK_RETURN: 
     begin 
     PostMessage(FTree.Handle, WM_KEYDOWN, VK_DOWN, 0); 
     Key := 0; 
     FTree.EndEditNode; 
     FTree.setfocus; 
     end; 
    end; //case 
end; 

function TStringEditLink.BeginEdit: Boolean; 
begin 
    Result := not FStopping; 
    if Result then 
    begin 
     FEdit.Show; 
     FEdit.SetFocus; 
    end; 
end; 

function TStringEditLink.CancelEdit: Boolean; 
begin 
    Result := True; 
    FEdit.Hide; 
end; 

function TStringEditLink.EndEdit: Boolean; 
var 
    s: String; 
begin 
    Result := True; 
    s := TComboBox(FEdit).Text; 
    FTree.Text[FNode, FColumn] := s; 

    FTree.InvalidateNode(FNode); 
    FEdit.Hide; 
    FTree.SetFocus; 
end; 

function TStringEditLink.GetBounds: TRect; 
begin 
    Result := FEdit.BoundsRect; 
end; 

function TStringEditLink.PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean; 
var 
    FCellText: String; 
    FCellTextBounds: TRect; 
    FCellFont: TFont; 
begin 
    Result := True; 
    FTree := Tree as TVirtualStringTree; 

    FNode := Node; 
    FColumn := Column; 

    FCellFont:= TFont.Create; 
    FTree.GetTextInfo(FNode, FColumn, FCellFont, FCellTextBounds, FCellText); 

    FEdit := TComboBox.Create(nil); 
    with FEdit as TComboBox do 
    begin 
     Visible := False; 
     Parent := Tree; 
     Items.Add('Google'); 
     Items.Add('Yahoo'); 
     Items.Add('Altavista'); 
     OnKeyDown := EditKeyDown; 
     Text:= FCellText; 
    end; 
end; 

procedure TStringEditLink.ProcessMessage(var Message: TMessage); 
begin 
    FEdit.WindowProc(Message); 
end; 

procedure TStringEditLink.SetBounds(R: TRect); 
var 
    Dummy: Integer; 
begin 
    FTree.Header.Columns.GetColumnBounds(FColumn, Dummy, R.Right); 
    FEdit.BoundsRect := R; 
end; 

end. 

Answer 1

Решение, которое я использовал в конце перечислены ниже:

TBasePanel = class(TPanel) 
    private 
    procedure CMRelease(var Message: TMessage); message CM_RELEASE; 
    protected 
    public 
    procedure Release; virtual; 
    end; 

TStringEditLink = class(TInterfacedObject, IVTEditLink) 
    private 
    FBasePanel: TBasePanel; 
    ... 
    protected 
    procedure EditKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); 
    public 
    destructor Destroy; override; 
    function BeginEdit: Boolean; stdcall; 
    function CancelEdit: Boolean; stdcall; 
    function EndEdit: Boolean; stdcall; 
    function GetBounds: TRect; stdcall; 
    function PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean; stdcall; 
    procedure ProcessMessage(var Message: TMessage); stdcall; 
    procedure SetBounds(R: TRect); stdcall; 
    end; 

implementation 

procedure TBasePanel.CMRelease(var Message: TMessage); 
begin 
    Free; 
end; 

procedure TBasePanel.Release; 
begin 
    if HandleAllocated then 
    PostMessage(Handle, CM_RELEASE, 0, 0); 
end; 

destructor TStringEditLink.Destroy; 
begin 
    if Assigned(FBasePanel) then FBasePanel.Release; 
    inherited; 
end; 

FBasePanel следует использовать в качестве owner и, как parent для многих редакторов, как компонент хотел бы быть отображены в то же время.

Answer 2

У меня нет Лазаря, но это, кажется, ведут себя так же на xe4.

В моей установке VST, расположенной в ./VirtualTreeviewV5.3.0/Demos/Advanced, есть файл Editors.pas, где я нашел деструктор ниже. Обратите внимание на комментарий casues issue #357:

destructor TPropertyEditLink.Destroy; 
begin 
    //FEdit.Free; casues issue #357. Fix: 
    if FEdit.HandleAllocated then 
    PostMessage(FEdit.Handle, CM_RELEASE, 0, 0); 
    inherited; 
end; 

Кроме того, FEdit.Free выполняется в методе PrepareEdit до его свежего создания:

function TStringEditLink.PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean; 
var 
    FCellText: String; 
    FCellTextBounds: TRect; 
    FCellFont: TFont; 
begin 
    Result := True; 
    FTree := Tree as TVirtualStringTree; 

    FNode := Node; 
    FColumn := Column; 

    FEdit.Free; 
    FEdit := nil; 

    FCellFont:= TFont.Create; 
    FTree.GetTextInfo(FNode, FColumn, FCellFont, FCellTextBounds, FCellText); 

    FEdit := TComboBox.Create(nil); 
    with FEdit as TComboBox do 
    . . . 

Это решает VK_ESC и VK_RETURN вопросов на моем xe4 и установке XE7.

---

Вопрос #357, кажется, еще не исправлено: см - Used fix proposed in issue #361 to fix issue #357 (AV in advanced demo - PropertiesDemo form in XE3+). Я не нашел доказательств #361 fix.

---

Другая проблема возникает при нажатии на неназначенный узел после операции редактирования.
Проверка, что Click.HitNode не nil перед началом редактирования, разрешает вышеуказанное.

procedure TForm2.VirtualTreeClick(Sender: TObject); 
var 
    VT: TVirtualStringTree; 
    Click: THitInfo; 
begin 
    VT:= Sender as TVirtualStringTree; 
    VT.GetHitTestInfoAt(Mouse.CursorPos.X-VT.ClientOrigin.X, Mouse.CursorPos.Y-VT.ClientOrigin.Y, True, Click); 

    if Assigned(Click.HitNode) then 
    VT.EditNode(Click.HitNode,Click.HitColumn); 
end; 

---

Заметьте также у вас есть циклическая ссылка в EditorLink единицу продукции:

uses Unit2; 

Answer 3

Это псевдо трассировки стека вашего кода иллюстрирует проблему:

FEdit.EditKeyDown() 
    -- calls -- 
FTree.EndEditNode() { or FTree.CancelEditNode } 
    -- which calls -- 
TStringEditLink.Destroy() 
    -- which calls -- 
FEdit.Free() 

Код в обработчик события для FEdit.EditKeyDown() освобождает FEdit перед ключом код обработчика события вниз заканчивается. Таким образом, ошибка нарушения доступа.

Мы обрабатываемся это путем создания механизма сигнала таким образом, TStringEditLink может сигнализировать основную форму, когда это было сделано, и основная форма может запустить код, чтобы уничтожить TStringEditLink (так как это тот, который создал TStringEditLink в первое место). Мы добавили TTimer в основную форму и свойство для получения сигнала. TTimer наблюдает за свойством. Компонент TStringEditLink имеет указатель на форму, поэтому он может установить свойство.

unit Unit1; 

interface 

uses 
    Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, 
    Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, VirtualTrees; 

type 
    TEditorAction = (eaCancel, eaAccept, eaNotSet); 

    TForm1 = class(TForm) 
    vstTree: TVirtualStringTree; 
    procedure vstTreeCreateEditor(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; out EditLink: IVTEditLink); 
    procedure DoWatchTreeEditorTimer(Sender: TObject); 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    private 
    FEndEditTimer: TTimer; 
    FEditorAction: TEditorAction; 
    procedure SetEditorAction(const Value: TEditorAction); 
    public 
    property EditorAction: TEditorAction read FEditorAction write SetEditorAction; 
    end; 

    TPropertyEdit = class(TInterfacedObject, IVTEditLink) 
    procedure EditKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); 
    private 
    FEdit: TWinControl; 
    FTree: TVirtualStringTree; 
    FNode: PVirtualNode; 
    FColumn: Integer; 
    public 
    FForm: TForm1; 
    destructor Destroy; override; 
    function BeginEdit: Boolean; stdcall; 
    function CancelEdit: Boolean; stdcall; 
    function EndEdit: Boolean; stdcall; 
    function GetBounds: TRect; stdcall; 
    function PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean; stdcall; 
    procedure ProcessMessage(var Message: TMessage); stdcall; 
    procedure SetBounds(R: TRect); stdcall; 
    end; 

var 
    Form1: TForm1; 

implementation 

{$R *.dfm} 

{ TForm1 } 

procedure TForm1.FormCreate(Sender: TObject); 
begin 
    FEndEditTimer := TTimer.Create(nil); 
    FEndEditTimer.Enabled := False; 
    FEndEditTimer.Interval := 100; 
    FEndEditTimer.OnTimer := DoWatchTreeEditorTimer; 
end; 

procedure TForm1.FormDestroy(Sender: TObject); 
begin 
    FreeAndNil(FEndEditTimer); 
end; 

procedure TForm1.vstTreeCreateEditor(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; out EditLink: IVTEditLink); 
begin 
    EditLink := TPropertyEdit.Create; 
    TPropertyEdit(EditLink).FForm := Self; { lets us signal the form when the editor needs to be destroyed } 
    FEditorAction := eaNotSet; 
end; 

procedure TForm1.SetEditorAction(const Value: TEditorAction); 
begin 
    if FEditorAction <> Value then 
    begin 
    FEditorAction := Value; 
    FEndEditTimer.Enabled := True; 
    end; 
end; 

procedure TForm1.DoWatchTreeEditorTimer(Sender: TObject); 
begin 
    FEndEditTimer.Enabled := False; 
    Application.ProcessMessages; 
    case FEditorAction of 
    eaCancel: 
     begin 
     vstTree.CancelEditNode; 
     vstTree.SetFocus; 
     end; 
    eaAccept: 
     begin 
     vstTree.EndEditNode; 
     vstTree.SetFocus; 
     end; 
    end; 
end; 

{ TPropertyEdit } 

function TPropertyEdit.BeginEdit: Boolean; 
begin 
    Result := True; 
    FEdit.Show; 
end; 

function TPropertyEdit.CancelEdit: Boolean; 
begin 
    Result := True; 
    FEdit.Hide; 
    FForm.FEditorAction := eaCancel; 
end; 

destructor TPropertyEdit.Destroy; 
begin 
    if FEdit <> nil then 
    FreeAndNil(FEdit); 
    inherited; 
end; 

procedure TPropertyEdit.EditKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); 
begin 
    case Key of 
    VK_ESCAPE: 
     begin 
     Key := Word(0); { some versions of Delphi throw random A/V errors if '0' is not cast as a Word() } 
     FForm.EditorAction := eaCancel; 
     end; 
    VK_RETURN: 
     begin 
     Key := Word(0); { some versions of Delphi throw random A/V errors if '0' is not cast as a Word() } 
     FForm.EditorAction := eaAccept 
     end; 
    end; 
end; 

function TPropertyEdit.EndEdit: Boolean; 
begin 
    Result := True; 
    { Do something with the value provided by the user } 
    FEdit.Hide; 
    FForm.EditorAction := eaAccept; 
end; 

function TPropertyEdit.GetBounds: TRect; 
begin 
    Result := FEdit.BoundsRect; 
end; 

function TPropertyEdit.PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean; 
begin 
    Result := True; 
    FTree := Tree as TVirtualStringTree; 
    FNode := Node; 
    FColumn := Column; 
    { Setup the editor for user } 
    FEdit := TSomeWinControl.Create(nil); 
    FEdit.Properties := Values; 
    { Capture keystrokes } 
    FEdit.OnKeyDown := EditKeyDown; 
end; 

procedure TPropertyEdit.ProcessMessage(var Message: TMessage); 
begin 
    FEdit.WindowProc(Message); 
end; 

procedure TPropertyEdit.SetBounds(R: TRect); 
var 
    Dummy: Integer; 
begin 
    FTree.Header.Columns.GetColumnBounds(FColumn, Dummy, R.Right); 
    FEdit.BoundsRect := R; 
end; 

end. 

Наш код делает много дополнительных вещей, так что приведенный выше код является копирование/вставка из существенных частей, чтобы продемонстрировать, как преодолеть состояние гонки. Он не проверен, но должен заставить вас указывать в правильном направлении.

Answer 4

В исходном коде HeidiSql есть хороший пример, чтобы избежать этой ошибки. код немного измененный является:

procedure TBaseEditorLink.TempWindowProc(var Message: TMessage); 
begin 
    case Message.Msg of 
    WM_CHAR: //Catch hotkeys 
     if not (TWMChar(Message).CharCode = VK_TAB) then FOldWindowProc(Message); 
    WM_GETDLGCODE: //"WantTabs" mode for main control 
     Message.Result := Message.Result or DLGC_WANTARROWS or DLGC_WANTALLKEYS or DLGC_WANTTAB; 
    else 
     begin 
     try 
      FOldWindowProc(Message); 
     except 
      on E : EAccessViolation do; //EAccessViolation occurring in some cases 
      on E : Exception do raise; 
     end; 
     end; 
    end; 
end; 

Answer 5

Одним из решений являются также освободить ранее созданные элементы управления.

function TStringEditLink.PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean; 
var 
    FCellText: String; 
    FCellTextBounds: TRect; 
    FCellFont: TFont; 
    i: Integer; 
    Item: TControl; 
begin 
    Result := True; 
    FTree := Tree as TVirtualStringTree; 

    FNode := Node; 
    FColumn := Column; 

    FCellFont:= TFont.Create; 
    FTree.GetTextInfo(FNode, FColumn, FCellFont, FCellTextBounds, FCellText); 

    //----->> free previuous created control <<---------- 
    for i := (FTree.ControlCount - 1) downto 0 do 
    begin 
     Item := FTree.controls[i]; 
     if assigned(item) then 
     begin 
      if item is TComboBox then FreeAndNil(item); 
     end; 
    end; 
    //--------------------------------------------------- 

    FEdit := TComboBox.Create(nil); 
    with FEdit as TComboBox do 
    begin 
     Visible := False; 
     Parent := Tree; 
     Items.Add('Google'); 
     Items.Add('Yahoo'); 
     Items.Add('Altavista'); 
     OnKeyDown := EditKeyDown; 
     Text:= FCellText; 
    end; 
end;