ListBox got a new face
(Code Listing)

Khaled Shagrouni, May 31, 2001

Download the sample project: xlist.zip (15 KB)

Code listing:

 
unit fXList;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    Image1: TImage;
    Label1: TLabel;
    procedure ListBox1DrawItem(Control: TWinControl; Index: Integer;
      Rect: TRect; State: TOwnerDrawState);
    procedure ListBox1MeasureItem(Control: TWinControl; Index: Integer;
      var Height: Integer);
    procedure ListBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FormResize(Sender: TObject);

  private

  public

  end;

procedure ListBoxDrawItem(Control: TWinControl; Index: Integer;
  ARect: TRect; State: TOwnerDrawState; Image: TBitmap );
procedure ListBoxMeasureItem(Control: TWinControl; Index: Integer;
  var Height: Integer; Image: TBitmap);
procedure ListBoxMouseMove(Sender: TObject; Shift: TShiftState;
  X, Y: integer; Image: TBitmap);
procedure ListBoxRefresh(Control: TWinControl; Image: TBitmap);

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
  Rect: TRect; State: TOwnerDrawState);
begin
  ListBoxDrawItem(Control, Index, Rect, State, Image1.Picture.Bitmap );
end;

procedure TForm1.ListBox1MeasureItem(Control: TWinControl;
  Index: Integer;
  var Height: Integer);
begin
  ListBoxMeasureItem(Control, Index, Height, Image1.Picture.Bitmap);
end;

procedure TForm1.ListBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  ListBoxMouseMove(Sender, Shift, X, Y, Image1.Picture.Bitmap);
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  ListBoxRefresh (ListBox1, Image1.Picture.Bitmap);
end;

procedure ListBoxDrawItem(Control: TWinControl; Index: Integer;
  ARect: TRect; State: TOwnerDrawState; Image: TBitmap);
var
  s: string;
  R: Trect;
  lst: TlistBox;
  Ident: integer;
  sOption: integer;
begin
  if Index = -1 then exit;

  lst:= TlistBox(Control);

  if lst.Style = lbStandard then exit;

  R := ARect;
  if R.Top > lst.Height then exit;

  S := lst.Items[Index];
  sOption := 0;
  case lst.BiDiMode of
    bdLeftToRight: sOption := 0;
    bdRightToLeft: sOption := DT_RIGHT + DT_RTLREADING;
    bdRightToLeftNoAlign: sOption := DT_RTLREADING;
    bdRightToLeftReadingOnly: sOption := DT_RTLREADING;
  end;

  if lst.Style = lbOwnerDrawVariable then
    sOption := sOption + DT_WORDBREAK + DT_EDITCONTROL ;


  if Image <> nil then
    Ident := Image.Width + 4
  else
    Ident := 2;

  if lst.BiDiMode = bdRightToLeft then
    Dec(R.Right, Ident)
  else
    Inc(R.Left, Ident);

  lst.Canvas.Font := lst.Font ;
  lst.Canvas.Brush.Color := lst.color;

  if odSelected in state then
    begin
      lst.Canvas.Font.Color := clWhite;
      lst.Canvas.Brush.Color := $00E7A66B;
    end;

  if (odFocused in state) and (odSelected in state) then
    begin
      lst.Canvas.Brush.Color := $00C4500B;
      lst.Canvas.Font.Color := clWhite;
    end;



  if not (odDefault in state) then
    lst.Canvas.FillRect (Arect)
  else
    lst.Canvas.FillRect (R);

  Drawtext(lst.Canvas.Handle, PChar(s), length(s), R, sOption);


  R := ARect;
  if lst.BiDiMode = bdRightToLeft then
    R.Left := R.Right - Ident + 2
  else
    Inc(R.Left,  2);

  R.Right := R.Left + Image.Width;
  if not (odDefault in state) then
    lst.Canvas.Draw (R.Left, R.top + 1, Image);

end;

procedure ListBoxMouseMove(Sender: TObject; Shift: TShiftState;
 X, Y: integer; Image: TBitmap);
var
  APoint: TPoint;
  Index: integer;
  lst: TListBox;

  s: string;
  R: Trect;
  Ident: integer;
  sOption: integer;
  X1,X2: integer;

