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

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.

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;

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.

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;

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.

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;

Related

Lazarus: TListBox.Style:= lbVirtual but no OnData event

From Delphi 6 on it was possible to put millions of lines in the TListBox component via .Style:= lbVirtual and using the OnData event. In Lazarus lbVirtual exists, too, but not the OnData event. I want to extend this component to be able to display millions of lines, but I get errors during compilation.
My problem is that I can't really port code from Delphi to Lazarus when it comes to using lbVirtual in Lazarus, as no OnData event exists.
Delphi 7:
ListBox.Style:= lbVirtual;
property OnData;
ListBox.Count:= // for reading
Lazarus:
ListBox.Style:= lbVirtual; // which behaves like lbStandard
ListBox.Count:= // ReadOnly
In Lazarus I used the property OnData in my new L_Listbox component and ListBox.Count:=. I still don't know if L_ListBox lines will show up like I know it from lbVirtual. Now I get compiler error messages such as
resourcestring
LongInt
I thought I would solve this by appending to uses Math. However, it did not help. All compilation errors pop up in the file: l_listbox.pas
LLB.pas
{ This file was automatically created by Lazarus. Do not edit!
This source is only used to compile and install the package.
}
unit LLB;
{$warn 5023 off : no warning about unused units}
interface
uses
L_ListBox, LazarusPackageIntf;
implementation
procedure Register;
begin
RegisterUnit('L_ListBox', #L_ListBox.Register);
end;
initialization
RegisterPackage('LLB', #Register);
end.
LLB.lpk
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<Package Version="4">
<PathDelim Value="\"/>
<Name Value="LLB"/>
<Type Value="RunAndDesignTime"/>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)\"/>
</SearchPaths>
</CompilerOptions>
<Files Count="1">
<Item1>
<Filename Value="l_listbox.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="L_ListBox"/>
</Item1>
</Files>
<RequiredPkgs Count="2">
<Item1>
<PackageName Value="LCL"/>
</Item1>
<Item2>
<PackageName Value="FCL"/>
</Item2>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
<UseFileFilters Value="True"/>
</PublishOptions>
</Package>
</CONFIG>
l_listbox.pas (see comments where the compiler complains in function TListBoxStrings.GetObject(Index: Integer): TObject;)
unit L_ListBox;
{$mode objfpc}{$H+}
interface
uses Math, StdCtrls, Controls, Classes, Forms, Graphics, Messages, Windows, SysUtils, Commctrl, Types,
LResources, LCLType, LCLIntf, LMessages;
resourcestring
SErrorSettingCount = 'Error setting %s.Count';
SListBoxMustBeVirtual = 'Listbox (%s) style must be virtual in order to set Count';
SListIndexError = 'List %s is invalid';
type
TListBoxStyle = (lbStandard, lbOwnerDrawFixed, lbOwnerDrawVariable, lbVirtual, lbVirtualOwnerDraw);
TLBGetDataEvent = procedure(Control: TWinControl; Index: Integer; var Data: string) of object;
TLBFindDataEvent = function(Control : TWinControl; FindString: string): Integer of object;
TLBGetDataObjectEvent = procedure(Control: TWinControl; Index: Integer; var DataObject: TObject) of object;
TL_ListBox = class(Tlistbox)
private
FCount : Integer;
FStyle : TListBoxStyle;
FOnDataFind : TLBFindDataEvent;
FOnData : TLBGetDataEvent;
FOnDataObject : TLBGetDataObjectEvent;
function GetSelCount : Integer;
function GetCount : Integer;
procedure SetCount(const Value: Integer);
procedure SetStyle(Value: TListBoxStyle);
protected
function DoGetData(const Index: Integer): String;
function DoGetDataObject(const Index: Integer): TObject;
function DoFindData(const Data: String): Integer;
function InternalGetItemData(Index: Integer): Longint; dynamic;
procedure InternalSetItemData(Index: Integer; AData: Longint); dynamic;
function GetItemData(Index: Integer): LongInt; dynamic;
procedure SetItemData(Index: Integer; AData: LongInt); dynamic;
procedure CreateParams(var Params: TCreateParams); override;
public
property SelCount : Integer read GetSelCount;
property Count : Integer read GetCount write SetCount;
published
property OnData : TLBGetDataEvent read FOnData write FOnData;
property OnDataObject : TLBGetDataObjectEvent read FOnDataObject write FOnDataObject;
property OnDataFind : TLBFindDataEvent read FOnDataFind write FOnDataFind;
property Style: TListBoxStyle read FStyle write SetStyle default lbStandard;
end;
procedure Register;
implementation
uses RTLConsts;
procedure Register;
begin
RegisterComponents('ex',[TL_ListBox]);
end;
type
TListBoxStrings = class(TStrings)
private
ListBox: TL_ListBox;
protected
function GetCount: Integer; override;
function GetObject(Index: Integer): TObject; override;
procedure PutObject(Index: Integer; AObject: TObject); override;
public
end;
{ TL_ListBox }
procedure TL_ListBox.CreateParams(var Params: TCreateParams);
const
Styles: array[TListBoxStyle] of DWORD = (0, LBS_OWNERDRAWFIXED, LBS_OWNERDRAWVARIABLE, LBS_OWNERDRAWFIXED, LBS_OWNERDRAWFIXED);
Data: array[Boolean] of DWORD = (LBS_HASSTRINGS, LBS_NODATA);
begin
inherited CreateParams(Params);
CreateSubClass(Params, 'ListBox');
with Params do begin
Style := Style or ({WS_HSCROLL or }WS_VSCROLL or Data[Self.Style in [lbVirtual]] or LBS_NOTIFY) or Styles[FStyle];
end;
end;
function TL_ListBox.DoFindData(const Data: String): Integer;
begin
if Assigned(FOnDataFind) then Result := FOnDataFind(Self, Data) else Result := -1;
end;
function TL_ListBox.DoGetData(const Index: Integer): String;
begin
if Assigned(FOnData) then FOnData(Self, Index, Result);
end;
function TL_ListBox.DoGetDataObject(const Index: Integer): TObject;
begin
if Assigned(FOnDataObject) then FOnDataObject(Self, Index, Result);
end;
function TL_ListBox.GetCount: Integer;
begin
if Style in [lbVirtual] then Result := FCount else Result := Items.Count;
end;
function TL_ListBox.GetItemData(Index: Integer): LongInt;
begin
Result := SendMessage(Handle, LB_GETITEMDATA, Index, 0);
end;
function TL_ListBox.GetSelCount: Integer;
begin
Result := SendMessage(Handle, LB_GETSELCOUNT, 0, 0);
end;
function TL_ListBox.InternalGetItemData(Index: Integer): Longint;
begin
Result := GetItemData(Index);
end;
procedure TL_ListBox.InternalSetItemData(Index, AData: Integer);
begin
SetItemData(Index, AData);
end;
procedure TL_ListBox.SetCount(const Value: Integer);
var
Error: Integer;
begin
if Style in [lbVirtual] then
begin
// Limited to 32767 on Win95/98 as per Win32 SDK
Error := SendMessage(Handle, LB_SETCOUNT, Value, 0);
if (Error <> LB_ERR) and (Error <> LB_ERRSPACE) then FCount := Value else raise Exception.CreateFmt(LoadStr(SErrorSettingCount), [Name]);
end
else raise Exception.CreateFmt(LoadStr(SListBoxMustBeVirtual), [Name]);
end;
procedure TL_ListBox.SetItemData(Index, AData: Integer);
begin
SendMessage(Handle, LB_SETITEMDATA, Index, AData);
end;
procedure TL_ListBox.SetStyle(Value: TListBoxStyle);
begin
if FStyle <> Value then
begin
if Value in [lbVirtual] then
begin
Items.Clear;
Sorted := False;
end;
FStyle := Value;
end;
end;
{ TListBoxStrings }
function TListBoxStrings.GetCount: Integer;
begin
Result := SendMessage(ListBox.Handle, LB_GETCOUNT, 0, 0);
end;
function TListBoxStrings.GetObject(Index: Integer): TObject;
begin
if ListBox.Style in [lbVirtual] then
Result := ListBox.DoGetDataObject(Index)
else
begin
Result := TObject(ListBox.GetItemData(Index)); // Compiler complains here on TObject...
if Longint(Result) = LB_ERR then Error(SListIndexError, Index); // ...and here on Longint
end;
end;
procedure TListBoxStrings.PutObject(Index: Integer; AObject: TObject);
begin
if (Index <> -1) and not (ListBox.Style in [lbVirtual]) then
ListBox.SetItemData(Index, LongInt(AObject));
end;
end.
My Form:
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls,
L_ListBox;
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
L_ListBox1: TL_ListBox;
procedure Button1Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure L_ListBox1Data(Control: TWinControl; Index: Integer;
var Data: string);
private
public
end;
var
Form1: TForm1;
MyList : TStringlist;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.Button1Click(Sender: TObject);
begin
MyList := TStringlist.Create;
L_ListBox1.Style := lbVirtual;
MyList.LoadFromFile('ex.txt');
L_ListBox1.Count := MyList.Count;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
MyList.Free;
end;
procedure TForm1.L_ListBox1Data(Control: TWinControl; Index: Integer;
var Data: string);
begin
Data := MyList[Index];
end;
end.
I corrected the code in L_ListBox.pas
procedure Register;
implementation
uses RTLConsts;
resourcestring
SErrorSettingCount = 'Error setting% s.Count';
SListBoxMustBeVirtual = 'Listbox (% s) style must be virtual in order to set Count';
SListIndexError = 'List% s is invalid';
procedure Register;
begin
RegisterComponents ('ex', [TL_ListBox]);
end;
I am getting an error:
[Debugger Exception Notification]
Project project1 raised exception class 'Exception' with message:
Error setting L_ListBox1.Count
What is the construction in Lazarus ?
since the compiler stops I marked bold
TObject
Longint
Result := TObject(ListBox.GetItemData(Index));
if Longint(Result) = LB_ERR then Error(SListIndexError, Index);

How to get notified when disk free space changes?

I used this code but it doesn't work for SHCNE_FREESPACE, I don't receive any notification if I delete or copy files in the specified folder. Only if I use other flags I receive notifications.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ShlObj, ActiveX;
const
SHCNRF_INTERRUPTLEVEL = $0001;
SHCNRF_SHELLLEVEL = $0002;
SHCNRF_RECURSIVEINTERRUPT = $1000;
SHCNRF_NEWDELIVERY = $8000;
type
TSHChangeNotifyEntry = record
pidl: PItemIdList;
fRecursive: BOOL;
end;
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
procedure OnNotifyEvent(var AMessage:TMessage); message WM_USER;
end;
var
Form1: TForm1;
Hand: THandle;
function SHChangeNotifyRegister(OwnerHwnd:HWND; fSources:Integer; fEvents:DWord; wMsg:UINT;
cEntries:Integer; var pshcne:TSHChangeNotifyEntry):ULONG; stdcall; external 'shell32.dll';
function SHChangeNotifyDeregister(ulID:ULONG):BOOL; stdcall; external 'shell32.dll';
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
var Desktop:IShellFolder;
pidl:PItemIdList;
Path:String;
Eaten,attr,Events,Sources:DWord;
cnPIDL:TSHChangeNotifyEntry;
begin
if Succeeded(SHGetDesktopFolder(Desktop)) then begin
Path:='D:\Test';
if Succeeded(Desktop.ParseDisplayName(0, nil, PWideChar(Path), Eaten, pidl, attr)) then begin
Caption:=Path;
cnPIDL.pidl:=pidl;
cnPIDL.fRecursive:=true;
Sources:=SHCNRF_INTERRUPTLEVEL or SHCNRF_SHELLLEVEL or SHCNRF_NEWDELIVERY or SHCNRF_RECURSIVEINTERRUPT;
Events:=SHCNE_FREESPACE;
Hand:=SHChangeNotifyRegister(Handle, Sources, Events, WM_USER, 1, cnPIDL);;
CoTaskMemFree(pidl);
end;
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
SHChangeNotifyDeregister(Hand);
end;
procedure TForm1.OnNotifyEvent(var AMessage: TMessage);
begin
if AMessage.Msg = WM_USER then Caption:=Caption+' x';
end;
end.
Here's my attempt (written in Delphi 2009):
unit DiskSpace;
interface
uses
Windows, Messages, Classes, ShlObj;
type
PLONG = ^LONG;
LONG = LongInt;
TSpaceChangeEvent = procedure(Sender: TObject; const DiskFree, DiskTotal: Int64) of object;
TDiskSpace = class
strict private
FDiskRoot: string;
FDiskFree: Int64;
FDiskTotal: Int64;
FWndHandle: HWND;
FNotifierID: ULONG;
FOnSpaceChange: TSpaceChangeEvent;
protected
procedure WndProc(var Msg: TMessage); virtual;
procedure DoSpaceChange(const DiskFree, DiskTotal: Int64); virtual;
public
constructor Create(Drive: Char); virtual;
destructor Destroy; override;
property DiskRoot: string read FDiskRoot;
property DiskFree: Int64 read FDiskFree;
property DiskTotal: Int64 read FDiskTotal;
property OnSpaceChange: TSpaceChangeEvent read FOnSpaceChange write FOnSpaceChange;
end;
implementation
const
shell32 = 'shell32.dll';
SHCNRF_InterruptLevel = $0001;
SHCNRF_ShellLevel = $0002;
SHCNRF_RecursiveInterrupt = $1000;
SHCNRF_NewDelivery = $8000;
WM_SHELL_ITEM_NOTIFY = WM_USER + 666;
type
PSHChangeNotifyEntry = ^TSHChangeNotifyEntry;
TSHChangeNotifyEntry = record
pidl: PItemIDList;
fRecursive: BOOL;
end;
procedure ILFree(pidl: PItemIDList); stdcall;
external shell32 name 'ILFree';
function ILCreateFromPath(pszPath: PWideChar): PItemIDList; stdcall;
external shell32 name 'ILCreateFromPathW';
function SHChangeNotifyRegister(hwnd: HWND; fSources: Integer; fEvents: LONG; wMsg: UINT;
cEntries: Integer; pshcne: PSHChangeNotifyEntry): ULONG; stdcall;
external shell32 name 'SHChangeNotifyRegister';
function SHChangeNotifyDeregister(ulID: ULONG): BOOL; stdcall;
external shell32 name 'SHChangeNotifyDeregister';
{ TDiskSpace }
constructor TDiskSpace.Create(Drive: Char);
var
NotifyEntry: TSHChangeNotifyEntry;
begin
FDiskRoot := Drive + ':\';
FWndHandle := AllocateHWnd(WndProc);
NotifyEntry.pidl := ILCreateFromPath(PWideChar(FDiskRoot));
try
NotifyEntry.fRecursive := True;
FNotifierID := SHChangeNotifyRegister(
FWndHandle,
SHCNRF_ShellLevel or SHCNRF_InterruptLevel or SHCNRF_RecursiveInterrupt,
SHCNE_CREATE or SHCNE_DELETE or SHCNE_UPDATEITEM,
WM_SHELL_ITEM_NOTIFY,
1,
#NotifyEntry);
finally
ILFree(NotifyEntry.pidl);
end;
end;
destructor TDiskSpace.Destroy;
begin
if FNotifierID <> 0 then
SHChangeNotifyDeregister(FNotifierID);
if FWndHandle <> 0 then
DeallocateHWnd(FWndHandle);
inherited;
end;
procedure TDiskSpace.WndProc(var Msg: TMessage);
var
NewFree: Int64;
NewTotal: Int64;
begin
if (Msg.Msg = WM_SHELL_ITEM_NOTIFY) then
begin
if GetDiskFreeSpaceEx(PChar(FDiskRoot), NewFree, NewTotal, nil) then
begin
if (FDiskFree <> NewFree) or (FDiskTotal <> NewTotal) then
begin
FDiskFree := NewFree;
FDiskTotal := NewTotal;
DoSpaceChange(FDiskFree, FDiskTotal);
end;
end
else
begin
FDiskFree := -1;
FDiskTotal := -1;
end;
end
else
Msg.Result := DefWindowProc(FWndHandle, Msg.Msg, Msg.wParam, Msg.lParam);
end;
procedure TDiskSpace.DoSpaceChange(const DiskFree, DiskTotal: Int64);
begin
if Assigned(FOnSpaceChange) then
FOnSpaceChange(Self, DiskFree, DiskTotal);
end;
end.
And a possible usage:
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
FDiskSpace: TDiskSpace;
procedure DiskSpaceChange(Sender: TObject; const DiskFree, DiskTotal: Int64);
end;
implementation
procedure TForm1.FormCreate(Sender: TObject);
begin
FDiskSpace := TDiskSpace.Create('C');
FDiskSpace.OnSpaceChange := DiskSpaceChange;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FDiskSpace.Free;
end;
procedure TForm1.DiskSpaceChange(Sender: TObject; const DiskFree, DiskTotal: Int64);
begin
Caption := Format('%d/%d B', [DiskFree, DiskTotal]);
end;

TList descendant with another otbject?

I need to impliment a TList descendant of controls + an extra object.
something like:
List.Add(AControl, AObject)
So The List will hold both AControl, AObject
What is the best way of doing this with Delphi 7?
You can store a list of records, then you can put whatever you want into the record, eg:
type
PMyRecord = ^MyRecord;
MyRecord = record
Control: TControl;
Object: TObject;
end;
var
Rec: PMyRecord;
begin
New(Rec);
try
Rec.Control := AControl;
Rec.Object := AObject;
List.Add(Rec);
except
Dispose(Rec);
Raise;
end;
end;
var
Rec: PMyRecord;
begin
Rec := PMyRecord(List[SomeIndex]);
// use Rec.Control and Rec.Object as needed...
end;
Don't forget to Dispose() an item when you remove it from the list:
var
Rec: PMyRecord;
begin
Rec := PMyRecord(List[SomeIndex]);
List.Delete(SomeIndex);
Dispose(Rec);
end;
And also when you are finished using the list, or at least when you Clear() it:
var
I: Integer;
Rec: PMyRecord;
begin
for I := o to List.Count-1 do
Dispose(PMyRecord(List[I]));
//...
end;
If you derive a new class from TList, you can override its virtual Notify() method to dispose items:
type
TMyList = class(TList)
protected
function Get(Index: Integer): PMyRecord;
procedure Notify(Ptr: Pointer; Action: TListNotification); override;
public
function Add(AControl: TControl; AObject: TObject): Integer;
procedure Insert(Index: Integer; AControl: TControl; AObject: TObject);
property Items[Index: Integer]: PMyRecord read Get; default;
end;
function TMyList.Add(AControl: TControl; AObject: TObject): Integer;
var
Rec: PMyRecord;
begin
New(Rec);
try
Rec.Control := AControl;
Rec.Object := AObject;
Result := inherited Add(Rec);
except
Dispose(Rec);
Raise;
end;
end;
procedure TMyList.Insert(Index: Integer; AControl: TControl; AObject: TObject);
var
Rec: PMyRecord;
begin
New(Rec);
try
Rec.Control := AControl;
Rec.Object := AObject;
inherited Insert(Index, Rec);
except
Dispose(Rec);
Raise;
end;
end;
function TMyList.Get(Index: Integer): PMyRecord;
begin
Result := PMyRecord(inherited Get(Index));
end;
procedure TMyList.Notify(Ptr: Pointer; Action: TListNotification);
begin
inherited;
if Action = lnDeleted then
Dispose(PMyRecord(Ptr));
end;
try this
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
TMyContainer = class
public
ctnGen: TControl;
objGen: TObject;
constructor Create(const ctnGen: TControl; const objGen: TObject);
end;
var
Form1: TForm1;
implementation
uses
Contnrs;
{$R *.DFM}
{ TMyContainer }
constructor TMyContainer.Create(const ctnGen: TControl;
const objGen: TObject);
begin
inherited Create();
Self.ctnGen := ctnGen;
Self.objGen := objGen;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
lstGen: TObjectList;
begin
lstGen := TObjectList.Create(True);
try
lstGen.Add(TMyContainer.Create(Self, Self));
ShowMessage(TMyContainer(lstGen.Items[0]).objGen.ClassName);
finally
lstGen.Free;
end;
end;
TObjectList will free the TMyContainer class

Error when you change the order of columns in Dbgrid

I wrote the code for the form rendering settings database table Dbgrid in another form. It depends on the selected items are defined Chetsklistboks visible columns in Dbgrid. I also wrote the code to move with drag & drop items and columns Chetsklistbox Dbgrid conformity. But start at some point (and in my opinion with an attempt to change the item with the lowest index in the item with a large index) errors when drag & drop from the Argument out of range and when you close the Invalid Pointer Operation. Help resolve the error.
unit SettingOfShowData;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.CheckLst, Vcl.ExtCtrls,
VirtualTrees, DatabaseClasses, MainForm, ListOfTables;
type
TNodeField=record
NameField : string;
end;
PNodeField=^TNodeField;
type
TfmSettings = class(TForm)
Panel1: TPanel;
VT: TVirtualStringTree;
Edit1: TEdit;
Edit2: TEdit;
Edit3: TEdit;
CheckListBox1: TCheckListBox;
procedure VTGetNodeDataSize(Sender: TBaseVirtualTree;
var NodeDataSize: Integer);
procedure VTGetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);
procedure FormCreate(Sender: TObject);
procedure VTFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode);
procedure FormActivate(Sender: TObject);
function IsPrimaryKey(InputTableName : string; InputFieldName : string) : Boolean;
procedure VTNodeClick(Sender: TBaseVirtualTree; const HitInfo: THitInfo);
procedure VTNodeDblClick(Sender: TBaseVirtualTree; const HitInfo: THitInfo);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure CheckListBox1ClickCheck(Sender: TObject);
procedure CheckListBox1DragDrop(Sender, Source: TObject; X, Y: Integer);
procedure CheckListBox1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
procedure CheckListBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
public
{ Public declarations }
end;
var
fmSettings: TfmSettings;
NumX, NumY : Integer;
implementation
{$R *.dfm}
procedure TfmSettings.CheckListBox1ClickCheck(Sender: TObject);
begin
fmShowData.DBGrid1.Columns[CheckListBox1.ItemIndex].Visible :=
not(fmShowData.DBGrid1.Columns[CheckListBox1.ItemIndex].Visible);
end;
procedure TfmSettings.CheckListBox1DragDrop(Sender, Source: TObject; X,
Y: Integer);
var
Num1, Num2, temp: Integer;
Point1, Point2: TPoint;
begin
Point1.X:=NumX;
Point1.Y:=NumY;
Point2.X:=X;
Point2.Y:=Y;
with Source as TCheckListBox do
begin
Num2:=CheckListBox1.ItemAtPos(Point1,True);
Num1:=CheckListBox1.ItemAtPos(Point2,True);
CheckListBox1.Items.Move(Num2, Num1);
if Num2>Num1 then
begin
temp:=Num2;
Num2:=Num1;
Num1:=temp;
end;
fmShowData.DBGrid1.Columns[Num1].Index:=Num2;
fmShowData.DBGrid1.Columns[Num2+1].Index:=Num1;
end;
end;
procedure TfmSettings.CheckListBox1DragOver(Sender, Source: TObject; X,
Y: Integer; State: TDragState; var Accept: Boolean);
begin
if Source=CheckListBox1 then Accept:=True;
end;
procedure TfmSettings.CheckListBox1MouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
NumY:=Y;
NumX:=X;
end;
procedure TfmSettings.FormActivate(Sender: TObject);
var
Index, i: Integer;
VTNodeField : PNodeField;
begin
VT.BeginUpdate();
//TableSpec:=TTableSpec(DBSchema.Tables.FindComponent(fmListOfTables.DisplayTable));
for Index := 0 to TTableSpec(DBSchema.Tables.FindComponent(fmListOfTables.DisplayTable)).Fields.ComponentCount-1 do
begin
if TTableSpec(DBSchema.Tables.FindComponent(fmListOfTables.DisplayTable)).Fields.Components[Index] is TFieldSpec then
begin
VTNodeField:=VT.GetNodeData(VT.AddChild(nil, nil));
VTNodeField^.NameField:=(TTableSpec(DBSchema.Tables.FindComponent(fmListOfTables.DisplayTable)).Fields.Components[Index] as TFieldSpec).name;
end;
end;
VT.EndUpdate();
for i := 0 to TTableSpec(DBSchema.Tables.FindComponent(fmListOfTables.DisplayTable)).Fields.ComponentCount-1 do
begin
if (TTableSpec(DBSchema.Tables.FindComponent(fmListOfTables.DisplayTable)).Fields.Components[i] is TFieldSpec) then
begin
CheckListBox1.Items.Add(TTableSpec(DBSchema.Tables.FindComponent(fmListOfTables.DisplayTable)).Fields.Components[i].Name);
CheckListBox1.Checked[i]:=true;
end;
end;
end;
procedure TfmSettings.FormClose(Sender: TObject; var Action: TCloseAction);
var i: integer;
begin
{ while VT.ComponentCount>0 do
begin
VT.DeleteNode(VT.Nodes.GetEnumerator.Current);
VT.DeleteChildren(VT.Nodes.GetEnumerator.Current);
VT.Nodes.GetEnumerator.MoveNext();
end; }
VT.Clear();
//fmTableData.DBGrid1.Columns
CheckListBox1.Clear;
end;
procedure TfmSettings.FormCreate(Sender: TObject);
var
Index: Integer;
VTNodeField : PNodeField;
//TableSpec : TTableSpec;
begin
{ VT.BeginUpdate();
//TableSpec:=TTableSpec(DBSchema.Tables.FindComponent(fmListOfTables.DisplayTable));
for Index := 0 to TTableSpec(DBSchema.Tables.FindComponent(fmListOfTables.DisplayTable)).ComponentCount-1 do
begin
if TTableSpec(DBSchema.Tables.FindComponent(fmListOfTables.DisplayTable)).Components[Index] is TFieldSpec then
begin
VTNodeField:=VT.GetNodeData(VT.AddChild(nil, nil));
VTNodeField.NameField:=(TTableSpec(DBSchema.Tables.FindComponent(fmListOfTables.DisplayTable)).Components[Index] as TFieldSpec).FieldName;
end;
end;
VT.EndUpdate();}
end;
procedure TfmSettings.VTFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode);
var
Data: PNodeField;
begin
Data:=Sender.GetNodeData(Node);
if Assigned(Data) then
begin
Finalize(Data^);
end;
end;
procedure TfmSettings.VTGetNodeDataSize(Sender: TBaseVirtualTree;
var NodeDataSize: Integer);
begin
NodeDataSize:=SizeOf(TNodeField);
end;
procedure TfmSettings.VTGetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);
var
Index: Integer;
VTNodeField : PNodeField;
begin
VTNodeField:=Sender.GetNodeData(Node);
for Index := 0 to DBSchema.Tables.FindComponent(fmListOfTables.DisplayTable).ComponentCount-1 do
begin
if DBSchema.Tables.FindComponent(fmListOfTables.DisplayTable).Components[Index] is TFieldSpec then
begin
VTNodeField:=Sender.GetNodeData(Sender.AddChild(nil, nil));
VTNodeField^.NameField:=(DBSchema.Tables.FindComponent(fmListOfTables.DisplayTable).Components[Index] as TFieldSpec).name;
end;
end;
CellText:=VTNodeField^.NameField;
end;
procedure TfmSettings.VTNodeClick(Sender: TBaseVirtualTree;
const HitInfo: THitInfo);
var
NewVTNodeField : PNodeField;
NewNode : PVirtualNode;
begin
{NewNode:=VT.AddChild(VT.FocusedNode);
NewVTNodeField:=VT.GetNodeData(NewNode); }
end;
procedure TfmSettings.VTNodeDblClick(Sender: TBaseVirtualTree;
const HitInfo: THitInfo);
var
NewVTNodeField, CurrentNode: PNodeField;
NewNode : PVirtualNode;
//CurrentNode : PDataNode;
i, j : integer;
begin
{ NewNode:=VT.AddChild(VT.FocusedNode);
NewVTNodeField:=VT.GetNodeData(NewNode); }
CurrentNode:=VT.GetNodeData(VT.FocusedNode);
if IsPrimaryKey(fmListOfTables.DisplayTable, {VT.Text[VT.FocusedNode, 0]} CurrentNode^.NameField) then
begin
for i:= 0 to DBSchema.Tables.ComponentCount-1 do
for j:=0 to TTableSpec(DBSchema.Tables.Components[i]).Constraints.ComponentCount-1 do
begin
if (TConstraintSpec(TTableSpec(DBSchema.Tables.Components[i]).Constraints.Components[j]).Reference=fmListOfTables.DisplayTable) then
begin
NewNode:=VT.AddChild(VT.FocusedNode);
NewVTNodeField:=VT.GetNodeData(NewNode);
NewVTNodeField^.NameField:=(TTableSpec(DBSchema.Tables.Components[i])).Name;
end;
end;
end;
end;
function TfmSettings.IsPrimaryKey(InputTableName : string; InputFieldName: string):Boolean;
var
i : integer;
flag: boolean;
begin
flag:=False;
for i:=0 to TTableSpec(DBSchema.Tables.FindComponent(InputTableName)).Constraints.ComponentCount-1 do
begin
if ((TConstraintSpec(TTableSpec(DBSchema.Tables.FindComponent(InputTableName)).Constraints.Components[i]).ConstraintType='PRIMARY') and (TFieldSpec(TConstraintDetailSpec(TConstraintSpec(TTableSpec(DBSchema.Tables.FindComponent(InputTableName)).Constraints.Components[i]).DetailList).FieldSpec).FieldName=InputFieldName){(TTableSpec(DBSchema.Tables.FindComponent(InputTableName)).Fields.FindComponent(InputFieldName).Name=TConstraintDetailSpec(TConstraintSpec(TTableSpec(DBSchema.Tables.FindComponent(InputTableName)).Constraints.Components[i]).DetailList).FieldName)}) then
flag:=True;
Edit1.Text:=TConstraintSpec(TTableSpec(DBSchema.Tables.FindComponent(InputTableName)).Constraints.Components[i]).Name;
Edit2.Text:=AnsiToUtf8(TFieldSpec(TConstraintDetailSpec(TConstraintSpec(TTableSpec(DBSchema.Tables.FindComponent(InputTableName)).Constraints.Components[i]).DetailList).FieldSpec).FieldName);
Edit3.Text:=InputFieldName;
end;
Result:=flag;
end;
end.
Select the code of procedure that changes the order of the columns
procedure TfmSettings.CheckListBox1DragDrop(Sender, Source: TObject; X,
Y: Integer);
var
Num1, Num2, temp: Integer;
Point1, Point2: TPoint;
begin
Point1.X:=NumX;
Point1.Y:=NumY;
Point2.X:=X;
Point2.Y:=Y;
with Source as TCheckListBox do
begin
Num2:=CheckListBox1.ItemAtPos(Point1,True);
Num1:=CheckListBox1.ItemAtPos(Point2,True);
CheckListBox1.Items.Move(Num2, Num1);
if Num2>Num1 then
begin
temp:=Num2;
Num2:=Num1;
Num1:=temp;
end;
fmShowData.DBGrid1.Columns[Num1].Index:=Num2;
fmShowData.DBGrid1.Columns[Num2+1].Index:=Num1;
end;
end;
If then checklistbox is a representation of the fields the corresponding Action for
CheckListBox1.Items.Move(Num2, Num1);
would be
DBGrid1.Columns[num2].Index := DBGrid1.Columns[num1].Index;
nothing more or less.
// Removed comment thx to jachguate

