Is it possible to add that arrow pointer thing to a String Grind in Delphi 7? You know what I mean, that arrow pointer that you can see at the left in a DBGrid.
Yes, but not automatically. You would need to display a triangle manually. You can override OnDrawCell for your grid. It seems you need to set the FixedCols to 0 since it doesn't appear to redraw the fixed cells again when the row selection changes.
procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
var
aCanvas: TCanvas;
oldColor: TColor;
triangle: array [0..2] of TPoint;
const
spacing = 4;
begin
if (ACol = 0) and (aRow = StringGrid1.Row) then
begin
aCanvas := (Sender as TStringGrid).Canvas; // To avoid with statement
oldColor := aCanvas.Brush.Color;
// Shape the triangle
triangle[0] := TPoint.Create(Rect.Left + spacing, Rect.Top + spacing);
triangle[1] := TPoint.Create(Rect.Left + spacing, Rect.Top + Rect.Height - spacing);
triangle[2] := TPoint.Create(Rect.Left + Rect.Width - spacing, Rect.Top + Rect.Height div 2);
// Draw the triangle
aCanvas.Pen.Color := clBlack;
aCanvas.Brush.Color := clBlack;
aCanvas.Polygon(triangle);
aCanvas.FloodFill(Rect.Left + Rect.Width div 2, Rect.Top + Rect.Height div 2, clBlack, fsSurface);
aCanvas.Brush.Color := oldColor;
end;
end;
This draws a triangle in the box. You should get the general idea.
Not automatically; it's not part of the standard TStringGrid. The "arrow pointer thing" is called the row indicator, and it's a feature added in TDBGrid. It's declared in TDBGridOptions, specifically dgIndicator, as seen below:
TDBGridOption = (dgEditing, dgAlwaysShowEditor, dgTitles, dgIndicator,
dgColumnResize, dgColLines, dgRowLines, dgTabs, dgRowSelect,
dgAlwaysShowSelection, dgConfirmDelete, dgCancelOnExit, dgMultiSelect);
Note that this is different from TGridOption declared in the Grids unit, which does not contain anything similar. (There is no goIndicator or equivalent.)
In order to get the indicator, you'd have to draw it yourself in the OnDrawCell event when you receive a ACol value of 0 with ARow equivalent to the Grid.Row value. There's an example of TStringGrid.OnDrawCell in this answer, although it's demonstrating setting a custom row height and not drawing the row indicator.
Related
I'm trying to draw in each cell of a TGridPanel overriding the Paint event. I get the Rect for each cell through CellRect [Row, Col]. This works until an edge is reported. In this case, even the design in designtime is wrong: the 'ClientRect' of the cells do not correspond to the return of CellRect.
I tried to adjust the rect obtained from CellRect, but it is very complex to consider the displacement rate for each. In the image below, I have a TGripanel with a 3px border and each panel with AlignwithMargins = true, all Margins = 3px.
Has anyone ever experienced this?
Native Paint:
BorderWidth = 3
BorderStyle = bsNone
(each panel is align = alclient and AlignWithMargins = True
My code to get cells 'ClientRect':
procedure TMyCustomGridPanel.paint;
var
Row, Col: Integer;
rctCell: TRect;
function GetColor(C, R: Integer): TColor;
begin
if odd(C + R) then
Result:= clblack
else
Result:= clWhite;
end;
begin
inherited;
for Row := 0 to RowCollection.Count -1 do
begin
for Col := 0 to ColumnCollection.Count -1 do
begin
Canvas.Brush.Color := GetColor(Col, Row);
if Canvas.Brush.Color <> clDefault then
begin
rctCell := CellRect[Col, Row];
{$REGION 'Adjust first col an row'}
if Col = 0 then
rctCell.SetLocation(rctCell.Location.X + BorderWidth, rctCell.Location.Y);
if Row = 0 then
rctCell.SetLocation(rctCell.Location.X, rctCell.Location.Y + BorderWidth);
{$ENDREGION}
{$REGION 'ajust last cells'}
if Col = (ColumnCollection.Count -1) then
begin
if Col > 0 then // tem mais de uma coluna
rctCell.SetLocation(rctCell.Location.X - BorderWidth, rctCell.Location.Y);
rctCell.Right := ClientRect.Right;
end;
if Row = (RowCollection.Count -1) then
begin
if Row > 0 then
rctCell.SetLocation(rctCell.Location.X, rctCell.Location.Y - BorderWidth);
rctCell.Bottom := ClientRect.Bottom;
end;
{$ENDREGION}
Canvas.Pen.Style := psClear;
Canvas.FillRect(rctCell);
end;
end;
end;
end;
Result with my code:
(the panels are just to show that CellRect is not the 'ClientRect' to put a control)
GridPanel
BorderWidth = 10
BorderStyle = bsNone
Color = clmarron
Panels
Align = alClient
Color = clgray
AlignWithMargins = true
Design time rendering of the cell borders (the dotted lines) of a TGridPanel does not take into account the borders of the panel. Thus they do not visually coincide with components you have placed in the grid cells. This is most apparent e.g. with panels of which the Align property is set to alClient.
To know the actual rectangle of a cell, in coordinates of the TGridPanel, you can use OffsetRect to adjust for the border widths.
var
row, col: integer;
r: TRect;
begin
...
r := CellRect[Col, Row];
OffsetRect(r, BorderWidth, BorderWidth);
I have a TLabel with fixed height and word wrap. The problem is that when the caption text exceeds the label's height, I can't see the last lines of text. I search entire internet for label components that can scroll down and show the last lines of text that exceeds the height of caption.
As you can see in this picture, line 7 is half visible and line 8 is not even shown:
I want line 1 to disappear or go up and line 8 be fully visible.
You can override TLabel's DoDrawText virtual method. something like this (example using interposer class):
TLabel = class(StdCtrls.TLabel)
protected
procedure DoDrawText(var Rect: TRect; Flags: Longint); override;
end;
...
procedure TLabel.DoDrawText(var Rect: TRect; Flags: Longint);
var
R: TRect;
TextHeight: Integer;
begin
if (Flags and DT_CALCRECT = 0) then
begin
R := ClientRect;
Canvas.Font := Font;
DrawText(Canvas.Handle, PChar(Text), -1, R, DT_EXPANDTABS or DT_CALCRECT or DT_WORDBREAK);
TextHeight := R.Bottom - R.Top;
if TextHeight > ClientHeight then
Rect.Top := Rect.Top - (TextHeight - ClientHeight);
end;
inherited DoDrawText(Rect, Flags);
end;
You can use TScrollBox :
Drop a TScrollBox.
Drop a TLabel inside the TScrollBox.
Set Label Align to alTop.
I developed an application in Delphi using graphics32 library. It involves adding layers to a ImgView32 control. It does all I want now, except that when the user adds more that 25-30 layers to the ImgView, the selected layer starts behaving badly. I mean,
- when there are 30+ layers on the ImgView32 and I click on a layer, it takes about 2.5-2 seconds to actually select it.
- Also when I try to move the layer, it moves abruptly
It appears that ImgViewChange is called way too many times when there are more layers. Same goes to PaintLayer. It gets called way too many times.
How can I stop that from happening? How can I make the layers move graciously even when there are more that 30 layers added?
My code is as follows:
procedure TMainForm.LayerMouseDown(Sender: TObject; Buttons: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
cronstart:=now;
if Sender <> nil then
begin
Selection := TPositionedLayer(Sender);
end
else
begin
end;
cronstop:=now;
Memo1.Lines.Add('LayerMouseDown:'+FloatToStr((cronstop-cronstart)*secsperDay)+'sec');
end;
procedure TMainForm.AddSpecialLineLayer(tip:string);
var
B: TBitmapLayer;
P: TPoint;
W, H: Single;
begin
B := TBitmapLayer.Create(ImgView.Layers);
with B do
try
Bitmap.SetSize(100,100);
Bitmap.DrawMode := dmBlend;
with ImgView.GetViewportRect do
P := ImgView.ControlToBitmap(GR32.Point((Right + Left) div 2, (Top + Bottom) div 2));
W := Bitmap.Width * 0.5;
H := Bitmap.Height * 0.5;
with ImgView.Bitmap do
Location := GR32.FloatRect(P.X - W, P.Y - H, P.X + W, P.Y + H);
Scaled := True;
OnMouseDown := LayerMouseDown;
B.OnPaint := PaintGeamOrizHandler
except
Free;
raise;
end;
Selection := B;
end;
procedure TMainForm.PaintGeamOrizHandler(Sender: TObject;Buffer: TBitmap32);
var
bmp32:TBitmap32;
R:TRect;
usa2:single;
latime,inaltime,usa:Single;
inaltime2, latime2:single;
begin
cronstart:=now;
if Sender is TBitmapLayer then
with TBitmapLayer(Sender).GetAdjustedLocation do
begin
bmp32:=TBitmap32.Create;
try
R := MakeRect(TBitmapLayer(Sender).GetAdjustedLocation);
bmp32.DrawMode:=dmblend;
bmp32.SetSize(Round(Right-Left), Round(Bottom-Top));
latime:=Round((Right-Left));
inaltime:=Round((Bottom-Top));
usa:=60;
usa2:=usa / 2;
with TLine32.Create do
try
EndStyle := esClosed;
JoinStyle := jsMitered;
inaltime2:=inaltime / 2;
latime2:=latime / 2;
SetPoints([FixedPoint(latime2-usa2,inaltime2), FixedPoint(latime2+usa2,inaltime2)]);
Draw(bmp32, 13, clWhite32);
SetPoints(GetOuterEdge);
Draw(bmp32, 1.5, clBlack32);
SetPoints([FixedPoint(latime2-usa2-3,inaltime2), FixedPoint(latime2-usa2,inaltime2)]);
Draw(bmp32, 5, clBlack32);
SetPoints([FixedPoint(latime2-usa2-3-7,inaltime2), FixedPoint(latime2-usa2-3,inaltime2)]);
Draw(bmp32, 7, clWhite32);
SetPoints(GetOuterEdge);
Draw(bmp32, 1.5, clBlack32);
SetPoints([FixedPoint(latime2+usa2,inaltime2), FixedPoint(latime2+usa2+3,inaltime2)]);
Draw(bmp32, 5, clBlack32);
SetPoints([FixedPoint(latime2+usa2+3+7,inaltime2), FixedPoint(latime2+usa2+3,inaltime2)]);
Draw(bmp32, 7, clWhite32);
SetPoints(GetOuterEdge);
Draw(bmp32, 1.5, clBlack32);
finally
Free;
end;
(Sender as TBitmapLayer).Bitmap.Assign(bmp32);
finally
bmp32.Free;
end;
end;
cronstop:=now;
Memo1.Lines.Add('PaintLayer:'+FloatToStr((cronstop-cronstart)*secsperDay)+'sec');
end;
procedure TMainForm.SetSelection(Value: TPositionedLayer);
begin
if Value<>nil then
begin
if Value <> FSelection then
begin
if RBLayer <> nil then
begin
RBLayer.ChildLayer := nil;
RBLayer.LayerOptions := LOB_NO_UPDATE;
end;
FSelection := Value;
if Value <> nil then
begin
if RBLayer = nil then
begin
RBLayer := TRubberBandLayer.Create(ImgView.Layers);
RBLayer.MinHeight := 1;
RBLayer.MinWidth := 1;
end
else
RBLayer.BringToFront;
RBLayer.ChildLayer := Value;
RBLayer.LayerOptions := LOB_VISIBLE or LOB_MOUSE_EVENTS or LOB_NO_UPDATE;
RBLayer.OnResizing := RBResizing;
end;
end;
end;
end;
procedure TMainForm.RBResizing(Sender: TObject;
const OldLocation: TFloatRect; var NewLocation: TFloatRect;
DragState: TRBDragState; Shift: TShiftState);
var
w, h, cx, cy: Single;
nw, nh: Single;
begin
cronstart:=now;
if DragState = dsMove then Exit; // we are interested only in scale operations
if Shift = [] then Exit; // special processing is not required
if ssCtrl in Shift then
begin
{ make changes symmetrical }
with OldLocation do
begin
cx := (Left + Right) / 2;
cy := (Top + Bottom) / 2;
w := Right - Left;
h := Bottom - Top;
end;
with NewLocation do
begin
nw := w / 2;
nh := h / 2;
case DragState of
dsSizeL: nw := cx - Left;
dsSizeT: nh := cy - Top;
dsSizeR: nw := Right - cx;
dsSizeB: nh := Bottom - cy;
dsSizeTL: begin nw := cx - Left; nh := cy - Top; end;
dsSizeTR: begin nw := Right - cx; nh := cy - Top; end;
dsSizeBL: begin nw := cx - Left; nh := Bottom - cy; end;
dsSizeBR: begin nw := Right - cx; nh := Bottom - cy; end;
end;
if nw < 2 then nw := 2;
if nh < 2 then nh := 2;
Left := cx - nw;
Right := cx + nw;
Top := cy - nh;
Bottom := cy + nh;
end;
end;
cronstop:=now;
Memo1.Lines.Add('RBResizing:'+FloatToStr((cronstop-cronstart)*secsperDay)+'sec');
end;
procedure TMainForm.ImgViewChange(Sender: TObject);
var
wid,hei:Integer;
begin
Edit1.Text:=IntToStr(StrToInt(Edit1.Text)+1);
cronstart:=now;
if Selection = nil then
begin
end
else
begin
wid:=Round(Selection.Location.Right-Selection.Location.Left);
hei:=Round(Selection.Location.Bottom-Selection.Location.Top);
// SelectLayerPan(Selection.Index);
end;
cronstop:=now;
Memo1.Lines.Add('ImgViewChange:'+FloatToStr((cronstop-cronstart)*secsperDay)+'sec');
end;
procedure TMainForm.ImgViewMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
begin
Edit1.Text:='0';
cronstart:=now;
if Layer = nil then
begin
if Assigned(FSelection) then
begin
Selection := nil;
RBLayer.Visible:=false;
end;
end
else
begin
// SelectLayerPan(layer.Index);
end;
cronstop:=now;
Memo1.Lines.Add('imgViewMouseDown:'+FloatToStr((cronstop-cronstart)*secsperDay)+'sec');
end;
procedure TMainForm.ImgViewPaintStage(Sender: TObject; Buffer: TBitmap32;
StageNum: Cardinal);
const //0..1
Colors: array [Boolean] of TColor32 = ($FFFFFFFF, $FFB0B0B0);
var
R: TRect;
I, J: Integer;
OddY: Integer;
TilesHorz, TilesVert: Integer;
TileX, TileY: Integer;
TileHeight, TileWidth: Integer;
begin
TileHeight := 13;
TileWidth := 13;
TilesHorz := Buffer.Width div TileWidth;
TilesVert := Buffer.Height div TileHeight;
TileY := 0;
for J := 0 to TilesVert do
begin
TileX := 0;
OddY := J and $1;
for I := 0 to TilesHorz do
begin
R.Left := TileX;
R.Top := TileY;
R.Right := TileX + TileWidth;
R.Bottom := TileY + TileHeight;
Buffer.FillRectS(R, Colors[I and $1 = OddY]);
Inc(TileX, TileWidth);
end;
Inc(TileY, TileHeight);
end;
end;
procedure TMainForm.Button1Click(Sender: TObject);
begin
Edit1.Text:='0';
MainForm.AddSpecialLineLayer('geams'); //orizontal
end;
So just click the button multiple times (30 times) and you will notice the eratic behaviour once you get to have 25-30 layers added.
(Of course use the base code from the layers example of the library and add the above procedures)
Maybe a solution would be to disable somewhere the ImgViewChange event from firing. But I do not know where to do that... Or maybe I'm wrong.
Please give me a solution for this problem... because I can't think of anything...
EDIT
Here is a screenshot that will explain better:
As you can see in the right side of the imgView, there are 3 editboxes. The first tells us that there are 25 layers added already. The other two are also self-explanatory.
In the left side of the picture you can see the layers drawn there. They are all the same, drawn with the paintHandler from the code. So all the layers are identical
Now consider this scenario: no layer is selected, then I start clicking layers, the first 3 clicks, show me ImgViewChange=52 and Paint=26, for each of them. Then on my fourth click on a layer the values are those in the image displayed here. This does not make any sense.
So ImgViewChanged is called 1952 times and the PaintHandler is called 976 times. There must be a bug somewhere...
Please help me figure this out. take into consideration that those editboxes get filled in the code above. Also in this test project there is no other code that might do this crazy behavior. I wrote this test project with only the code that was neccessary to make it work. So the code is above, the behavior is in the picture.
EDIT
After I added bmp32.BeginUpdate and bmp32.EndUpdate in the PaintHandler method, the number of repaints and imgViewChanges seem to have decreased, but not by much. Now I get ImgViewChange=1552 and PaintHandler=776.
I'm not even sure that it's because my change, because these numbers seem almost random. I mean I have no idea why it happens, who triggers those events for regular number of times, and what happens when they are triggered so many more times?
When I add the layers to the imgView, all 25 of them, I leave them where they are added: in the center of the View. After they are all added, I start click-in on each and I drag them away from the center so they would all be visible.
Now, the first 15-20 layers that I click on and drag from the center, the 2 numbers that I monitor (number of times those two events get fired) is a lot lower that the numbers I get after the 20th layer that I want to drag from the center. And after they are all dispersed in the view, it begins: some layers are click-able in real-time, others take a while to get selected and my count of event-fires are through the roof.
EDIT
I found my problem.
With this I reduced the number of events that get fired to the normal amount. So the solution was to add BeginUpdate and EndUpdate for the Assignment of the layer's bitmap...
So in the PaintHandler I changed the code to:
(Sender as TBitmapLayer).BeginUpdate;
(Sender as TBitmapLayer).Bitmap.Assign(bmp32);
(Sender as TBitmapLayer).EndUpdate;
And now my layers behave like they should. Thank you SilverWarrior for pointing me into the right direction. Please convert your comment into an answer so I can accept it.
The BeginUpdate/EndUpdate are beneficial to reduce the number of ImgViewChange events as documented here
OnChange is an abstract change notification event, which is called by
some of the descendants of TCustomPaintBox32 immediately after changes
have been made to their contents. In TCustomImage32, for example, this
includes redirection of change notification events from the contained
bitmap and from layers. This event, however, is not called by
TCustomPaintBox32 control itself, unless you call the Changed method
explicitly. Change notification may be disabled with BeginUpdate call
and re-enabled with EndUpdate call.
However, there are other problems in your code:
In AddSpecialLineLayer() you create a new TBitmapLayer, set the size and location of its Bitmap and set its OnPaint handler to PaintGeamOrizHandler(). This is not a problem in itself, but it's the first step towards the real problem.
In PaintGeamOrizHandler() the main idea seems to be to draw some shapes, but the way it is done is very time consuming for no benefit.
First you create a new TBitmap32. Then you draw the shapes on this bitmap. Then you assign it to the layers bitmap. Finally you free the bitmap just created.
All of the shape drawing could instead have been done directly to the layers bitmap. The "temporary" bitmap is just a waist of CPU resources.
But another question is, why are the shapes drawn every time the layer needs to be painted? The bitmap of the TBitmapLayer is perfectly capable of retaining the shapes until you specifically need to change them. Instead you could have drawn the shapes in a separate procedure as a one time effort when you created the layer (and/or when you need to change the shapes).
You may also want to explore the documentation for paint stages and perhaps repaint optimizer
I want to disable the gridlines in a drawgrid and draw the grid lines myself for every other columns. Row lines are not needed.
I want to merge two cells in the fixed area so that it looks like as it is one column, like in this picture:
I have added this code to the ondrawcell event of the drawgrid to achieve this:
procedure Tbookings3_Frm.bgridDrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
var
CellIndex: Integer;
s:string;
x:integer;
begin
CellIndex := (ARow * bgrid.ColCount) + ACol;
if gdFixed in State then
begin
bgrid.Canvas.Brush.Color := clskyblue;
end
else if (State * [gdSelected, gdHotTrack]) <> [] then
begin
bgrid.Canvas.Brush.Color := clHighlight;
end
else
begin
bgrid.Canvas.Brush.Color := Cells[CellIndex].BkColor;
end;
bgrid.Canvas.FillRect(Rect);
if gdFixed in State then
Frame3D(bgrid.Canvas, Rect, clHighlight, clBtnShadow, 1);
if gdFocused in State then
bgrid.Canvas.DrawFocusRect(Rect);
//---------------
with (Sender as TDrawGrid).Canvas do
begin
// set font
Font.Color := CLblack;
FillRect(Rect);
if ARow = 2 then
begin
x := (Rect.Right - Rect.Left - TextWidth(days_h[ACol])) div 2;
TextOut(Rect.Left + x, Rect.Top + 2, days_h[ACol]);
end;
if ARow = 1 then
begin
x := (Rect.Right - Rect.Left - TextWidth(sun_mon[ACol])) div 2;
TextOut(Rect.Left + x, Rect.Top + 2, sun_mon[ACol]);
end;
if ARow = 0 then
begin
x := (Rect.Right - Rect.Left - TextWidth(mon[ACol])) div 2;
TextOut(Rect.Left + x, Rect.Top + 2, mon[ACol]);
end;
if (Acol = 0) and (ARow > 2) then
begin
s:=rooms[Arow];
x := (Rect.Right - Rect.Left - TextWidth(s)) div 2;
TextOut(Rect.Left + x, Rect.Top + 2, s);
end;
//-------------------------------------------------
end; //end canvas
//----------------
if gdFocused in State then
bgrid.Canvas.DrawFocusRect(Rect);
end;
You need to disable the grid's native gridlines, and then you can draw your own gridlines surrounding each cell in the OnDrawCell event as needed. The TRect represents the inside area of the cell being drawn, but you can draw outside of that Rect as well. To make two cells appear merged, you would simply not draw a gridline between them.
What would be the most simple and clean way to show a focused/selected listbox item with a Office XP style?
See this sample image to show the idea more clearer:
I think I need to set the Listbox Style to either lbOwnerDrawFixed or lbOwnerDrawVariable and then modify the OnDrawItem event?
This is where I am stuck, I am not really sure what code to write in there, so far I tried:
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
begin
with (Control as TListBox).Canvas do
begin
if odSelected in State then
begin
Brush.Color := $00FCDDC0;
Pen.Color := $00FF9933;
FillRect(Rect);
end;
TextOut(Rect.Left, Rect.Top, TListBox(Control).Items[Index]);
end;
end;
I should of known that would not work, I get all kind of funky things going on:
What am I doing wrong, more importantly what do I need to change to make it work?
Thanks.
You forgot to paint the items for different states. You need to determine in what state the item currently is and according on that draw it.
What you have on your picture you can get this way. However this doesn't looks well if you have enabled multiselect and select more than one item:
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
Offset: Integer;
begin
with (Control as TListBox) do
begin
Canvas.Font.Color := Font.Color;
if (odSelected in State) then
begin
Canvas.Pen.Color := $00FF9932;
Canvas.Brush.Color := $00FDDDC0;
end
else
begin
Canvas.Pen.Color := Color;
Canvas.Brush.Color := Color;
end;
Canvas.Rectangle(Rect);
Canvas.Brush.Style := bsClear;
Offset := (Rect.Bottom - Rect.Top - Canvas.TextHeight(Items[Index])) div 2;
Canvas.TextOut(Rect.Left + Offset + 2, Rect.Top + Offset, Items[Index]);
end;
end;
And the result with ItemHeight set to 16:
Bonus - continuous selection:
Here is a tricky solution implementing a continuous selection. The principle is to draw the item like before but then overdraw the item's border top and bottom lines with the lines of a color depending on selection state of the previous and next item. Except that, must be rendered also outside of the current item, since the item selection doesn't naturally invoke neighbour items to be repainted. Thus the horizontal lines are painted one pixel above and one pixel below the current item bounds (colors of these lines depends also on the relative selection states).
Quite strange here is the use of item objects to store the selected state of each item. I did that, because when using a drag & drop item selection, the Selected property doesn't return the real state until you release the mouse button. Fortunately, the OnDrawItem event of course fires with the real state, so as a workaround I've used storing of these states from the OnDrawItem event.
Important:
Notice, that I'm using the item objects to store the actual selection state, so be careful, and when you're using item objects for something else, store this actual states e.g. into an array of Boolean.
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
const
SelBackColor = $00FDDDC0;
SelBorderColor = $00FF9932;
var
Offset: Integer;
ItemSelected: Boolean;
begin
with (Control as TListBox) do
begin
Items.Objects[Index] := TObject((odSelected in State));
if (odSelected in State) then
begin
Canvas.Pen.Color := SelBorderColor;
Canvas.Brush.Color := SelBackColor;
Canvas.Rectangle(Rect);
end
else
begin
Canvas.Pen.Color := Color;
Canvas.Brush.Color := Color;
Canvas.Rectangle(Rect);
end;
if MultiSelect then
begin
if (Index > 0) then
begin
ItemSelected := Boolean(ListBox1.Items.Objects[Index - 1]);
if ItemSelected then
begin
if (odSelected in State) then
begin
Canvas.Pen.Color := SelBackColor;
Canvas.MoveTo(Rect.Left + 1, Rect.Top);
Canvas.LineTo(Rect.Right - 1, Rect.Top);
end
else
Canvas.Pen.Color := SelBorderColor;
end
else
Canvas.Pen.Color := Color;
Canvas.MoveTo(Rect.Left + 1, Rect.Top - 1);
Canvas.LineTo(Rect.Right - 1, Rect.Top - 1);
end;
if (Index < Items.Count - 1) then
begin
ItemSelected := Boolean(ListBox1.Items.Objects[Index + 1]);
if ItemSelected then
begin
if (odSelected in State) then
begin
Canvas.Pen.Color := SelBackColor;
Canvas.MoveTo(Rect.Left + 1, Rect.Bottom - 1);
Canvas.LineTo(Rect.Right - 1, Rect.Bottom - 1);
end
else
Canvas.Pen.Color := SelBorderColor;
end
else
Canvas.Pen.Color := Color;
Canvas.MoveTo(Rect.Left + 1, Rect.Bottom);
Canvas.LineTo(Rect.Right - 1, Rect.Bottom);
end;
end;
Offset := (Rect.Bottom - Rect.Top - Canvas.TextHeight(Items[Index])) div 2;
Canvas.Brush.Style := bsClear;
Canvas.Font.Color := Font.Color;
Canvas.TextOut(Rect.Left + Offset + 2, Rect.Top + Offset, Items[Index]);
end;
end;
And the result:
You need to look at the value of the State variable that is passed into the function. This tells you if the item is selected or not and you can then set the brush and pen appropriately.