В TListView, TextOut не прорисовывает цвета. [XP]
JetAPI © (2007-08-15 22:50:00)
Помогите пожалуйста, самому справиться не получается!
Перепробывал всё... и сдался!
На форме лежит TListView,.. и всё. Вот код:
. . .
uses CommCtrl;
procedure TForm1.FormCreate(Sender: TObject);
var i,j: Byte;
begin
Form1.Width := 650;
ListView1.ViewStyle := vsReport;
ListView1.GridLines := True;
ListView1.Width := 500;
for i:=0 to 2 do begin
ListView1.Columns.Add.Width:=150;
ListView1.Column[i].Caption:='Колонка '+IntToStr(i+1);
end;
for i:=0 to 3 do begin
ListView1.Items.Add.Caption:='Итем '+IntToStr(i+1);
for j:=0 to 1 do
ListView1.Items.Item[i].SubItems.Add('Сабитем
'+IntToStr(j+1));
end;
end;
procedure TForm1.ListView1AdvancedCustomDrawSubItem(Sender:
TCustomListView;
Item: TListItem; SubItem: Integer; State:
TCustomDrawState;
Stage: TCustomDrawStage; var DefaultDraw: Boolean);
var R: TRect;
begin
if (item.Index = 1) and (SubItem = 1) then begin
DefaultDraw:=false;
ListView_GetSubItemRect(ListView1.Handle,Item.Index,SubItem,LVIR_BOUNDS,@R);
with Sender.Canvas do begin
Font.Color:=clBlue;
TextOut(R.Left + 6, R.Top, '01');
Font.Color:=clLime;
TextOut(R.Left + 26, R.Top, '02');
Font.Color:=clRed;
TextOut(R.Left + 46, R.Top, '03');
end;
end;
if Assigned(Sender.Canvas.Font.OnChange) then
Sender.Canvas.Font.OnChange(Sender.Canvas.Font);
end;
При запуске, программа, в отдельно взятом SubItem'е, должна
нарисовать разными цветами: 01 02 03, но не рисует...
Рисует, только одним цветом - clBlue.
В общем горе мне одно с этим TListView! Прошу очень помочь.
Спасибо всем.
JetAPI (2007-08-15 22:58:00) [1]
Если ничего так и не смогу решить, придется идти путем
наименьшего сопротивления. Но мне этого, не хотелось бы больше
всего - искать обхода и уклонятся от сути.
Если "имплантировать" в SubIten TLabel или
TTPaintBox...
Но это тогда катастрофат, если, в каждый SubItem, вставлять
TLabel или TPaintBox
Наверх 
ЧАТ |
Орешник |
|