Delphi - ListView or similar with owner draw button

How do I do create a listview (or similar) with a button on each line? The button needs to be able to have different text/color on each line as required.
I'm sure Virtual Treeview would be perfect for this, but I'm a little lost with it.
Thanks
-Brad
With a virtualtreeview...... add vstButton to your uses and select your Virtualtreeview in the object inspector and set the following events for your tree:
procedure TForm1.VSTCreateEditor(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; out EditLink: IVTEditLink);
begin
EditLink:=TStringEditLink.Create;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
VST.NodeDataSize := SizeOf(TTreeData);
AddRandomNodesToTree(Vst);
end;
procedure TForm1.VSTFreeNode(Sender: TBaseVirtualTree;
Node: PVirtualNode);
var
Data: PTreeData;
begin
Data:=VST.GetNodeData(Node);
if Assigned(Data) then begin
Data^.Column0 := '';
Data^.Column1 := '';
Data^.Column2 := '';
end;
end;
procedure TForm1.VSTGetText(Sender: TBaseVirtualTree;
Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;
var CellText: string);
var
Data: PTreeData;
begin
Data := VST.GetNodeData(Node);
case Column of
0: CellText := Data^.Column0;
1: CellText := Data^.Column1;
2: CellText := Data^.Column2;
end;
end;
procedure TForm1.VSTNewText(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; NewText: string);
Var
Data: PTreeData;
begin
Data := VST.GetNodeData(Node);
Case Column of
0: Data^.Column0:= NewText;
1: Data^.Column1:= NewText;
2: Data^.Column2:= NewText;
End;
end;
procedure TForm1.VSTPaintText(Sender: TBaseVirtualTree;
const TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;
TextType: TVSTTextType);
Var
Data: PTreeData;
begin
if Odd(Node.Index) then
TargetCanvas.Font.Color:= clRed;
end;
... this assumes the record is:
type
PTreeData = ^TTreeData;
TTreeData = record
Column0: String;
Column1: String;
Column2: String;
end;
...add the following unit:
unit vstButton;
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, VirtualTrees,
messages, windows, StdCtrls, ShlObj;
type
TStringEditLink = class(TInterfacedObject, IVTEditLink)
private
FEdit: TWinControl;
FTree: TVirtualStringTree;
FNode: PVirtualNode;
FColumn: Integer;
FSelectedFolder: string;
protected
procedure ButtonClick(Sender: TObject);
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;
function GetFolderDialog(Handle: Integer; Caption: string; var strFolder: string): Boolean;
implementation
destructor TStringEditLink.Destroy;
begin
FEdit.Free;
inherited;
end;
procedure TStringEditLink.ButtonClick(Sender: TObject);
var
s: string;
begin
s := 'c:\';
if GetFolderDialog(Application.Handle, 'Select a folder', s) then
FSelectedFolder := s;
FTree.EndEditNode;
FTree.setfocus;
end;
function TStringEditLink.BeginEdit: Boolean;
begin
Result := True;
FSelectedFolder := FTree.Text[FNode, FColumn];
TButton(FEdit).CAption := FTree.Text[FNode, FColumn];
FEdit.Show;
FEdit.SetFocus;
end;
function TStringEditLink.CancelEdit: Boolean;
begin
Result := True;
FEdit.Hide;
FTree.EndEditNode;
FTree.setfocus;
end;
function TStringEditLink.EndEdit: Boolean;
var
S: WideString;
begin
Result := True;
FTree.Text[FNode, FColumn] := FSelectedFolder;
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;
begin
Result := True;
FTree := Tree as TVirtualStringTree;
FNode := Node;
FColumn := Column;
FEdit.Free;
FEdit := nil;
FEdit := TButton.Create(nil);
with FEdit as TButton do
begin
Visible := False;
Parent := Tree;
Font.Color := FTree.Colors.HeaderHotColor;
OnClick := ButtonClick;
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;
//------------------------------------------------------------------------------\\
function BrowseCallbackProc(hwnd: HWND; uMsg: UINT; lParam: LPARAM; lpData: LPARAM): Integer; stdcall;
begin
if (uMsg = BFFM_INITIALIZED) then
SendMessage(hwnd, BFFM_SETSELECTION, 1, lpData);
BrowseCallbackProc := 0;
end;
function GetFolderDialog(Handle: Integer; Caption: string; var strFolder: string): Boolean;
const
BIF_STATUSTEXT = $0004;
BIF_NEWDIALOGSTYLE = $0040;
BIF_RETURNONLYFSDIRS = $0080;
BIF_SHAREABLE = $0100;
BIF_USENEWUI = BIF_EDITBOX or BIF_NEWDIALOGSTYLE;
var
BrowseInfo: TBrowseInfo;
ItemIDList: PItemIDList;
JtemIDList: PItemIDList;
Path: PChar;
begin
Result := False;
Path := StrAlloc(MAX_PATH);
SHGetSpecialFolderLocation(Handle, CSIDL_DRIVES, JtemIDList);
with BrowseInfo do
begin
hwndOwner := GetActiveWindow;
pidlRoot := JtemIDList;
SHGetSpecialFolderLocation(hwndOwner, CSIDL_DRIVES, JtemIDList);
{ return display name of item selected }
pszDisplayName := StrAlloc(MAX_PATH);
{ set the title of dialog }
lpszTitle := PChar(Caption);//'Select the folder';
{ flags that control the return stuff }
lpfn := #BrowseCallbackProc;
{ extra info that's passed back in callbacks }
lParam := LongInt(PChar(strFolder));
end;
ItemIDList := SHBrowseForFolder(BrowseInfo);
if (ItemIDList <> nil) then
if SHGetPathFromIDList(ItemIDList, Path) then
begin
strFolder := Path;
Result := True
end;
end;
End.
the above code is based upon code found at this website:
http://wiki.freepascal.org/VirtualTreeview_Example_for_Lazarus
If you look at the unit vstButton, to get a TEdit, or TCombo...etc... just replace any TButton reference with TEdit or TCombo etc... adjust events for it etc... The above link code actually uses a TCombo
that website helped me alot to learn how to use the virtualtreeview
the above code will insert a Tbutton into every cell, and when you click on the button it will open a BrowseForFolder dialog and insert the result back into the virtualtreeview cell
Hope this helps
did you want a button visible in a cell column all the time? Could simulate the button with an image... like a dropdown mark on one side of the cell

Resources