Win32 API | Смена жирности строки в Listbox'e - Компьютерный форум OSzone.net

Компьютерный форум OSzone.net (http://forum.oszone.net/index.php)

- Программирование и базы данных (http://forum.oszone.net/forumdisplay.php?f=21)

- - Win32 API | Смена жирности строки в Listbox'e (http://forum.oszone.net/showthread.php?t=45808)

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

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

Код:

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;

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

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[ItemIdx];

  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);

  //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;

....

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

Как я и думал, проблема будет решена с помощью 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[ItemIdx];

  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);

  //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;