Rambler's Top100
"Knowledge itself is power"
F.Bacon
Поиск | Карта сайта | Помощь | О проекте | ТТХ  
 Сокровищница
  
 

Фильтр по датам

 
 К н и г и
 
Книжная полка
 
 
Библиотека
 
  
  
 


Поиск
 
Поиск по КС
Поиск в статьях
Яndex© + Google©
Поиск книг

 
  
Тематический каталог
Все манускрипты

 
  
Карта VCL
ОШИБКИ
Сообщения системы

 
Форумы
 
Круглый стол
Новые вопросы

 
  
Базарная площадь
Городская площадь

 
   
С Л С

 
Летопись
 
Королевские Хроники
Рыцарский Зал
Глас народа!

 
  
ТТХ
Конкурсы
Королевская клюква

 
Разделы
 
Hello, World!
Лицей

Квинтана

 
  
Сокровищница
Подземелье Магов
Подводные камни
Свитки

 
  
Школа ОБЕРОНА

 
  
Арсенальная башня
Фолианты
Полигон

 
  
Книга Песка
Дальние земли

 
  
АРХИВЫ

 
 

Сейчас на сайте присутствуют:
 
  
 
Во Флориде и в Королевстве сейчас  13:31[Войти] | [Зарегистрироваться]

ListBox с Fixed рядами и произвольными иконками для каждого ряда.

Климов Иван
дата публикации 12-01-2005 18:00

ListBox с Fixed рядами и произвольными иконками для каждого ряда.

В данном примере хочется рассмотреть, как с помощью канвы можно преобразить и добавить функциональности компоненту ListBox. Хочу оговориться сразу - для простоты вида я рисую прямо на канве. Для уменьшения эффекта мигания можно рисовать на bmp.

Перейду непосредственно к примеру:
Форма = Form7, Компонент - ListBox1
Я решил подгрузить bmp для списка с FormCreate, хотя можно где угодно…

procedure TForm7.FormCreate(Sender: TObject);
begin
  bmp:=Tbitmap.Create; //создаем бмп
  bmp.Transparent:=True; //включаем прозрачность
  bmp.TransparentMode:=tmauto; //способ-авто, есть и другие флаги-смотри справку
  bmp.LoadFromFile(ExtractFilePath(Application.ExeName)+''user.bmp'');
end;

procedure TForm7.ListBox1DrawItem(Control: TWinControl; Index: Integer;
  Rect: TRect; State: TOwnerDrawState);
var
  int,int2,int3:integer; //для определения нечетности
  OldBkMode: integer; //для задания прозрачности фона текста через api
  myrect,Myrect2:Trect; // произвольные ректы для боковой полосы и дорисовки ее
                        //до конца листбокса
  oldbs:TbrushStyle; //для отмены прозрачности кисти
  Fcolor:Tcolor; //для отмены цвета шрифта
Begin
 //задаем координаты боковой полоски
  myrect.Top:=rect.top;
  myrect.Bottom:=rect.Bottom;
  myrect.Left :=Rect.Left{ListBox1.Left};
  Myrect.Right:=Rect.Left+Bmp.Width+2;
  Myrect2.Top:=rect.bottom;
  Myrect2.Left:=Myrect.Left;
  Myrect2.Right:=Myrect.Right;
  Myrect2.Bottom:=ListBox1.Height;
//Если элемент последний то дорисовываем градиент до конца листбокса
// (эффект на любителя)
  if index=ListBox1.Count-1 then
  DrawGradient(Listbox1.Canvas,Myrect2,true,[$00FDF6F6,$00D9C9C9]);

 if (index <> 0) and (index <> 6)then
 begin
  // Отрисовываем листбокс без Fixed рядом (у нас 0-ой и 6-й)
  ListBox1.Canvas.TextRect(rect,rect.left+bmp.width+3,rect.top+3,ListBox1.Items[Index]);
  int:= index mod 2;
  if int = 0 then
  begin //если ряд четный то рисуем полоску светлого цвета (а-ля Linux!!)
   ListBox1.Canvas.Brush.Color:=RGB(242,245,253); // я выбрал такой цвет
   //убираем линии прямоугольника. (рисуем его без рамки)
   ListBox1.Canvas.pen.Style :=psclear;
   //рисуем прямоугольник
   ListBox1.Canvas.RoundRect(Rect.Left+bmp.Width,Rect.Top,rect.Right,
                             rect.bottom,0,0);
   // задаем прозрачность текста
   OldBkMode := SetBkMode(ListBox1.Canvas.Handle, TRANSPARENT);
   // рисуем текст
   ListBox1.Canvas.TextRect(rect,rect.left+bmp.Width+3,rect.top+3,
                            ListBox1.Items[Index]);
   // возвращаем старые настройки прозрачности
   SetBkMode(ListBox1.Canvas.Handle, OldBkMode);
  end;
 end;
 if (index <> 0) and (index <> 6) then
 begin // Если не Fixed то рисуем градиент сбоку
   DrawGradient(Listbox1.Canvas,Myrect,true,[$00FDF6F6,$00D9C9C9]);
   //если хотим чтобы все bmp были одинаковые
   {ListBox1.Canvas.Draw(rect.Left,Rect.Top,bmp); }
 end;
 if (index=0) or (index = 6) then
 begin //отрисовка Fixed рядов
   ListBox1.Canvas.Font.Style:=[fsBold]; //Шрифт жирный
   DrawGradient(Listbox1.Canvas,Rect,false,[$00FDF6F6,$00D9C9C9]); // другой градиент
   ListBox1.Canvas.Brush.Color:=$00947C7C; //Цвет каемки Fixed прямоугольника
   ListBox1.Canvas.FrameRect(Rect); //Рисуем рамку
   oldbs:=ListBox1.Canvas.Brush.Style;
   Listbox1.Canvas.Brush.Style:=bsclear; //делаем фон текста прозрачным
   Fcolor:=ListBox1.Canvas.Font.Color; //запоминаем цвет шрифта
   ListBox1.Canvas.Font.Color:=clMedGray;
   DrawText(ListBox1.Canvas.Handle,Pchar(ListBox1.Items[Index]),
            length(ListBox1.Items[Index]),rect,
            DT_SINGLELINE  or DT_CENTER or DT_VCENTER); //рисуем текст в центре ячейки
   ListBox1.Canvas.Font.Color:=Fcolor; //восстанавливаем цвет
   ListBox1.Canvas.Brush.Style:=oldbs; //восстанавливаем стиль прозрачности
 end;
 if (index <> 0) and (index <> 6) then
 begin //чтобы не мигали Fixed ячейки
   if odselected in state then
   begin //отрисовываем выбранный элемент
     ListBox1.Canvas.pen.Width:=1;
     ListBox1.Canvas.pen.Color :=$00947C7C;
     ListBox1.Canvas.pen.Style :=pssolid;
     ListBox1.Canvas.Brush.Color:=$00C2EEFF;
     ListBox1.Canvas.Rectangle(rect.Left,rect.Top,rect.Right,rect.bottom);
     oldbs:=ListBox1.Canvas.Brush.Style;
     ListBox1.Canvas.Brush.Style:=bsclear;
     ListBox1.Canvas.TextRect(rect,rect.left+bmp.Width+3,rect.top+3,
                   ListBox1.Items[Index]);
     ListBox1.Canvas.Brush.Style:=oldbs;
   end;
 end;
 if index = 5 then
   //выводим произвольный битмап в выбранный ряд
   ListBox1.Canvas.Draw(rect.Left,Rect.Top,bmp);
 if odFocused in State then
   //убираем стандартные точечки выделения при потере фокуса
   ListBox1.Canvas.DrawFocusRect(Rect);
