TStringEditLink 被破坏后的访问冲突 (TVirtualStringTree) - Lazarus 示例答案

【问题标题】：Access violation after TStringEditLink get destroyed (TVirtualStringTree) - Lazarus exampleTStringEditLink 被破坏后的访问冲突 (TVirtualStringTree) - Lazarus 示例
【发布时间】：2016-08-05 13:49:24
【问题描述】：

我尝试基于example of Lazarius 为 VirtualStringTree 实现一个编辑器

你能告诉我为什么在TStringEditLink 被销毁后我会遇到访问冲突吗？

奇怪的是，只有当我按下 ESCAPE 或 ENTER 时才会出现错误。如果我从一个单元格单击到另一个单元格，则没有错误。

就像一个观察一样，我认为如果我从 destructor TStringEditLink.Destroy 中删除 FEdit.Free 代码，错误就会消失。

你有解决办法吗？

下面是完整代码：

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.

【问题讨论】：

标签： delphi virtualtreeview tvirtualstringtree

【解决方案1】：

我没有 Lazarus，但它在 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
  . . .

这解决了我的 XE4 和 XE7 安装中的 VK_ESC 和 VK_RETURN 问题。

#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;

【讨论】：

既然我播下了你的答案，我记得我几个月前播下了这段代码。我会测试它，我会回来提供反馈。
它不能解决问题。控件在FTree 之后被破坏，并且表单被破坏。如果我不输入FEdit.Free，也是一样的。为了查看FEdit 何时被破坏，我使用了包装器TAltComboBox = class(TComboBox); ... procedure WMDestroy(var Msg: TWMDestroy); message WM_DESTROY;
你为什么使用相当老的V5.3.0？现在的V6.3.0还存在这个问题吗？

【解决方案2】：

您的代码的这个伪堆栈跟踪说明了这个问题：

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.

我们的代码做了很多额外的事情，所以上面的代码是基本部分的复制/粘贴，以演示如何克服竞争条件。它未经测试，但应该能让你指向正确的方向。

【讨论】：

不行！我之前也尝试过if assigned(FEdit) then FEdit.Free;。它还感兴趣的是，如果我在inherited 之后添加showmessage('...')，错误就会消失。也许是编辑器被销毁后节点的焦点。
也许将FEdit 设置为nil 会有所帮助？否则，这听起来像是一种竞争条件。
我认为你是对的，它与按键有关。我查看了那部分的代码，它与您的不同。我将编辑我的答案。

【解决方案3】：

一种解决方案也是释放之前创建的控件。

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;

【讨论】：

【解决方案4】：

我最后使用的解决方案如下：

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，因为许多组件编辑器希望同时显示。

【讨论】：

【解决方案5】：

在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;

【讨论】：

这并不能修复错误，它只是对用户隐藏它。解决问题而不是隐藏错误会更好。