Проблема с отрисовкой сабитема в ListView

← →
Rouse_ © (2010-09-10 17:40) [0]

Вырисовалась тут проблемка с отрисовкой, может кто сталкивался и покажет момент, который я упускаю...

Задача: есть ListView с тремя колонками, в первой и третьей отображается текст, в средней необходимо отрисовать прогрессбар.

Код отрисовки простой:

procedure TForm1.ListView1CustomDrawSubItem(Sender: TCustomListView; Item: TListItem; SubItem: Integer; State: TCustomDrawState; var DefaultDraw: Boolean); var R: TRect; begin if SubItem = 1 then begin R := Item.DisplayRect(drSelectBounds); R.Left := Sender.Column[0].Width; R.Right := R.Left + Sender.Column[1].Width; DrawProgressBar(Sender.Canvas, R, Random(100)); DefaultDraw := False; end end;

ну и сам отрисовщик:

procedure TForm1.DrawProgressBar(ACanvas: TCanvas; lpRect: TRect; ProgressCount: Integer); procedure GetChunkRect; begin Inc(lpRect.Left, 4); Inc(lpRect.Top, 2); Dec(lpRect.Right, 2); Dec(lpRect.Bottom, 2); lpRect.Right := lpRect.Left + Trunc(((lpRect.Right - lpRect.Left) / 100) * ProgressCount); end; var Details: TThemedElementDetails; ChunkPos: Integer; ChunkRect: TRect; CurrentColor: TColor; begin if ThemeServices.ThemesEnabled then begin Details := ThemeServices.GetElementDetails(tpBar); ThemeServices.DrawElement(ACanvas.Handle, Details, lpRect); GetChunkRect; Details := ThemeServices.GetElementDetails(tpChunk); ThemeServices.DrawElement(ACanvas.Handle, Details, lpRect); end else begin ... end; end;

т.е. вроде ничего необычного, но:

в таком виде слетает шрифт у элементов третьей колонки.
вот картинка, где показано наглядно (левое изображение):
http://rouse.drkb.ru/tmp/lv.png

покопал исходники, нашел причину проблемы - шрифты слетают при вызове Canvas.Handle - точнее после выполнения функции function TCanvas.GetHandle: HDC;

Как временное решение добавил перед отрисовкой вот такой код:
ListView1.Canvas.Handle := 0;
Отрисовываться стало нормально (среднее изображение), только морганет при скроле.

Для отключение моргания выставил DoubleBuffered и прилыли - отрисовка скролбара пропала, точнее рисуется частично и вообще каким-то рандомным способом... (правое изображение)

Кто может подсказать - гдеж все-же собака порылась? Бо в исходниках уже зарылся, никак не могу выяснить причину такого поведения...

Вот ссылка на демопроект, наглядно демонстрирующий проблему:
http://rouse.drkb.ru/tmp/lv.zip

Собиралось все на Delphi 2007, тестировалось под Windows 7

← →
Rouse_ © (2010-09-10 17:42) [1]

>> отрисовка скролбара пропала - имелось ввиду отрисовка прогрессбара

← →
Eraser © (2010-09-11 01:02) [2]

были какие то баги помню в 2007 с похожим эффектом, и смутно помню что решалось какими-то манипуляциями с brush, где-то её или обнулять надо или цвет сохранять, потом устанавливать.. или же весь dc сохранять, потом восстанавливать.

← →
DVM © (2010-09-11 12:43) [3]

> Rouse_ © (10.09.10 17:40)

У меня еще текст который подсвечен в данный момент - черный на черных прямоугольниках рисуется.

← →
DVM © (2010-09-11 12:49) [4]

> Rouse_ © (10.09.10 17:40)

как вариант, не рисовать прогрессбар, а создать его окно в нужном месте.

← →
Rouse_ © (2010-09-11 13:58) [5]

Окно можно конечно, но элементов много будет. Можно конечно держать прогресы только для видимых элементов и позициониовать их правильно, только как-то не кошерно это...

← →
Макс Черных (2010-09-11 16:36) [6]

> Кто может подсказать - гдеж все-же собака порылась?

Саня, вспомнил я. :)

Короче говоря, там долго разбирать где напутано в делфях, но ListView1.Canvas.Handle := 0 в режиме DoubleBuffered делать нельзя так как отрисовка идет на HDC который BeginBufferedPaint вернула.
Ну, я тебе показывал.

В общем сделай вот как:

procedure TForm1.ListView1CustomDrawSubItem(Sender: TCustomListView; Item: TListItem; SubItem: Integer; State: TCustomDrawState; var DefaultDraw: Boolean); var R: TRect; begin if SubItem = 1 then begin R := Item.DisplayRect(drSelectBounds); R.Left := Sender.Column[0].Width; R.Right := R.Left + Sender.Column[1].Width; DrawProgressBar(Sender.Canvas, R, Random(100)); DefaultDraw := False; end else begin Sender.Canvas.Font.Size := 1; Sender.Canvas.Font.Size := TListView(Sender).Font.Size; SetBkMode(Sender.Canvas.Handle, TRANSPARENT); DefaultDraw := true; end; end;

DoubleBuffered поставь true. И все будет пучком. :)

← →
Rouse_ © (2010-09-11 23:21) [7]

О, Макс - пасип, завтра буду проверять :)

← →
DVM © (2010-09-12 18:03) [8]

> Макс Черных (11.09.10 16:36) [6]
>

Действительно глюки пропали.

← →
Онотоле (2010-09-17 15:08) [9]

когда-то давно разбирал похожий глюк,
(там рисуется средний сабитем как RoundRect с заданным цветом и в след сабитемах слетали шрифты),
получилось сделать так, может чем поможет:

procedure TfrFilmCopies.lvCustomDrawSubItem(Sender: TCustomListView; Item: TListItem; SubItem: Integer; State: TCustomDrawState; var DefaultDraw: Boolean); var R: TRect; begin if SubItem = SI_COLOR then begin if ListView_GetSubItemRect(Sender.Handle, Item.Index, SubItem, LVIR_BOUNDS, @R) then begin if (Item.Selected) then if (TListView(Sender).Focused) then Sender.Canvas.Brush.Color := clHighlight else if (TListView(Sender).HideSelection) then Sender.Canvas.Brush.Color := clWindow else Sender.Canvas.Brush.Color := cl3DLight else Sender.Canvas.Brush.Color := clWindow; Sender.Canvas.FillRect(R); Sender.Canvas.Brush.Color := TcmnFilmCopy(Item.Data).FilmColor; UnrealizeObject(Sender.Canvas.Brush.Handle); SelectObject(Sender.Canvas.Handle, Sender.Canvas.Brush.Handle); Sender.Canvas.Pen.Color := $404040; Sender.Canvas.RoundRect(R.Left + 1, R.Top + 1, R.Right - 1, R.Bottom - 1, 7, 7); DefaultDraw := false; end end else Sender.Canvas.Brush.Color := clWindow; end; procedure TfrFilmCopies.lvCustomDrawItem(Sender: TCustomListView; Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean); begin Sender.Canvas.Brush.Color := clWindow; end;

> Онотоле (17.09.10 15:08) [9]

А точно работает? У тебя единичный вызов SelectObject как ни как...

Ну да - Макс же решение рабочее привел :)

Проблема с отрисовкой сабитема в ListView Найти похожие ветки