Access violation after TStringEditLink get destroyed (TVirtualStringTree) - Lazarus example

Question

I've try to implement an editor for a VirtualStringTree based on example of Lazarius

Can you tell me why did I get an Access Violation after TStringEditLink gets destroyed?

It's weired that error appear only when i press ESCAPE or ENTER. If i click from one cell to another there is no error.

Like an observation, I sow that if I remove the FEdit.Free code from destructor TStringEditLink.Destroy the error disappear.

Do you have a solution for this?

Bellow the full code:

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.

and the EditorLink unit

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.

fantaghirocco · Answer 1 · 2016-08-06T09:04:37.740

I have no Lazarus but it seems to behave the same on XE4.

In my VST installation, located in ./VirtualTreeviewV5.3.0/Demos/Advanced there is an Editors.pas file where I've found the destructor below. Notice the comment 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;

Moreover, FEdit.Free is performed in the PrepareEdit method before its fresh creation:

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
  . . .

This solves the VK_ESC and the VK_RETURN issues on my XE4 and XE7 installation.

The issue #357 seems to have not been fixed yet: see - Used fix proposed in issue #361 to fix issue #357 (AV in advanced demo - PropertiesDemo form in XE3+). I've found no evidence of the #361 fix.

Another issue happens to me when clicking on a unassigned node after an edit operation.
Checking if the Click.HitNode is not nil before start editing solves the above.

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;

Notice also you have a circular reference in the EditorLink unit:

uses Unit2;

now since i sow your answer, i remember that i sow this code some months ago. i will test it and i will come back with an feed-back. — REALSOFO, Aug 06 '16 at 12:45
it doesn't solve the problem. the control gets destroyed after `FTree` and form get destroyed. it's the same if i don't put `FEdit.Free`. In order to see when the `FEdit` gets destroyed I used a wrapper `TAltComboBox = class(TComboBox); ... procedure WMDestroy(var Msg: TWMDestroy); message WM_DESTROY;` — REALSOFO, Aug 06 '16 at 17:48
Why are you using the quite old V5.3.0? Does the problem still exist in the current V6.3.0? — Joachim Marder, Aug 07 '16 at 21:40

James L. · Answer 2 · 2016-08-08T23:35:08.523

This pseudo stack trace of your code illustrates the issue:

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

The code in the event handler for FEdit.EditKeyDown() frees FEdit before the key down event handler code finishes running. Thus the access violation error.

We handled this by setting up a signal mechanism so the TStringEditLink could signal the main form when it was done, and the main form could run the code to destroy the TStringEditLink (since it is the one that created the TStringEditLink in the first place). We added a TTimer to the main form, and a property to receive the signal. The TTimer watches the property. The TStringEditLink component has a pointer to the form, so it can set the property.

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.

Our code does a lot of additional things, so the above code is a copy/paste of the essential parts to demonstrate how to overcome the race condition. It is untested, but should get you pointed in the right direction.

It doesn't work! I had tried also before with `if assigned(FEdit) then FEdit.Free;`. It;s also interested that if I add a `showmessage('...')` after `inherited`, the error disappear. Maybe it's something with the focus of the node after the editor get's destroyed. — REALSOFO, Aug 06 '16 at 02:11
Perhaps also setting `FEdit` to `nil` would help? Otherwise, it sounds like a race condition. — James L., Aug 06 '16 at 06:44
I think you are right about it being related to the key press. I looked at my code for that part and it is different from yours. I'll edit my answer. — James L., Aug 08 '16 at 21:21

REALSOFO · Answer 3 · 2016-08-12T20:18:02.930

One solution is also to free the previously created controls.

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;

score 0 · Accepted Answer · answered Aug 26 '16 at 05:55

The solution I used at the end is listed bellow:

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 should be used as owner and as parent for as many component editors would like to be displayed in the same time.

score -1 · Answer 5 · answered Aug 07 '16 at 07:57

In HeidiSql source code there is a good example to avoid this error. The code a little changed is:

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;

This doesn't fix the error, it just hides it from the user. It would be better to fix the problem instead of hiding the error. — James L., Aug 08 '16 at 23:11

Access violation after TStringEditLink get destroyed (TVirtualStringTree) - Lazarus example

5 Answers5