Listbox с фоновым рисунком

[Dock1100]

Вот мой код отрисовки листбокса, но
1. рисунок блымает, и глючит
2. Почемуто надписи видны токо при выделении

procedure TForm8.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
begin

ListBox1.Canvas.Brush.Color:=rgb(120,120,120);
ListBox1.Canvas.pen.Style :=psclear;
listbox1.Canvas.Font.Color:=rgb(255,255,255);
ListBox1.Canvas.StretchDraw(bounds(0,0,listbox1.Width,listbox1.Height),bmp); 
//если вместо етого написать	ListBox1.Canvas.fillrect(bounds(0,Rect.Top,rect.Right,listbox1.ItemHeight));
//то надписи видны и нету ефкта блыманья
ListBox1.Canvas.TextRect(rect,rect.left+3,rect.top+20,'');
listbox1.Canvas.TextOut(rect.left+3,rect.top+3,ListBox1.Items[Index]);
listbox1.Canvas.TextOut(rect.left+3,rect.top+20,ListBox1.Items[Index]);
if odselected in state then
begin
ListBox1.Canvas.pen.Width:=1;
ListBox1.Canvas.pen.Color :=rgb(100,100,100);
ListBox1.Canvas.Brush.Color:=rgb(120,139,130);
ListBox1.Canvas.roundrect(0,rect.Top,rect.Right,rect.bottom,10,10);
ListBox1.Canvas.Brush.Style:=bsclear;
ListBox1.Canvas.Font.Color:=rgb(255,255,255);
ListBox1.Canvas.Font.style:=[fsbold];
ListBox1.Canvas.TextRect(rect,rect.left+3,rect.top+20,'');
listbox1.Canvas.TextOut(rect.left++3,rect.top+3,ListBox1.Items[Index]);
listbox1.Canvas.TextOut(rect.left++3,rect.top+20,ListBox1.Items[Index]);
end;


if odFocused in State then
ListBox1.Canvas.DrawFocusRect(Rect);



end;

 

[VahaC]

2. Почемуто надписи видны токо при выделении

А ты как хотел??

Ты ведь рисуешь в OnDrawItem
а значит вызывается для отрисовки каждого итема
а ты делаешь

ListBox1.Canvas.StretchDraw(bounds(0,0,listbox1.Width,listbox1.Height),bmp);

что как раз "скрывает" всё что ты нарисовал раньше

если ты хочешь поместить картику на фон всёго листбокса то копируй её кусочками в каждую "ячейку"

Для копирования используй Canvas.CopyRect

 

[VahaC]

Вот мой вариант кода

procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
textheight : Integer;
vcntr : Integer;
str : String;
begin
str := ListBox1.Items[Index];
textheight := listbox1.Canvas.TextHeight(str);
vcntr := (listbox1.ItemHeight - textheight) div 2;

ListBox1.Canvas.CopyRect(Rect, Image1.Canvas, Rect);
ListBox1.Canvas.Brush.Style := bsClear;
listbox1.Canvas.Font.Color := clBlack;
listbox1.Canvas.TextOut(Rect.Left + 3, Rect.Top + vcntr, str);

if odselected in state then
begin
ListBox1.Canvas.pen.Width := 1;
ListBox1.Canvas.pen.Color := clSkyBlue;
ListBox1.Canvas.Brush.Color := clSkyBlue;
ListBox1.Canvas.roundrect(0, Rect.Top, Rect.Right, Rect.Bottom, 10, 10);
ListBox1.Canvas.Font.Color := clBlack;
ListBox1.Canvas.Font.style := [fsbold];
listbox1.Canvas.TextOut(Rect.Left + 3, Rect.Top + vcntr, str);
end;

if odFocused in State then
ListBox1.Canvas.DrawFocusRect(Rect);
end;

Его ещё надо допиливать так как есть глюки при прокрутке

 

[Dock1100]

Мда, у меня выходило примерно тоже самое.
Решил проще самому сделать подобие компонента листбокса, на основе рисунка(ну и трекбара для прокрутки):

unit Unit5;

interface

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

type
TForm5 = class(TForm)
Image1: TImage;
TrackBar1: TTrackBar;
Button1: TButton;
OpenDialog1: TOpenDialog;
Button2: TButton;
Memo1: TMemo;
procedure FormCreate(Sender: TObject);
procedure drawitem(canvas:tcanvas;pos:integer; image:TBitmap; bkcol:TColor);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure TrackBar1Change(Sender: TObject);
procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
public
{ Public declarations }
end;

const itemh=40;

var
Form5: TForm5;
items:Tstringlist;
bmp:Tbitmap;
pos:integer;
selected:integer;


implementation

{$R *.dfm}

procedure TForm5.FormCreate(Sender: TObject);
var i,j:integer;
s:string;
begin
items:=Tstringlist.Create;
bmp:=TBitmap.Create;

items.LoadFromFile('1.txt'); //тут выдаст ошибку просто сделайте тхт файл стекстом в корне с ехе
memo1.Lines:=items;//использовал для проверки(сходства), правильноли рисует текст
form5.DoubleBuffered:=true;
drawitem(image1.Canvas,0,bmp,clcream);
end;

procedure TForm5.Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer); //выделение
begin
with image1 do
begin
selected:=pos+(y div itemh);
drawitem(canvas,pos,bmp,clcream);
end;

end;

procedure TForm5.TrackBar1Change(Sender: TObject);
begin
drawitem(image1.Canvas,trackbar1.Position,bmp,clcream);
pos:=trackbar1.Position;
end;

procedure TForm5.Button1Click(Sender: TObject);
begin
if opendialog1.Execute then
begin
bmp.LoadFromFile(opendialog1.FileName);
image1.Transparent:=false;
end;
end;

procedure TForm5.Button2Click(Sender: TObject);
begin
drawitem(image1.Canvas,trackbar1.Position,bmp,clcream);
end;

procedure TForm5.drawitem(canvas: TCanvas; pos: Integer; image:TBitmap; bkcol:TColor); //отрисовка рисунка
var i,k:integer;
begin
with image1 do
begin
Canvas.Brush.Color:=bkcol;
Canvas.Brush.Style:=bssolid;
canvas.FillRect(bounds(0,0,width,height));
canvas.StretchDraw(bounds(0,0,width,height),image);
k:=items.count;
if (pos+(height div itemh))<k then k:=(pos+(height div itemh));
for i:= pos to k-1 do
begin
if i<>selected then
begin
Canvas.Brush.Color:=rgb(120,120,120);
Canvas.Brush.Style:=bsclear;
Canvas.pen.Style :=psclear;
Canvas.Font.Color:=rgb(0,0,0);
Canvas.TextRect(bounds(0,0,width,height),0,itemh*(i-pos),Items[i]);
end
else
begin
Canvas.Brush.Color:=rgb(150,150,200);
Canvas.Brush.Style:=bssolid;
canvas.FillRect(bounds(0,(i-pos)*itemh,width,itemh));
Canvas.Brush.Style:=bsclear;
Canvas.pen.Style :=psclear;
Canvas.Font.Color:=rgb(0,0,0);
Canvas.TextRect(bounds(0,0,width,height),0,itemh*(i-pos),Items[i]);
end;
end;
end;
end;

end.

 

[VahaC]

Можно ещё вот

Ссылка скрыта от гостей

вариант попробовать

 

[Dock1100]

Тоже вариант, но я его гуглом за 2 часа так и не нашол.