end;

Наверное, Вы хотите спросить: "А что такое DrawGradient???" Это процедура по прорисовке градиента с произвольным количеством цветов (взята мною из DelphiWorld''a).

Примечание:
Автор процедуры: David Johannes Rieger
Оригинал материала: http://www.djr-delphi.gmxhome.de/old/Tipps/Grafik/005.htm
http://www.swissdelphicenter.ch/torry/showcode.php?id=1162

procedure DrawGradient(ACanvas: TCanvas; Rect: TRect;
   Horicontal: Boolean; Colors: array of TColor);
 type
   RGBArray = array[0..2] of Byte;
 var
   x, y, z, stelle, mx, bis, faColorsh, mass: Integer;
   Faktor: double;
   A: RGBArray;
   B: array of RGBArray;
   merkw: integer;
   merks: TPenStyle;
   merkp: TColor;
 begin
   mx := High(Colors);
   if mx > 0 then
   begin
     if Horicontal then
       mass := Rect.Right - Rect.Left
     else
       mass := Rect.Bottom - Rect.Top;
     SetLength(b, mx + 1);
     for x := 0 to mx do
     begin
       Colors[x] := ColorToRGB(Colors[x]);
       b[x][0] := GetRValue(Colors[x]);
       b[x][1] := GetGValue(Colors[x]);
       b[x][2] := GetBValue(Colors[x]);
     end;
     merkw := ACanvas.Pen.Width;
     merks := ACanvas.Pen.Style;
     merkp := ACanvas.Pen.Color;
     ACanvas.Pen.Width := 1;
     ACanvas.Pen.Style := psSolid;
     faColorsh := Round(mass / mx);
     for y := 0 to mx - 1 do
     begin
       if y = mx - 1 then
         bis := mass - y * faColorsh - 1
       else
         bis := faColorsh;
       for x := 0 to bis do
       begin
         Stelle := x + y * faColorsh;
         faktor := x / bis;
         for z := 0 to 3 do
           a[z] := Trunc(b[y][z] + ((b[y + 1][z] - b[y][z]) * Faktor));
         ACanvas.Pen.Color := RGB(a[0], a[1], a[2]);
         if Horicontal then
         begin
           ACanvas.MoveTo(Rect.Left + Stelle, Rect.Top);
           ACanvas.LineTo(Rect.Left + Stelle, Rect.Bottom);
         end
         else
         begin
           ACanvas.MoveTo(Rect.Left, Rect.Top + Stelle);
           ACanvas.LineTo(Rect.Right, Rect.Top + Stelle);
         end;
       end;
     end;
     b := nil;
     ACanvas.Pen.Width := merkw;
     ACanvas.Pen.Style := merks;
     ACanvas.Pen.Color := merkp;
   end
   else
     // Please specify at least two colors
    raise EMathError.Create(''Es mussen mindestens zwei Farben angegeben werden.'');
 end;

Иван Климов
www.isoftware.amillo.net



Смотрите также материалы по темам:
[TListBox] [GDI, рисование на канве]

 Обсуждение материала [ 17-01-2005 07:13 ] 7 сообщений
  
Время на сайте: GMT минус 5 часов

Если вы заметили орфографическую ошибку на этой странице, просто выделите ошибку мышью и нажмите Ctrl+Enter.
Функция может не работать в некоторых версиях броузеров.

Web hosting for this web site provided by DotNetPark (ASP.NET, SharePoint, MS SQL hosting)  
Software for IIS, Hyper-V, MS SQL. Tools for Windows server administrators. Server migration utilities  

 
© При использовании любых материалов «Королевства Delphi» необходимо указывать источник информации. Перепечатка авторских статей возможна только при согласии всех авторов и администрации сайта.
Все используемые на сайте торговые марки являются собственностью их производителей.

Яндекс цитирования