I am running Lazarus 0.9.30.
I have a standard TStringGrid on a form and have a function that dynamically adds TGridColumns objects to it at run time. I have a collection of objects that contain all the attributes of each column (that I read out of a file at run time), and I want to associate each object with its corresponding column header.
I have tried the code below but at run time when I try to access the object behind the column header object, I get a 'nil object returned. I suspect the reason this is occurring is that the grid cell (that holds the column title) is blank, and you can't associate objects with grid cells that are empty.
type
TTmColumnTitles = class(TTmCollection)
public
constructor Create;
destructor Destroy; override;
function stGetHint(anIndex : integer) : string;
end;
type
TTmColumnTitle = class(TTmObject)
private
FCaption : string;
FCellWidth : integer;
FCellHeight : integer;
FFontOrientation : integer;
FLayout : TTextLayout;
FAlignment : TAlignment;
FHint : string;
procedure vInitialise;
public
property stCaption : string read FCaption write FCaption;
property iCellWidth : integer read FCellWidth write FCellWidth;
property iCellHeight : integer read FCellHeight write FCellHeight;
property iFontOrientation : integer read FFontOrientation write FFontOrientation;
property Layout : TTextLayout read FLayout write FLayout;
property Alignment : TAlignment read FAlignment write FAlignment;
property stHint : string read FHint write FHint;
constructor Create;
destructor Destroy; override;
end;
procedure TTmMainForm.vLoadGridColumnTitles
(
aGrid : TStringGrid;
aCollection : TTmColumnTitles
);
var
GridColumn : TGridColumn;
aColumnTitle : TTmColumnTitle; //Just a pointer!
anIndex1 : integer;
anIndex2 : integer;
begin
for anIndex1 := 0 to aCollection.Count - 1 do
begin
aColumnTitle := TTmColumnTitle(aCollection.Items[anIndex1]);
GridColumn := aGrid.Columns.Add;
GridColumn.Width := aColumnTitle.iCellWidth;
GridColumn.Title.Font.Orientation := aColumnTitle.iFontOrientation;
GridColumn.Title.Layout := aColumnTitle.Layout;
GridColumn.Title.Alignment := aColumnTitle.Alignment;
GridColumn.Title.Caption := aColumnTitle.stCaption;
aGrid.RowHeights[0] := aColumnTitle.iCellHeight;
aGrid.Objects[anIndex1, 0] := aColumnTitle;
end; {for}
end;
Just assigning an object to the Objects property isn't enough. You have to draw the title caption from that object yourself in an OnDrawCell event handler, or assign the Cells property as well.
and you can't associate objects with grid cells that are empty
Yes you can. The string and the object of one cell 'work' independent of each other.
So it should be:
for anIndex2 := 0 to aGrid.ColCount - 1 do
begin
aColumnTitle := aCollection.Items[anIndex2]; // Is aCollection.Count in sync
// with aGrid.ColCount??
aGrid.Cells[anIndex2, 0] := aColumnTitle.Caption;
aGrid.Objects[anIndex2, 0] := aColumnTitle;
end;
Related
I'm trying to use the InitialDir property of TSelectDirectoryDialog:
procedure selectfolder;
begin
SelectDirectoryDialog1.InitialDir := strPath;
If SelectDirectoryDialog1.Execute then begin
Edit1.Text := SelectDirectoryDialog1.FileName;
end;
end;
The first time (with strPath=X) it works fine, the second time I'm using this procedure (with strPath=Y) it doesn't use the new path (Y), but the one I selected previously.
Do I have to call a method, something like SelectDirectoryDialog1."reinitiate" before I set the InitialDir property a second time? Another idea would be to use a different property then InitialDir, but I don't know which one would do the job. Unfortunately the doc page for TSelectDirectoryDialog is currently down, so I don't have a description for the available methods/properties for TSelectDirectoryDialog and the ones I tested to solve my problem.
I got it to work if I create the TSelectDirectoryDialog class instance manually and don't use the one from the Component Palette to create it "on the form". Then I just destroy the instance and create a new one.
procedure TForm1.Button4Click(Sender: TObject);
var SelectDirectoryDialogManual : TSelectDirectoryDialog;
begin
SelectDirectoryDialogManual := TSelectDirectoryDialog.Create(nil);
SelectDirectoryDialogManual.InitialDir := 'C:\Windows';
if SelectDirectoryDialogManual.Execute then ShowMessage(SelectDirectoryDialogManual.FileName);
SelectDirectoryDialogManual.Free;
end;
But how do I do that when I created SelectDirectoryDialog1 using the component Component Palette?
By saving and restoring the value of InitialDir before each invocation of Execute, or doing what #Sertac says in a comment, which works but is less "self-documenting" imo, ymmv.
The code below works fine for me. edInitialDir is a TEdit which saves the most recent directory selected using SelectDirectoryDialog1, which is then used for the next invocation.
procedure TForm1.Button1Click(Sender: TObject);
begin
SelectDirectoryDialog1.InitialDir := edInitialDir.Text;
if SelectDirectoryDialog1.Execute then
Caption := 'executed'
else
Caption := 'not executed';
edInitialDir.Text := SelectDirectoryDialog1.FileName;
end;
Note: All properties of SelectDirectoryDialog1 are the defaults for an instance freshly added from the Component Palette.
Regarding your comment, TSelectDirectoryDialog.Execute calls TWin32WSSelectDirectoryDialog.CreateHandle (see Dialogs.Pas, line 1219). The initial part of this is as follows:
class function TWin32WSSelectDirectoryDialog.CreateHandle(const ACommonDialog: TCommonDialog): THandle;
var
Options : TOpenOptions;
InitialDir : string;
Buffer : PChar;
bi : TBrowseInfo;
iidl : PItemIDList;
biw : TBROWSEINFOW;
Bufferw : PWideChar absolute Buffer;
InitialDirW: widestring;
Title: widestring;
DirName: string;
begin
DirName := '';
InitialDir := TSelectDirectoryDialog(ACommonDialog).FileName;
Options := TSelectDirectoryDialog(ACommonDialog).Options;
if length(InitialDir)=0 then
InitialDir := TSelectDirectoryDialog(ACommonDialog).InitialDir;
if length(InitialDir)>0 then begin
// remove the \ at the end.
if Copy(InitialDir,length(InitialDir),1)=PathDelim then
InitialDir := copy(InitialDir,1, length(InitialDir)-1);
// if it is a rootdirectory, then the InitialDir must have a \ at the end.
if Copy(InitialDir,length(InitialDir),1)=DriveDelim then
InitialDir := InitialDir + PathDelim;
end;
From this you can see that it initially attempts to derive the value of InitialDir from the FileName property and only if that results in an empty string does it attempt to use the stored value of the InitialDir property. This is why the dialog uses the previously-selected directory the next time Execute is invoked, which is exactly what you should be expecting, even if you do not like it. The only way to re-use the initial value of IntialDir from second and subsequent invocations is to restore it before each one.
I'm kinda a Delphi-newbie and I don't get how the Sort method of a TList of Records is called in order to sort the records by ascending integer value.
I have a record like the following:
type
TMyRecord = record
str1: string;
str2: string;
intVal: integer;
end;
And a generic list of such records:
TListMyRecord = TList<TMyRecord>;
Have tried to find a code-example in the help files and found this one:
MyList.Sort(#CompareNames);
Which I can't use, since it uses classes. So I tried to write my own compare function with a little different parameters:
function CompareIntVal(i1, i2: TMyRecord): Integer;
begin
Result := i1.intVal - i2.intVal;
end;
But the compiler always throws a 'not enough parameters' - error when I call it with open.Sort(CompareIntVal);, which seems obvious; so I tried to stay closer to the help file:
function SortKB(Item1, Item2: Pointer): Integer;
begin
Result:=PMyRecord(Item1)^.intVal - PMyRecord(Item2)^.intVal;
end;
with PMyRecord as PMyRecord = ^TMyRecord;
I have tried different ways of calling a function, always getting some error...
The Sort overload you should be using is this one:
procedure Sort(const AComparer: IComparer<TMyRecord>);
Now, you can create an IComparer<TMyRecord> by calling TComparer<TMyRecord>.Construct. Like this:
var
Comparison: TComparison<TMyRecord>;
....
Comparison :=
function(const Left, Right: TMyRecord): Integer
begin
Result := Left.intVal-Right.intVal;
end;
List.Sort(TComparer<TMyRecord>.Construct(Comparison));
I've written the Comparison function as an anonymous method, but you could also use a plain old style non-OOP function, or a method of an object.
One potential problem with your comparison function is that you may suffer from integer overflow. So you could instead use the default integer comparer.
Comparison :=
function(const Left, Right: TMyRecord): Integer
begin
Result := TComparer<Integer>.Default.Compare(Left.intVal, Right.intVal);
end;
It might be expensive to call TComparer<Integer>.Default repeatedly so you could store it away in a global variable:
var
IntegerComparer: IComparer<Integer>;
....
initialization
IntegerComparer := TComparer<Integer>.Default;
Another option to consider is to pass in the comparer when you create the list. If you only ever sort the list using this ordering then that's more convenient.
List := TList<TMyRecord>.Create(TComparer<TMyRecord>.Construct(Comparison));
And then you can sort the list with
List.Sort;
The concise answer:
uses
.. System.Generics.Defaults // Contains TComparer
myList.Sort(
TComparer<TMyRecord>.Construct(
function(const Left, Right: TMyRecord): Integer
begin
Result := Left.intVal - Right.intVal;
end
)
);
I want to share my solution (based on the input I have gathered here).
It's a standard setup. A filedata class that holds data of a single file in a generic TObjectList. The list has the two private attributes fCurrentSortedColumn and fCurrentSortAscending to control the sort order. The AsString-method is the path and filename combined.
function TFileList.SortByColumn(aColumn: TSortByColums): boolean;
var
Comparison: TComparison<TFileData>;
begin
result := false;
Comparison := nil;
case aColumn of
sbcUnsorted : ;
sbcPathAndName: begin
Comparison := function(const Left, Right: TFileData): integer
begin
Result := TComparer<string>.Default.Compare(Left.AsString,Right.AsString);
end;
end;
sbcSize : begin
Comparison := function(const Left, Right: TFileData): integer
begin
Result := TComparer<int64>.Default.Compare(Left.Size,Right.Size);
if Result = 0 then
Result := TComparer<string>.Default.Compare(Left.AsString,Right.AsString);
end;
end;
sbcDate : begin
Comparison := function(const Left, Right: TFileData): integer
begin
Result := TComparer<TDateTime>.Default.Compare(Left.Date,Right.Date);
if Result = 0 then
Result := TComparer<string>.Default.Compare(Left.AsString,Right.AsString);
end;
end;
sbcState : begin
Comparison := function(const Left, Right: TFileData): integer
begin
Result := TComparer<TFileDataTestResults>.Default.Compare(Left.FileDataResult,Right.FileDataResult);
if Result = 0 then
Result := TComparer<string>.Default.Compare(Left.AsString,Right.AsString);
end;
end;
end;
if assigned(Comparison) then
begin
Sort(TComparer<TFileData>.Construct(Comparison));
// Control the sort order
if fCurrentSortedColumn = aColumn then
fCurrentSortAscending := not fCurrentSortAscending
else begin
fCurrentSortedColumn := aColumn;
fCurrentSortAscending := true;
end;
if not fCurrentSortAscending then
Reverse;
result := true;
end;
end;
I found a much simpler modified sort function to alphabetize a TList of records or nonstandard list of items.
Example
PList = ^TContact;
TContact = record //Record for database of user contact records
firstname1 : string[20];
lastname1 : string[20];
phonemobile : Integer; //Fields in the database for contact info
phonehome : Integer;
street1 : string;
street2 : string;
type
TListSortCompare = function (Item1,
Item2: TContact): Integer;
var
Form1: TForm1;
Contact : PList; //declare record database for contacts
arecord : TContact;
Contacts : TList; //List for the Array of Contacts
function CompareNames(i1, i2: TContact): Integer;
begin
Result := CompareText(i1.lastname1, i2.lastname1) ;
end;
and the function to call to sort your list
Contacts.Sort(#CompareNames);
I have some problem defining the fields of a TmemDataset.
I want to use a memDataset with some files to keep and manipulate the data for a small personal project.
here are the code snipet I use to create the fields :
function createField(fieldName, fieldLabel : String ; fieldType : TFieldType;
group : Integer) : TField;
begin
Result := TField.Create(nil);
Result.FieldName := fieldName;
Result.SetFieldType(fieldType);
Result.FieldKind := fkData;
if fieldLabel = '' then
Result.DisplayLabel := fieldName
else
Result.DisplayLabel := fieldLabel;
result.DataSet := memDataset;
Result.Tag:= group;
end;
The call is quite simple :
createField('FIELDNAME', 'FieldDisplay', ftInteger, 2);
Unfortunately, this does not properly set the field type and compromise the whole data editing afterwards. I get a ftUnknown field type. How can I set the proper type for my fields ?
I was advised of another way of doing things :
procedure createField(fieldName, fieldLabel : String ;
fieldType : TFieldType; group : Integer);
begin
with memDataset do
begin
if fieldType = ftString then
FieldDefs.Add(fieldName, fieldType, 80, False)
else
if fieldType = ftWideString then
FieldDefs.Add(fieldName, fieldType, 512, False)
else
FieldDefs.Add(fieldName, fieldType, 0, False);
if fieldLabel = '' then
FieldDefs.Items[FieldCount].DisplayName := fieldName
else
FieldDefs.Items[FieldCount].DisplayName := fieldLabel;
// No other way
// medCharacter.FieldDefs.Items[FieldCount].Tag := group;
end;
end;
Except I loose some information quite important to my project : the field display name, I found a way to set, but I can't find a way to set the tag.
I am trying to make better use of VHDL protected types, so I threw together the following test (just for illustration, of course - my actual use case is considerably more complex):
type prot_type1 is protected
procedure set (new_data : integer);
impure function get return integer;
end protected prot_type1;
type prot_type1 is protected body
variable data : integer := 0;
procedure set (new_data : integer) is
begin
data := new_data;
end procedure set;
impure function get return integer is
begin
return data;
end function get;
end protected body prot_type1;
This compiles. However, the following line does not:
type prot_type1_array is array (natural range <>) of prot_type1;
Ashenden says (3rd Ed., p. 589) "Protected types cannot be used as elements of ... composite types". This is unfortunate. I was hoping to be able to create another protected type with the body:
type prot_type2 is protected body
variable data : prot_type1_array(0 to 3);
procedure set (idx : natural; new_data : integer) is
begin
data(idx).set(new_data);
end procedure set;
...
end protected body prot_type2;
and avoid duplicating the code in prot_type1.set() (which is admittedly trivial in this case, but would be much more complex in my actual use case). It seems my only choice, though, is (1) to basically rewrite the entirety of prot_type1 except with an array type for my private variable. Or (2), flatten the array internally, like:
type prot_type2 is protected body
variable data0 : prot_type1;
variable data1 : prot_type1;
procedure set (idx : natural; new_data : integer) is
begin
case idx is
when 0 =>
data0.set(new_data);
when 1 =>
data1.set(new_data);
when others =>
-- handle exceptions here
end case;
end procedure set;
...
end protected body prot_type2;
This works, but is mildly undesirable for small arrays, and is extremely undesirable for large arrays. Is there another way?
here is a suggestion based on Morten Zilmer comment. The prot1_type get an access on integer instead of a unique integer. I have used function append, remove and get to manage the integer values.
Here is the code :
type array_int is array (natural range <>) of integer;
type a_integer is access array_int;
type prot_type1 is protected
-- add a new value at the end of the vector
procedure append (new_data : integer);
-- remove a value from the vector, return 0 ik OK, -1 is the item doesn't exist
impure function remove (index : integer) return integer;
-- return the integer value of the item
impure function get(index : integer) return integer;
end protected prot_type1;
type prot_type1 is protected body
variable data : a_integer;
procedure append(new_data : integer) is
variable temp : a_integer;
begin
-- create a temporary vector with the new values
temp := new array_int'(data.all & new_data);
-- free memory of the real vector
Deallocate(data);
-- reallocate the real vector with the good values
data := new array_int'(temp.all);
-- free memory of the temporary vector
Deallocate(temp);
end procedure append;
impure function remove(index : integer) return integer is
variable temp : a_integer;
begin
if (index > data'length-1 or index < 0) then -- not sure if the vector is (0 to length -1) or (1 to length). to be tested !!!
return -1;
else
-- create a temporary vector with the new values
temp := new array_int'(data(0 to index-1) & data(index+1 to data'length-1));
-- free memory of the real vector
Deallocate(data);
-- reallocate the real vector with the good values
data := new array_int'(temp.all);
-- free memory of the temporary vector
Deallocate(temp);
return 0;
end if;
end function remove;
impure function get(index : integer) return integer is
begin
return data(index);
end function get;
end protected body prot_type1;
I have a record that looks similar to:
type
TNote = record
Title : string;
Note : string;
Index : integer;
end;
Simple. The reason I chose to set the variables as string (as opposed to an array of chars) is that I have no idea how long those strings are going to be. They can be 1 char long, 200 or 2000.
Of course when I try to save the record to a type file (file of...) the compiler complains that I have to give a size to string.
Is there a way to overcome this? or a way to save those records to an untyped file and still maintain a sort of searchable way?
Please do not point me to possible solutions, if you know the solution please post code.
Thank you
You can't do it with a typed file. Try something like this, with a TFileStream:
type
TStreamEx = class helper for TStream
public
procedure writeString(const data: string);
function readString: string;
procedure writeInt(data: integer);
function readInt: integer;
end;
function TStreamEx.readString: string;
var
len: integer;
iString: UTF8String;
begin
self.readBuffer(len, 4);
if len > 0 then
begin
setLength(iString, len);
self.ReadBuffer(iString[1], len);
result := string(iString);
end;
end;
procedure TStreamEx.writeString(const data: string);
var
len: cardinal;
oString: UTF8String;
begin
oString := UTF8String(data);
len := length(oString);
self.WriteBuffer(len, 4);
if len > 0 then
self.WriteBuffer(oString[1], len);
end;
function TStreamEx.readInt: integer;
begin
self.readBuffer(result, 4);
end;
procedure TStreamEx.writeInt(data: integer);
begin
self.WriteBuffer(data, 4);
end;
type
TNote = record
Title : string;
Note : string;
Index : integer;
procedure Save(stream: TStream);
end;
procedure TNote.Save(stream: TStream);
var
temp: TMemoryStream;
begin
temp := TMemoryStream.Create;
try
temp.writeString(Title);
temp.writeString(Note);
temp.writeInt(Index);
temp.seek(0, soFromBeginning);
stream.writeInt(temp.size);
stream.copyFrom(temp, temp.size);
finally
temp.Free;
end;
end;
I'll leave the Load procedure to you. Same basic idea, but it shouldn't need a temp stream. With the record size in front of each entry, you can read it and know how far to skip if you're looking for a certain record # instead of reading the whole thing.
EDIT: This was written specifically for versions of Delphi that use Unicode strings. On older versions, you could simplify it quite a bit.
Why not write this out as XML? See my session "Practical XML with Delphi" on how to get started with this.
Another possibility would be to make your records into classes descending form TComponent and store/retreive your data in DFM files.
This Stackoverflow entry shows you how to do that.
--jeroen
PS: Sorry my XML answer was a bit dense; I'm actually on the road for two conferences (BASTA! and DelphiLive! Germany).
Basically what you need to do is very simple: create a sample XML file, then start the Delphi XML Data Binding Wizard (available in Delphi since version 6).
This wizard will generate a unit for you that has the interfaces and classes mapping XML to Delphi objects, and a few helper functions for reading them from file, creating a new object, etc. My session (see the first link above) actually contains most of the details for this process.
The above link is a video demonstrating the usage of the Delphi XML Data Binding Wizard.
You could work with two different files, one that just stores the strings in some convenient way, the other stores the records with a reference to the strings. That way you will still have a file of records for easy access even though you don't know the size of the actual content.
(Sorry no code.)
TNote = record
Title : string;
Note : string;
Index : integer;
end;
could be translated as
TNote = record
Title : string[255];
Note : string[255];
Index : integer;
end;
and use Stream.writebuffer(ANodeVariable, sizeof(TNode), but you said that strings get go over 255 chars in this case IF a string goes over 65535 chars then change WORD to INTEGER
type
TNodeHeader=Record
TitleLen,
NoteLen: Word;
end;
(* this is for writing a TNode *)
procedure saveNodetoStream(theNode: TNode; AStream: TStream);
var
header: TNodeHeader;
pStr: PChar;
begin
...
(* writing to AStream which should be initialized before this *)
Header.TitleLen := Length(theNode.Title);
header.NodeLen := Length(theNode.Note);
AStream.WriteBuffer(Header, sizeof(TNodeHeader);
(* save strings *)
PStr := PChar(theNode.Title);
AStream.writeBuffer(PStr^, Header.TitleLen);
PStr := PChar(theNode.Note);
AStream.writebuffer(PStr^, Header.NoteLen);
(* save index *)
AStream.writebuffer(theNode.Index, sizeof(Integer));
end;
(* this is for reading a TNode *)
function readNode(AStream: TStream): TNode;
var
header: THeader
PStr: PChar;
begin
AStream.ReadBuffer(Header, sizeof(TNodeHeader);
SetLength(Result.Title, Header.TitleLen);
PStr := PChar(Result.Title);
AStream.ReadBuffer(PStr^, Header.TitleLen);
SetLength(Result.Note, Header.NoteLen);
PStr := PChar(Result.Note);
AStream.ReadBuffer(PStr^, Header.NoteLen);
AStream.ReadBuffer(REsult.Index, sizeof(Integer)(* 4 bytes *);
end;
You can use the functions available in this Open Source unit.
It allows you to serialize any record content into binary, including even dynamic arrays within:
type
TNote = record
Title : string;
Note : string;
Index : integer;
end;
var
aSave: TRawByteString;
aNote, aNew: TNote;
begin
// create some content
aNote.Title := 'Title';
aNote.Note := 'Note';
aNote.Index := 10;
// serialize the content
aSave := RecordSave(aNote,TypeInfo(TNote));
// unserialize the content
RecordLoad(aNew,pointer(aSave),TypeInfo(TNote));
// check the content
assert(aNew.Title = 'Title');
assert(aNew.Note = 'Note');
assert(aNew.Index = 10);
end;