Bitmap вместо фона в TListBox

interface 

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

type 
  TBitmapListBox = class(TCustomListBox) 
  private 
    FBitmap : TBitmap; 

    procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); 
        message WM_ERASEBKGND; 
    procedure WMHScroll(var Message : TWMCommand); 
        message WM_HSCROLL; 
    procedure WMVScroll(var Message : TWMCommand); 
        message WM_VSCROLL; 
    procedure WMKeyDown(var Message : TWMCommand); 
        message WM_KEYDOWN; 
  protected 
    procedure DrawItem(Index: Integer; Rect: TRect; 
      State: TOwnerDrawState); override; 
  public 
    constructor Create(AComponent : TComponent); override; 
    destructor Destroy; override; 
  published 
    property Align; 
    property Anchors; 
    property BiDiMode; 
    property BorderStyle; 
    property Color; 
    property Columns; 
    property Constraints; 
    property Ctl3D; 
    property DragCursor; 
    property DragKind; 
    property DragMode; 
    property Enabled; 
    property ExtendedSelect; 
    property Font; 
    property ImeMode; 
    property ImeName; 
    property IntegralHeight; 
    property ItemHeight; 
    property Items; 
    property MultiSelect; 
    property ParentBiDiMode; 
    property ParentColor; 
    property ParentCtl3D; 
    property ParentFont; 
    property ParentShowHint; 
    property PopupMenu; 
    property ShowHint; 
    property Sorted; 
    property TabOrder; 
    property TabStop; 
    property TabWidth; 
    property Visible; 
    property OnClick; 
    property OnDblClick; 
    property OnDragDrop; 
    property OnDragOver; 
    property OnDrawItem; 
    property OnEndDock; 
    property OnEndDrag; 
    property OnEnter; 
    property OnExit; 
    property OnKeyDown; 
    property OnKeyPress; 
    property OnKeyUp; 
    property OnMeasureItem; 
    property OnMouseDown; 
    property OnMouseMove; 
    property OnMouseUp; 
    property OnStartDock; 
    property OnStartDrag; 
  end; 

  TForm1 = class(TForm) 
    procedure FormCreate(Sender: TObject); 
  private 
    tblb : TBitmapListBox; 
    { Private declarations } 
  public 
    { Public declarations } 
  end; 

var 
  Form1: TForm1; 

implementation 

{$R *.DFM} 

{ TBitmapListBox } 

constructor TBitmapListBox.Create(AComponent: TComponent); 
var 
  FileStream : TFileStream; 
begin 
  inherited; 
  FileStream := TFileStream.Create('c:\TEMP\RANDOMNN.BMP', fmOpenRead); 
  FBitmap := TBitmap.Create; 
  FBitmap.LoadFromStream(FileStream); 
  FileStream.Free; 
  Style := lbOwnerDrawFixed; 
end; 

destructor TBitmapListBox.Destroy; 
begin 
  FBitmap.Free; 
  inherited; 
end; 

// Blt picture to the listbox background 
procedure TBitmapListBox.WMEraseBkgnd(
    var Message: TWmEraseBkgnd); 
begin 
  BitBlt(Message.DC, 0, 0, Width, Height, 
      FBitmap.Canvas.Handle, 0, 0, SRCCOPY); 
end; 

// Called to draw an item 
procedure TBitmapListBox.DrawItem(Index: Integer; Rect: TRect; 
  State: TOwnerDrawState); 
var 
  Flags: Longint; 
begin 
  // Put code in here to allow owner drawing of items 
  BitBlt(Canvas.Handle, Rect.Left, Rect.Top, Rect.Right - Rect.Left, 
      Rect.Bottom - Rect.Top, FBitmap.Canvas.Handle, Rect.Left, 
  Rect.Top, SRCCOPY); 


    if Index < Items.Count then 
    begin 
      Flags := DrawTextBiDiModeFlags(DT_SINGLELINE or DT_VCENTER); 
      if not UseRightToLeftAlignment then 
        Inc(Rect.Left, 2) 
      else 
        Dec(Rect.Right, 2); 
      Canvas.Brush.Style := bsClear; 
      DrawText(Canvas.Handle, PChar(Items[Index]), 
          Length(Items[Index]), Rect, 
        Flags); 
    end; 
end; 

// Override to force a repaint of the entire control, otherwise 
// the bitmap gets corrupte 
procedure TBitmapListBox.WMHScroll(var Message: TWMCommand); 
begin 
  LockWindowUpdate(Self.Handle); 
  inherited; 
  Invalidate; 
  LockWindowUpdate(0); 
end; 

// Override to force a repaint of the entire control, otherwise 
// the bitmap gets corrupte 
procedure TBitmapListBox.WMVScroll(var Message: TWMCommand); 
begin 
  LockWindowUpdate(Self.Handle); 
  inherited; 
  Invalidate; 
  LockWindowUpdate(0); 
end; 

// Override to force a repaint of the entire control, otherwise 
// the bitmap gets corrupt (only when a scroll happens) 
procedure TBitmapListBox.WMKeyDown(var Message: TWMCommand); 
var 
  OldTop : integer; 
begin 
  OldTop := TopIndex; 
  LockWindowUpdate(Self.Handle); 
  inherited; 
// Should be able to figure out a better way of only invalidating when 
// necessary, but I wasn't able to figure out the case when a user hits a letter 
// like, 'm' in this example 
//  if OldTop <> TopIndex then 
    Invalidate; 
  LockWindowUpdate(0); 
end; 

{ TForm1 } 

procedure TForm1.FormCreate(Sender: TObject); 
var 
  i : integer; 
begin 
  tblb := TBitmapListBox.Create(Self); 
  with tblb do 
  begin 
    Parent := Self; 
    Left := 4; 
    Top := 4; 
    Width := 640; 
    Height := 480; 
    for i := 0 to 500 do 
      Items.Add('Monkey vs. Robot!'); 
  end; 
end; 

Если Вы хотите поддержать Mousewheel скроллинг, добавьте следующий код:

{ в секции interface: }

procedure WMMOUSEWHEEL(var Message: TWMMouseWheel); 
    message WM_MOUSEWHEEL; 

и код ....

procedure TBitmapListBox.WMMOUSEWHEEL(var Message: TWMMouseWheel); 
begin 
  LockWindowUpdate(Self.Handle); 
  inherited; 
  Invalidate; 
  LockWindowUpdate(0); 
end;