How to make a list box with Office XP theme like selection rectangle?

Question

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.

Answer 1

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:

Answer 2

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.