How to make a ListBox item a given color? - delphi

I have a number of files in a directory, where each file has two lines, line 1 is the string that I want to put into my ListBox, and line 2 is the background color that I want that ListBox item to have (represented as an 8-digit hex value).
The contents of each file looks like this:
string
14603481
This is my code so far:
for i := 0 to PathList.Count - 1 do
begin
FileLines := TStringList.Create;
try
FileLines.LoadFromFile(PathList.Strings[i]);
s := FileLines[0]; { Loads string to add to ListBox1 }
RGBColor := FileLines[1];
finally
FileLines.Free;
end;
ListBox1.Items.AddObject(s, TObject(RGBColor)); { This code doesn't work, but hopefully you get what I'm }
end; { trying to do }
All other examples that do anything similar to this declare the color in the DrawItem procedure, but I need to set the color from within this for loop, since each entry will have a unique color.
How do I set the color of each item uniquely from within this loop?

The VCL's TListBox does not natively support any kind of per-item coloring. The TListBox.Font and TListBox.Color properties apply to all items equally.
To do what you are asking for, you will have to set the TListBox.Style property to lbOwnerDrawFixed and then use the TListBox.OnDrawItem event to custom-draw the items manually however you want, eg:
var
...
s: string;
RGBColor: Integer;
begin
...
for i := 0 to PathList.Count - 1 do
begin
FileLines := TStringList.Create;
try
FileLines.LoadFromFile(PathList[i]);
s := FileLines[0];
RGBColor := StrToInt(FileLines[1]);
finally
FileLines.Free;
end;
ListBox1.Items.AddObject(s, TObject(RGBColor));
end;
...
end;
...
procedure TMyForm.ListBox1DrawItem(Control: TWinControl;
Index: Integer; const Rect: TRect; State: TOwnerDrawState);
var
LB: TListBox;
begin
LB := TListBox(Control);
if odSelected in State then
begin
LB.Canvas.Brush.Color := clHighlight;
LB.Canvas.Font.Color := clHighlightText;
end else
begin
LB.Canvas.Brush.Color := TColor(Integer(LB.Items.Objects[Index]));
LB.Canvas.Font.Color := LB.Font.Color;
end;
LB.Canvas.FillRect(Rect);
LB.Canvas.TextRect(Rect, Rect.Left + 2, Rect.Top + 2, LB.Items[Index]);
if (odFocused in State) and not (odNoFocusRect in State) then
LB.Canvas.DrawFocusRect(Rect);
end;

Related

ListBoxItem Visible Error