begin

  lst:= TlistBox(Sender);
  if lst.Style = lbStandard then exit;

  X1 := 0;   // just to stop editor hint nagging.
  X2 := 0;

  if Image <> nil then
    Ident := Image.Width + 2
  else
    Ident := 2;

  APoint.X := X;
  APoint.Y := Y;
  Index := lst.ItemAtPos(APoint, True);

  R := lst.ItemRect(Index);

  if Index <> -1 then
    begin
      X2 := lst.Canvas.TextWidth (lst.Items[Index]);
      if lst.BiDiMode = bdRightToLeft then
        X1 := r.Right - X2 - Image.Width - 4
      else
        X1 := r.Left + Image.Width + 4;

      X2 := X1 + X2;
    end;



  if (ssLeft in Shift) then exit;

  if (x < X1) or (x > X2) then
    begin
      lst.Cursor := crDefault;
      if Index = lst.ItemIndex then exit;
      if lst.Tag = lst.ItemIndex then exit;
        if lst.Tag <> -1 then
          begin
            if lst.Selected[lst.Tag] then
              ListBoxDrawItem(lst, lst.Tag, lst.ItemRect(lst.Tag),
                              [odSelected], Image)
            else
              ListBoxDrawItem(lst, lst.Tag, lst.ItemRect(lst.Tag),
                              [odDefault], Image);
             lst.Tag := -1;
          end;

      exit;
    end;

  if (lst.Tag = Index) and (lst.Cursor = crHandPoint) then
    exit; // Drawn before

  lst.Cursor := crHandPoint;

  sOption := 0;
  case lst.BiDiMode of
    bdLeftToRight: sOption := 0;
    bdRightToLeft: sOption := DT_RIGHT + DT_RTLREADING;
    bdRightToLeftNoAlign: sOption := DT_RTLREADING;
    bdRightToLeftReadingOnly: sOption := DT_RTLREADING;
  end;

  if lst.Style = lbOwnerDrawVariable then
    sOption := sOption + DT_WORDBREAK + DT_EDITCONTROL;


  if lst.ItemIndex <> Index then
    begin
      R := lst.ItemRect(Index);

      S := lst.Items[Index];

      if lst.BiDiMode = bdRightToLeft then
        Dec(R.Right, Ident + 2)
      else
        Inc(R.Left, Ident + 2);

      if lst.Selected[Index] then
        lst.Canvas.Font.Color := clWhite
      else
        lst.Canvas.Font.Color := clBlue;
      lst.Canvas.Font.Style  := lst.Font.Style + [fsUnderLine];

      SetBkModE(lst.Canvas.Handle, TRANSPARENT);
      Drawtext(lst.Canvas.Handle, PChar(s), length(s), R, sOption);

    end;

    if not (ssMiddle in Shift) and
           (lst.Tag <> -1) and
           (lst.Tag <> Index) and
           (lst.Tag <> lst.ItemIndex) then   //What? Do you need more?
        if lst.Selected[lst.Tag] then
           ListBoxDrawItem(lst, lst.Tag, lst.ItemRect(lst.Tag),
                           [odSelected], Image)
         else
           ListBoxDrawItem(lst, lst.Tag, lst.ItemRect(lst.Tag),
                           [odDefault], Image);


  lst.Tag := Index;

end;

procedure ListBoxRefresh(Control: TWinControl; Image: TBitmap);
var
  lst: TListBox;
  i, Count, H: integer;
begin
  lst := TListBox(Control);
  if lst.Style = lbStandard then exit;
  if lst.Style = lbOwnerDrawFixed then
    Count := 1
  else
    Count := lst.Items.Count - 1;
  for i := 0 to Count - 1 do
    begin
      ListBoxMeasureItem(lst, i, H, Image);
      lst.Perform (LB_SETITEMHEIGHT, i, MAKELPARAM(H, 0));
    end;

  lst.refresh;

end;

procedure ListBoxMeasureItem(Control: TWinControl; Index: Integer;
  var Height: Integer; Image: TBitmap );
var
  s: string;
  lst: TListBox;
  R: TRect;
  sOption: integer;
begin
   lst := TListBox(Control);
   if lst.Style = lbStandard then exit;
   sOption := 0;
   case lst.Style of
     lbStandard:
       begin
         Height := lst.ItemHeight;
         exit;
       end;
     lbOwnerDrawFixed: sOption := 0;
     lbOwnerDrawVariable: sOption := DT_WORDBREAK;
   end;
   R := lst.ClientRect;

   Dec(R.Right, Image.width + 4 );
   S := lst.Items[Index];
   lst.Canvas.Font.Assign(lst.Font);
   Height := DrawTextEx(lst.Canvas.Handle,
                        PChar(s),
                        length(s),
                        R,
                        sOption or DT_CALCRECT or DT_EXTERNALLEADING,
                        nil);

   Inc(Height, 4);
   if (Image.Height + 2) > Height then
     Height := Image.Height + 2;
end;

end.