Win32 API | Смена жирности строки в Listbox'e

[Savant]

Как можно реализовать смену жирности шрифта у одной или нескольких строк Listbox'a (WM_SETFONT меняет у всех сразу) ? Прочел весь SDK по Listbox'ам и ответа не нашел :(

[Prisoner]

procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
S: string;
N: Word;
WasColor: TColor;
begin
with Control as TListBox, Canvas do
begin
S := Items[Index];
FillRect(Rect);
MoveTo(Rect.Left + 2, Rect.Top);
SetTextAlign(Canvas.Handle, TA_LEFT or TA_UPDATECP);
WasColor := Font.Color;
for N := 1 to Length(S) do
begin
case UpCase(S[N]) of
'A', 'E', 'I', 'O', 'U': Font.Color := clRed;
else
Font.Color := WasColor;
end;
WinProcs.TextOut(Canvas.Handle, 0, 0, @S[N], 1);
end;
end;
end;


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

[Savant]

Prisoner
спасибо, реализовал =)
Правда было довольно много мучений, распишу их, чтобы другие не мучались :)

1. В design-time надо ListBox'y установить опции loOwnerDrawFixed либо loOwnerDrawVariable (кстати, в чем разница?), иначе данная процедура по-видимому игнорируется.
2. Для программирующих не с помощью VCL, а с помощью KOL

function TForm1.ListBox1DrawItem(Sender: PObj; DC: HDC; const Rect: TRect;
ItemIdx: Integer; DrawAction: TDrawAction;
ItemState: TDrawState): Boolean;
var
S: string;
Sel: Boolean;
begin
S:=TKOLListBox(Sender).Items;
Sel:=odsSelected in ItemState;
if Sel then begin
TKOLListBox(Sender).Canvas.Brush.Color:=clhighLight;
TKOLListBox(Sender).Font.Color:=clWhite;
end;
FillRect(DC, Rect, TKOLListBox(Sender).Canvas.Brush.Handle);
[I]//TKOLListBox(Sender).Canvas.MoveTo(Rect.Left + 2, Rect.Top);
Windows.MoveToEx(DC, Rect.Left + 2, Rect.Top, nil);
SetTextAlign(DC, TA_LEFT or TA_UPDATECP);
TKOLListBox(Sender).Font.FontStyle:=[fsBold];
TextOut(DC, 0, 0, PChar(S), Length(S));
if Sel then begin
TKOLListBox(Sender).Font.Color:=clWindowText;
TKOLListBox(Sender).Canvas.Brush.Color:=clWindow;
end;
end;


Если не заменить закомментированную строку на ту, что идет следом, то все строки будут "рисоваться" в один ряд. По-видимому глюк программистов.

Кстати 2 проблемы еще остались. Надо выделенный элемент писать на синем фоне (ну как обычно). Для этого я ввёл обрабочик

if odsSelected in ItemState then ...


Но! Если операцию заливки (FillRect) выполнять до вывода текста (TextOut), то сам текст выводится на белом фоне, а если после - то текст "скрывается" под этим слоем краски.

Пока писал эти строки, допёрло как сделать ;)

в самое начало надо добавить вызов SetBkMode, т.е.

....
begin
SetBkMode(DC, TRANSPARENT);
S:= ....



И последняя проблема:

....
TKOLListBox(Sender).Font.Color:=clWindowText;
....


Вот из-за этой строки (она почти в конце) ListBox перерисовывается бесчисленное число раз (я ждал около 30 сек, потом надоело; сама программа не зависает). Если ее (строку) закомментировать, то программа работает нормально. Причем если эту строку поместить в любое другое место процедуры, то результат опять же отрицательный... Ничего не понимаю...
В итоге выяснилось, что это происходит, когда используется больше 1 вызова свойства Font.Color . Причем даже если делать так:

....
if Sel then cl:=clWhite else cl:=clWindowText;
TKOLListBox(Sender).Font.Color:=cl;
....


Вот с этим я никак не могу разобраться...

[Savant]

Как я и думал, проблема будет решена с помощью Winapi (опять глюки у программистов KOL???).
Итоговый код:

var
Listbox_Font_Normal, Listbox_Font_Bold: HFONT;
Fonts_Created: Boolean = false;

procedure TForm1.KOLForm1Destroy(Sender: PObj);
begin
.......
DeleteObject(Listbox_Font_Normal);
DeleteObject(Listbox_Font_Bold);
end;

procedure CreateMyFonts;
begin
if not Fonts_Created then begin
Listbox_Font_Normal:=CreateFont(-12,0,0,0,FW_NORMAL,0,0,0,RUSSIAN_CHARSET,
OUT_TT_ONLY_PRECIS,CLIP_DEFAULT_PRECIS,DEFAULT_QUALITY,DEFAULT_PITCH or FF_DONTCARE,'Tahoma');
Listbox_Font_Bold:=CreateFont(-12,0,0,0,FW_BOLD,0,0,0,RUSSIAN_CHARSET,
OUT_TT_ONLY_PRECIS,CLIP_DEFAULT_PRECIS,DEFAULT_QUALITY,DEFAULT_PITCH or FF_DONTCARE,'Tahoma');
Fonts_Created:=True;
end;
end;

function TForm1.ListBox1DrawItem(Sender: PObj; DC: HDC; const Rect: TRect;
ItemIdx: Integer; DrawAction: TDrawAction;
ItemState: TDrawState): Boolean;
var
S: string;
Sel: Boolean;
cL: Integer;
HF: HFONT;
begin
S:=TKOLListBox(Sender).Items;
SetBkMode(DC, TRANSPARENT);
CreateMyFonts;
Sel:=odsSelected in ItemState;
if Sel then begin
TKOLListBox(Sender).Canvas.Brush.Color:=clhighLight;
cl:=clWhite;
end else
cl:=clWindowText;
SetTextColor(DC, cl);
FillRect(DC, Rect, TKOLListBox(Sender).Canvas.Brush.Handle);
[i]//TKOLListBox(Sender).Canvas.MoveTo(Rect.Left + 2, Rect.Top);
Windows.MoveToEx(DC, Rect.Left + 2, Rect.Top, nil);
SetTextAlign(DC, TA_LEFT or TA_UPDATECP);
// --- TODO: if условие then
if Sel then
HF:=Listbox_Font_Bold
// --- TODO: else
else
HF:=Listbox_Font_Normal;
// --- TODO: end
SelectObject(DC, HF);
TextOut(DC, 0, 0, PChar(S), Length(S));
if Sel then begin
TKOLListBox(Sender).Canvas.Brush.Color:=clWindow;
end;
Result:=False;
end;



p.s.: данный код меняет жирность у всех строк, удовлетворяющих условию, условие надо вставлять вместо "TODO" как показано

Аналогичный код на VCL выглядит так:

procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
S: string;
begin
with Control as TListBox, Canvas do
begin
S := Items[Index];
FillRect(Rect);
MoveTo(Rect.Left + 2, Rect.Top);
SetTextAlign(Canvas.Handle, TA_LEFT or TA_UPDATECP);
// TODO: if условие then
if true then
Font.Style := [fsBold];
WinProcs.TextOut(Canvas.Handle, 0, 0, PChar(S), Length(S));
Font.Style := [];
end;
end;