There is something that I didn't understand with TListBox and TListBoxItem in Delphi 10.2 Tokyo.
Some values (TListBoxItem) are load to my ListBox, when the first letter change I add a TListBoxGroupHeader.
procedure TForm1.Button1Click(Sender: TObject);
var
lbItem: TListBoxItem;
Letter: string;
ListBoxGroupHeader: TListBoxGroupHeader;
i: integer;
ListValue: TStringList;
begin
Letter := '';
ListValue := TStringList.Create;
try
ListValue.Add('Germany');
ListValue.Add('Georgie');
ListValue.Add('France');
ListValue.Add('Venezuela');
ListValue.Add('Poland');
ListValue.Add('Russia');
ListValue.Add('Sweden');
ListValue.Add('Denmark');
ListBox1.BeginUpdate;
for i := 0 to ListValue.Count - 1 do
begin
if Letter <> Copy(ListValue[i], 0, 1).ToUpper then
begin
ListBoxGroupHeader := TListBoxGroupHeader.Create(ListBox1);
ListBoxGroupHeader.Text := Copy(ListValue[i], 0, 1).ToUpper;
ListBox1.AddObject(ListBoxGroupHeader);
end;
lbItem := TListBoxItem.Create(ListBox1);
lbItem.Text := ListValue[i];
lbItem.Tag := i;
ListBox1.AddObject(lbItem);
Letter := Copy(ListValue[i], 0, 1).ToUpper;
end;
finally
ListBox1.EndUpdate;
FreeAndNil(ListValue);
end;
end;
I use a TEdit to search in this ListBox. That's here that I have a problem. If ListBoxItem contain the content of the Edit I set Visible to True, else I set it to False.
procedure TForm1.Edit1ChangeTracking(Sender: TObject);
var
i : integer;
ListBoxItem: TListBoxItem;
begin
ListBox1.BeginUpdate;
try
for i := 0 to ListBox1.Items.Count - 1 do
begin
if ListBox1.ListItems[i] is TListBoxItem then
begin
ListBoxItem := TListBoxItem(ListBox1.ListItems[i]);
if Edit1.Text.Trim = '' then
begin
ListBoxItem.Visible := True
end
else
begin
if ListBox1.ListItems[i] is TListBoxGroupHeader then
ListBoxItem.Visible := False
else
ListBoxItem.Visible := ListBoxItem.Text.ToLower.Contains(Edit1.Text.Trim.ToLower);
end;
end;
end;
finally
ListBox1.EndUpdate;
end;
end;
The first GroupHeader (letter G) is always visible ! and it's look like there is a ListBoxItem behind the GroupHeader.. When I use a checkpoint Visible is set to false .. so I didn't understand..
If I write the letter "V" I only see the GroupHeader with letter "G".
I have evene try to change the text value if it's a GroupHeader.
if ListBox1.ListItems[i] is TListBoxGroupHeader then
ListBoxItem.Text := '>>' + ListBoxItem.Text + '<<'
Thats change text but not for the first GroupHeader (letter G) ...
Don't know if I use it bad, or if it's a bug ??
I could have reproduce what you've described and it has something to do with hiding header whilst keeping item under that header visible. In such case application shows header rather than the item. I haven't checked what's wrong inside but it seems it is not what you want. IMHO you want to keep visible items that match to a search text with their respective header and hide only headers with no items under.
If that is so, try this:
procedure FilterItems(const Text: string; ListBox: TListBox);
var
I: Integer; { ← loop variable }
Hide: Boolean; { ← flag indicating if we want to hide the last header we passed }
Item: TListBoxItem; { ← currently iterated item }
Head: TListBoxGroupHeader; { ← last header item we passed during iteration }
begin
Head := nil;
Hide := True;
ListBox.BeginUpdate;
try
{ if search text is empty, show all items }
if Text.IsEmpty then
for I := 0 to ListBox.Content.ControlsCount - 1 do
ListBox.ListItems[I].Visible := True
else
{ otherwise compare text in non header items }
begin
for I := 0 to ListBox.Content.ControlsCount - 1 do
begin
Item := ListBox.ListItems[I];
{ if the iterated item is header }
if Item is TListBoxGroupHeader then
begin
{ set the previous header visibility by at least one visible item }
if Assigned(Head) then
Head.Visible := not Hide;
{ assume hiding this header and store its reference }
Hide := True;
Head := TListBoxGroupHeader(Item);
end
else
{ if the iterated item is a regular item }
if Item is TListBoxItem then
begin
{ set the item visibility by matching text; if the item remains visible, it
means we don't want to hide the header, so set our flag variable as well }
if Item.Text.ToLower.Contains(Text) then
begin
Hide := False;
Item.Visible := True;
end
else
Item.Visible := False;
end;
end;
{ the iteration finished, so now setup visibility of the last header we passed }
if Assigned(Head) then
Head.Visible := not Hide;
end;
finally
ListBox.EndUpdate;
end;
end;
procedure TForm1.Edit1ChangeTracking(Sender: TObject);
begin
FilterItems(Edit1.Text.Trim.ToLower, ListBox1);
end;

How to get the number of displayed lines in TMemo?

I need to get the number of displayed lines in TMemo (this include the lines that was wrapped because WordWrap is set to true). I need this to auto adjust the height of the Tmemo to it's content.
lines.count of course don't care about wrapped lines so i can't use it. strangely TextPosToPos also don't care about wrapped lines so i can't use it too ...
I m under firemonkey and delphi Berlin
Edit after I learned about ContentsBounds. My original (and obsolete) answer is still visible in the revisions.
Why do you need the number of displayed lines to adjust the height of the TMemo? This resizes the TMemo to its content:
Memo1.Height := Memo1.ContentBounds.Height + 5; // Small const to allow for rendering margins
It also takes word-wrap into consideration.
I don't know why using ContentBounds is "not really ideal". Here's how I do it:
uses
FMX.TextLayout, FMX.Graphics;
function MeasureTextHeight(const AFont: TFont; const AText: string): Single;
var
LLayout: TTextLayout;
begin
LLayout := TTextLayoutManager.DefaultTextLayout.Create;
try
LLayout.BeginUpdate;
try
LLayout.WordWrap := False;
LLayout.Font.Assign(AFont);
LLayout.Text := AText;
finally
LLayout.EndUpdate;
end;
Result := LLayout.TextHeight;
finally
LLayout.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
LTextHeight: Single;
LLines: Integer;
begin
LTextHeight := MeasureTextHeight(Memo1.TextSettings.Font, Memo1.Text);
LLines := Round(Memo1.ContentBounds.Height / LTextHeight);
end;
This is the rough way i use to calculate the number of lines an TMemo (styled) under firemonkey :
type
_TStyledMemoProtectedAccess = class(TStyledMemo);
procedure TALStyledMemo.OnApplyStyleLookupImpl(sender: Tobject);
Var I, j, k, l: integer;
begin
// TALStyledMemo
// TStyledMemo
// TLayout
// TActiveStyleObject
// TLayout
// TScrollBar
// TScrollBar
// TLayout
// TSmallScrollBar
// TSmallScrollBar
// TScrollContent
for I := 0 to controls.Count - 1 do begin
if (controls[i] is TStyledMemo) then begin // << TStyledMemo
fStyledMemo := TStyledMemo(controls[i]);
end;
end;
end;
function TALStyledMemo.getLineHeight: Single;
begin
if fStyledMemo <> nil then result := _TStyledMemoProtectedAccess(fStyledMemo).GetLineHeight
else result := 0;
end;
function TALStyledMemo.getLineCount: integer;
var aLineHeight: Single;
begin
aLineHeight := getLineHeight;
if compareValue(aLineHeight, 0, Tepsilon.Position) > 0 then result := round(ContentBounds.Height / aLineHeight)
else result := 0;
end;

Updating field in cxGrid acting strange

I have a function to update a cxGrid made with help from answers to Loop through records on a cxgrid and update a field/column
But it is sometimes acting a bit strange. If I open the form with the cxGrid and click the columnheader without doing anything else, the records are updateted OK. But if the 'selectorbar' is moved away from the top, the record marked is not updated.
I am sure it is a property that needs to be changed, but which one.
The variable fSelected is set to False at FormShow and is ther so that the user can unselect records as well.
procedure TfrmContactsSelect.colContactSelectedHeaderClick(Sender: TObject);
var
i: Integer;
Index: Integer;
BookMark : TBookMark;
Contact: variant;
begin
if fMulti = True then
begin
Screen.Cursor := crHourGlass;
fSelected := not fSelected;
BookMark := qryContacts.GetBookmark;
qryContacts.DisableControls;
try
for i := 0 to grdContactsView1.DataController.FilteredRecordCount - 1 do
begin
Index := grdContactsView1.DataController.FilteredRecordIndex[i];
Contact := grdContactsView1.DataController.Values[Index, 4];
if grdContactsView1.DataController.LocateByKey(Contact) then
begin
qryContacts.Edit;
qryContacts.FieldByName('fldcontact_selected').AsBoolean := fSelected;
qryContacts.Post;
end;
end;
finally
qryContacts.EnableControls;
qryContacts.GotoBookmark(BookMark);
qryContacts.FreeBookmark(BookMark);
end;
Screen.Cursor := crDefault;
end;
end;
Delphi XE7, DevExpress 14.2.2, UniDAC 5.5.12 for DB access
Comment:
I have ended up with the following solution based on the answer and input from MartynA
procedure TfrmContactsSelect.colContactSelectedHeaderClick(Sender: TObject);
var
i: Integer;
Index: Integer;
MarkedRecord: variant;
CurrentRecord: variant;
begin
if fMulti = True then
begin
Screen.Cursor := crHourGlass;
fSelected := not fSelected;
Index := grdContactsView1.DataController.FocusedRecordIndex;
MarkedRecord := grdContactsView1.DataController.Values[Index, colContactGuid.ID];
try
for i := 0 to grdContactsView1.DataController.FilteredRecordCount - 1 do
begin
Index := grdContactsView1.DataController.FilteredRecordIndex[i];
CurrentRecord := grdContactsView1.DataController.Values[Index, colContactGuid.ID];
if grdContactsView1.DataController.LocateByKey(CurrentRecord) then
begin
grdContactsView1.DataController.Edit;
grdContactsView1.DataController.SetEditValue(colContactSelected.ID, fSelected, evsText);
grdContactsView1.DataController.Post;
end;
end;
finally
grdContactsView1.DataController.LocateByKey(MarkedRecord);
end;
Screen.Cursor := crDefault;
end;
end;
I can reproduce your problem using the sample project I posted in my answer to your other q.
Try this: Add a TMemo to your form, and inside the 'if grdContactsView1.DataController.LocateByKey(Contact) then' block, write the value of a row-unique datafield and the Selected datafield value to the memo.
Then, what I get when some row other than the top row is selected is that one row is listed twice in the memo, with Selected both false and true, and one of the rows in the filter isn't listed at all, which I think accounts for the behaviour you're seeing. If I then comment out the .Edit .. .Post lines, it correctly lists all the rows in the filter.
So evidently doing the Selected field changes inside a block which iterated the FilteredRecordIndex property of the DBTableView is what's causing the problem.
Personally, I find that it goes a bit against the grain to modify dataset rows in code via a DB-aware control (because you usually end up fighting the DB-awareness of the control), but in this case, it's straightforward to do the processing via the DBTableView of the cxGrid.
procedure TForm1.ProcessFilteredRecords;
var
PrevV,
V : Variant;
i,
Index: Integer;
S : String;
begin
// First, pick up a reference to the current record
// so that we can return to it afterwards
Index := cxGrid1DBTableView1.DataController.FocusedRecordIndex;
PrevV := cxGrid1DBTableView1.DataController.Values[Index, 0];
try
for i := 0 to cxGrid1DBTableView1.DataController.FilteredRecordCount - 1 do begin
Index := cxGrid1DBTableView1.DataController.FilteredRecordIndex[i];
V := cxGrid1DBTableView1.DataController.Values[Index, 0];
if cxGrid1DBTableView1.DataController.LocateByKey(V) then begin
cxGrid1DBTableView1.DataController.Edit;
// 2 is the index of my Selected column in the grid
if cxGrid1DBTableView1.DataController.SetEditValue(2, True, evsText) then
Caption := 'OK'
else
Caption := 'Failed';
cxGrid1DBTableView1.DataController.Post;
end;
end;
finally
if cxGrid1DBTableView1.DataController.LocateByKey(PrevV) then
Caption := 'OK'
else
Caption := 'Failed';
end;
end;
Another way to avoid the problem is to change the Selected states in two steps:
Iterate the FilteredRecordIndex to build a list of rows to change - in your case this would be a list of guids
Then, iterate the list of rows and update their Selected states.
Code:
procedure TForm1.ProcessFilteredRecords;
var
V : Variant;
i,
Index: Integer;
BM : TBookMark;
S : String;
TL : TStringList;
begin
Memo1.Lines.Clear;
TL := TStringList.Create;
try
for i := 0 to cxGrid1DBTableView1.DataController.FilteredRecordCount - 1 do begin
Index := cxGrid1DBTableView1.DataController.FilteredRecordIndex[i];
V := cxGrid1DBTableView1.DataController.Values[Index, 0];
if cxGrid1DBTableView1.DataController.LocateByKey(V) then begin
if CDS1.FieldByName('Selected').AsBoolean then
S := 'True'
else
S := 'False';
S := CDS1.FieldByName('Name').AsString + ' ' + S;
Memo1.Lines.Add(S);
TL.Add(CDS1.FieldByName('Guid').AsString);
end;
end;
try
BM := CDS1.GetBookMark;
CDS1.DisableControls;
for i := 0 to TL.Count - 1 do begin
if CDS1.Locate('guid', TL[i], []) then begin
CDS1.Edit;
CDS1.FieldByName('Selected').AsBoolean := True;
CDS1.Post;
end
end;
finally
CDS1.EnableControls;
CDS1.GotoBookmark(BM);
CDS1.FreeBookmark(BM);
end;
finally
TL.Free;
end;
end;
Like you, I was expecting that changing a property or two of the cxGrid might avoid the problem without any code, but I haven't been able to find anything which does.

How to do incremental search in delphi FM2?

Hi i am having a problem with incremental search in delphi.
I Have looked at this http://delphi.about.com/od/vclusing/a/lb_incremental.htm
But this doesn't work in firemonkey so i came up with this :
for I := 0 to lstbxMapList.Items.Count-1 do
begin
if lstbxMapList.Items[i] = edtSearch.Text then
begin
lstbxMapList.ItemByIndex(i).Visible := True;
end;
if lstbxMapList.Items[I] <> edtSearch.Text then
begin
lstbxMapList.ItemByIndex(i).Visible := False;
end;
end;
When i use this the listbox is just blank.
You're hiding every item that doesn't exactly match edtSearch.Text. Try this instead (tested in XE3):
// Add StrUtils to your uses clause for `StartsText`
uses
StrUtils;
procedure TForm1.edtSearchChange(Sender: TObject);
var
i: Integer;
NewIndex: Integer;
begin
NewIndex := -1;
for i := 0 to lstBxMapList.Items.Count - 1 do
if StartsText(Edit1.Text, lstBxMapList.Items[i]) then
begin
NewIndex := i;
Break;
end;
// Set to matching index if found, or -1 if not
lstBxMapList.ItemIndex := NewIndex;
end;
Following from Kens answer, if you want to hide items as per your question, just set the Visible property but note that since the expression of an if statement returns a boolean and Visible is a boolean property it's possible to greatly simplify things. Note also that I've also used ContainsText which will match the string anywhere in the item text:
procedure TForm1.edtSearchChange(Sender: TObject);
var
Item: TListBoxItem;
begin
for Item in lstbxMapList.ListItems do
Item.Visible := ContainsText(Item.Text.ToLower, Edit1.Text.ToLower);
end;

Delphi: Shift-Up and Shift-Down in the Listview

Is there a feature in the Listview control to shift items up and down?
Not having worked with TListView very much (I mostly use database grids), I took your question as a chance to learn something. The following code is the result, it is more visually oriented that David's answer. It has some limitations: it will only move the first selected item, and while it moves the item, the display for vsIcon and vsSmallIcon is strange after the move.
procedure TForm1.btnDownClick(Sender: TObject);
var
Index: integer;
temp : TListItem;
begin
// use a button that cannot get focus, such as TSpeedButton
if ListView1.Focused then
if ListView1.SelCount>0 then
begin
Index := ListView1.Selected.Index;
if Index<ListView1.Items.Count then
begin
temp := ListView1.Items.Insert(Index+2);
temp.Assign(ListView1.Items.Item[Index]);
ListView1.Items.Delete(Index);
// fix display so moved item is selected/focused
ListView1.Selected := temp;
ListView1.ItemFocused := temp;
end;
end;
end;
procedure TForm1.btnUpClick(Sender: TObject);
var
Index: integer;
temp : TListItem;
begin
// use a button that cannot get focus, such as TSpeedButton
if ListView1.Focused then
if ListView1.SelCount>0 then
begin
Index := ListView1.Selected.Index;
if Index>0 then
begin
temp := ListView1.Items.Insert(Index-1);
temp.Assign(ListView1.Items.Item[Index+1]);
ListView1.Items.Delete(Index+1);
// fix display so moved item is selected/focused
ListView1.Selected := temp;
ListView1.ItemFocused := temp;
end;
end;
end;
You have two options:
Delete them and then re-insert them at the new location.
Use a virtual list view and move them in your data structure.
My routine for doing the first of these options is like this:
procedure TBatchTaskList.MoveTasks(const Source: array of TListItem; Target: TListItem);
var
i, InsertIndex: Integer;
begin
Assert(IsMainThread);
BeginUpdate;
Try
//work out where to move them
if Assigned(Target) then begin
InsertIndex := FListItems.IndexOf(Target);
end else begin
InsertIndex := FListItems.Count;
end;
//create new items for each moved task
for i := 0 to high(Source) do begin
SetListItemValues(
FListItems.Insert(InsertIndex+i),
TBatchTask(Source[i].Data)
);
Source[i].Data := nil;//handover ownership to the new item
end;
//set selection and focus item to give feedback about the move
for i := 0 to high(Source) do begin
FListItems[InsertIndex+i].Selected := Source[i].Selected;
end;
FBatchList.ItemFocused := FListItems[InsertIndex];
//delete the duplicate source tasks
for i := 0 to high(Source) do begin
Source[i].Delete;
end;
Finally
EndUpdate;
End;
end;
The method SetListItemValues is used to populate the columns of the list view.
This is a perfect example of why virtual controls are so great.

Resources