Top.Mail.Ru
Мастера DELPHI, Delphi programming community Титульная страница Поиск, карта сайта Написать письмо 
| Новости | Поиск | FAQ | Статьи | Книги | Новости VCL |
| Форумы ЧАТ | Орешник | KOL и MCK |
Форумы -» Основная («Начинающим»)/ Базы / WinAPI / Компоненты / Сети / Media / Игры / Corba и COM / KOL / FreePascal / .Net / Прочее / RSDN.ORG

« предыдущая ветвь | форум | следующая ветвь »

ListBox убрать рамку в выделенной строке [D7, WinXP]


Страницы:   1 2

Дмитрий_05 ©   (2005-12-01 13:44:00) 

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

Antonn   (2005-12-07 18:14:00) [1]

Дмитрий_05   (07.12.05 17:21) [28]
глянь тут: http://an-files.narod.ru/_works/5016.html

Дмитрий_05   (2005-12-07 17:30:00) [2]

Что за деньги то это точно...:)))

Игорь Шевченко   (2005-12-07 17:29:00) [3]

Дмитрий_05   (07.12.05 17:21) [28]


> а можно


За деньги можно все. Только их много надо, денег.

Дмитрий_05   (2005-12-07 17:21:00) [4]

Работает ))) а можно чтобы курсор не изменялся(чтобы не рисовался квадратик снизу курсора), и чтобы перемещение строки происходило во время перемещения курсора, а не после того как отпустить клавишу... Ну, соответственно если нажать правую клавишу мышки, не отпуская левой, чтобы сбрасывалось это все, т.е. строка становилась туда, где она и была...

Игорь Шевченко   (2005-12-07 14:07:00) [5]

Дмитрий_05   (07.12.05 12:51) [26]


> А вот чтобы строки можно было перемещать мышкой, т.е. имеется
> ввиду если ее "взять и потацить"


unit main;

interface

uses
 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
 StdCtrls;

type
 TForm1 = class(TForm)
   ListBox1: TListBox;
   procedure ListBox1MouseDown(Sender: TObject; Button: TMouseButton;
     Shift: TShiftState; X, Y: Integer);
   procedure ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer);
   procedure ListBox1DragOver(Sender, Source: TObject; X, Y: Integer;
     State: TDragState; var Accept: Boolean);
 end;

var
 Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.ListBox1MouseDown(Sender: TObject; Button: TMouseButton;
 Shift: TShiftState; X, Y: Integer);
begin
 if Button = mbLeft then
   ListBox1.BeginDrag({not (Button = mbLeft)}false);
end;

procedure TForm1.ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer);
begin
 if Source = ListBox1 then
   with ListBox1,ListBox1.Items do
     Move(ItemIndex, ItemAtPos(Point(X, Y), True));
end;

procedure TForm1.ListBox1DragOver(Sender, Source: TObject; X, Y: Integer;
 State: TDragState; var Accept: Boolean);
begin
 Accept:=Source = ListBox1;
end;

end.

Дмитрий_05   (2005-12-07 12:51:00) [6]

Игорь Шевченко, точно... что-то я не догадался, наверно из за того что не спал всю ночь, торможу уже :) Сейчас я на работе, тут нету Delphi, дома попробую :) А вот чтобы строки можно было перемещать мышкой, т.е. имеется ввиду если ее "взять и потацить", чтобы менялся ее индекс в зависимости от положения курсора, что посоветуете? :)

Игорь Шевченко   (2005-12-07 12:31:00) [7]


> Если можно... подскажите пожалуйста, как сделать чтобы при
> потере фокуса строка в таком ListBox-е оставалась выделенной


в CNDrawItem убрать проверку на odFocused, а проверять на odSelected ?

Дмитрий_05   (2005-12-07 12:26:00) [8]

я уже разобрался ))) может кому пригодится:

unit XListBox;

interface

uses
 Windows, Messages, Classes, Controls, StdCtrls, Graphics, SysUtils;

type
 TXListBox = class(TListBox)
 public
   constructor Create(AOwner: TComponent); override;
   destructor Destroy; override;
 protected
   procedure CreateParams(var Params: TCreateParams); override;
   procedure RecreateBack; virtual;
 private
   procedure PictureChanged(Sender: TObject);
   procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
   procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
   procedure WMEraseBkgnd(var Message: TWMERASEBKGND); Message WM_ERASEBKGND;
   procedure WMHScroll(var Message: TWMHScroll); message WM_HScroll;
   procedure WMVScroll(var Message: TWMVScroll); message WM_VScroll;
   procedure WMMOUSEWHEEL(var Message: TWMMOUSEWHEEL); message WM_MOUSEWHEEL;
 private
   FBack: TBitmap;
   FPicture: TPicture;
   FSelectedTextColor: TColor;
   procedure SetPicture(const Value: TPicture);
   procedure SetSelectedTextColor(const Value: TColor);
 published
   property Picture: TPicture read FPicture write SetPicture;
   property SelectedTextColor: TColor read FSelectedTextColor write SetSelectedTextColor default clHighlightText;
 end;

procedure Register;

implementation

procedure Register;
begin
 RegisterComponents('MyComp', [TXListBox]);
end;

constructor TXListBox.Create(AOwner: TComponent);
begin
 inherited;
 FBack := TBitmap.Create;
 FPicture := TPicture.Create;
 FPicture.OnChange := PictureChanged;
 FSelectedTextColor := clRed;// clHighlightText;
end;

destructor TXListBox.Destroy;
begin
 FPicture.Free;
 FBack.Free;
 inherited;
end;

procedure TXListBox.CreateParams(var Params: TCreateParams);
begin
 inherited;
 with Params do begin
   if Style and (LBS_OWNERDRAWFIXED or LBS_OWNERDRAWVARIABLE) = 0 then
     Style := Style or LBS_OWNERDRAWFIXED;
   Style := Style or BS_OWNERDRAW{ or WS_CLIPCHILDREN};
 end;
end;

procedure TXListBox.RecreateBack;
begin
 if HandleAllocated then
   with FBack, Canvas do begin
     Width  := ClientWidth;
     Height := ClientHeight;
     Brush.Color := Self.Color;
     if FPicture.Graphic <> nil then
       StretchDraw(ClipRect, FPicture.Graphic)
     else
       FillRect(ClipRect);
   end;
end;

procedure TXListBox.PictureChanged(Sender: TObject);
begin
 RecreateBack;
 Invalidate;
end;

procedure TXListBox.WMEraseBkgnd(var Message: TWMERASEBKGND);
begin
 if (FBack.Width <> ClientWidth) or (FBack.Height <> ClientHeight) then
   RecreateBack;
 Canvas.Draw(0, 0, FBack);
 InvalidateRect(Handle, nil, false);
 Message.Result := 1;
end;

procedure TXListBox.WMPaint(var Message: TWMPaint);
begin
 inherited;
 if Items.Count = 0 then Canvas.Draw(0, 0, FBack);
end;

procedure TXListBox.CNDrawItem(var Message: TWMDrawItem);
var
 State: TOwnerDrawState;
begin
 with Message.DrawItemStruct^ do
 begin
   State := TOwnerDrawState(LongRec(itemState).Lo);
   Canvas.Handle := hDC;
   Canvas.Font := Font;
   Canvas.Brush := Brush;
   if (Integer(itemID) >= 0) and (odFocused in State) then
     Canvas.Font.Color := SelectedTextColor;
   Canvas.Brush.Style := bsClear;
   if Integer(itemID) >= TopIndex then
     DrawItem(itemID, rcItem, State);
   Canvas.Handle := 0;
 end;
end;

procedure TXListBox.WMHScroll(var Message: TWMHScroll);
begin
 if Message.ScrollBar = 0 then
   begin
     LockWindowUpdate(Handle);
     inherited;
     LockWindowUpdate(0);
     InvalidateRect(Handle, nil, true);
   end
 else
   inherited;
end;

procedure TXListBox.WMVScroll(var Message: TWMVScroll);
begin
 if Message.ScrollBar = 0 then
   begin
     LockWindowUpdate(Handle);
     inherited;
     LockWindowUpdate(0);
     InvalidateRect(Handle, nil, true);
   end
 else
   inherited;
end;

procedure TXListBox.WMMOUSEWHEEL(var Message: TWMMOUSEWHEEL);
begin
 if GetFocus = Handle then
   begin
     LockWindowUpdate(Handle);
     inherited;
     LockWindowUpdate(0);
     InvalidateRect(Handle, nil, true);
   end
 else
   inherited;
end;

procedure TXListBox.SetPicture(const Value: TPicture);
begin
 FPicture.Assign(Value);
end;

procedure TXListBox.SetSelectedTextColor(const Value: TColor);
begin
 if FSelectedTextColor = Value then exit;
 FSelectedTextColor := Value;
 Invalidate;
end;

end.


Если можно... подскажите пожалуйста, как сделать чтобы при потере фокуса строка в таком ListBox-е оставалась выделенной, т.е. оставалась SelectedTextColor цветом. И еще если можно, сделать так чтобы строки можно было перетаскивать мышкой...

Игорь Шевченко   (2005-12-07 10:18:00) [9]


> Подскажите пожалуйста что не так?


А где код, в котором не так ?

Дмитрий_05   (2005-12-06 19:00:00) [10]

Подскажите пожалуйста что не так? Может действительно сообщения не доходят о перерисовке строк?

Дмитрий_05   (2005-12-05 19:53:00) [11]

Сори... Ошибся... посмотрел метод перерисовки строк, а не окна...)))))

Дмитрий_05   (2005-12-05 19:50:00) [12]

Спасибо за ссылку... поразбирался... посмотрел метод перерисовки окна... в моем случае вроде все так... но блин... исчезают строки и все...((( Может само сообщение не доходит о перерисовки строк CN_DRAWITEM? просто если сделать так: вот выделить в ListBox-е по строчке, чтобы они все показались... а потом перенести форму за пределы монитора а потом назад, строки опять исчезают, а сам фон рисуется без проблем... вот в чем дело..(((

Игорь Шевченко   (2005-12-05 12:18:00) [13]

http://kladovka.net.ru/download.cgi?id=193

Дмитрий_05   (2005-12-05 00:39:00) [14]

Переносил и уберал, еще до того как написать... Если совсем убрать, то в момент проектирования формы, при изменения свойства Picture, изображение не вставляется, само окно выбора изображения не закрывается никак, и Delphi как-бы виснет... Приходится выключать его через диспечер задачь... А если поставить в начало, то у меня строки не рисуются, только после того, если выделить их. Прорисовка строк, может там что-то не то я нахимичел:

type
 TXListBox = class(TListBox)
 private
   procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
 protected
   procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
.....
procedure TXListBox.CNDrawItem(var Message: TWMDrawItem);
var
 State: TOwnerDrawState;
begin
with Message.DrawItemStruct^ do
 begin
 State := TOwnerDrawState(LongRec(itemState).Lo);
 Canvas.Handle := hDC;
 Canvas.Font := Font;
 Canvas.Brush := Brush;
 if (Integer(itemID) >= 0) and (odSelected in State) then
   begin
   Canvas.Font.Color := FSelectedTextColor;
   end;
 if Integer(itemID) >= 0 then
   DrawItem(itemID, rcItem, State);
 Canvas.Handle := 0;
 end;
end;

procedure TXListBox.DrawItem(Index: Integer; Rect: TRect;
 State: TOwnerDrawState);
var
 Flags: Longint;
 Data: String;
begin
if Assigned(OnDrawItem) then
 OnDrawItem(Self, Index, Rect, State)
else
 begin
 if Index < Count then
   begin
   Flags := DrawTextBiDiModeFlags(DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);
   if not UseRightToLeftAlignment then
     Inc(Rect.Left, 2)
   else
     Dec(Rect.Right, 2);
   Data := '';
   if (Style in [lbVirtual, lbVirtualOwnerDraw]) then
     Data := DoGetData(Index)
   else
     Data := Items[Index];
   SetBKMode(Canvas.Handle, TRANSPARENT);
   DrawText(Canvas.Handle, PChar(Data), Length(Data), Rect, Flags);
   end;
 end;
end;


P.S. То что не используется FillRect, я решил выделять строки только цветом шрифта.

Джо   (2005-12-04 23:23:00) [15]


> procedure TXListBox.WMPaint(var Message: TWMPAINT);
> var
>  R: TRect;
> begin
> with Canvas do
>  begin
>  Brush.Style := bsClear;
>  R := ClientRect;
>  if FPicture.Graphic <> nil then
>    StretchDraw(R, FPicture.Graphic);
>  end;
> inherited;
> end;

Перенести inherited в начало кода или убрать.

Дмитрий_05   (2005-12-04 22:00:00) [16]

Со строками разобрался, у меня небольшая проблема вот в чем. У меня этот компонент лежит на форме, которая создается диномически(по нажатию кнопки). Форма появляется, а мой ListBox не заполняется фоном, если эту форму перенести за пределы экрана а потом обратно, то фон рисуется. Прорисовка:


procedure TXListBox.WMEraseBkgnd(var Message: TWMERASEBKGND);
begin                         // чтобы не мограл
 Message.Result := 1;
end;

procedure TXListBox.WMPaint(var Message: TWMPAINT);
var
 R: TRect;
begin
with Canvas do
 begin
 Brush.Style := bsClear;
 R := ClientRect;
 if FPicture.Graphic <> nil then
   StretchDraw(R, FPicture.Graphic);
 end;
inherited;
end;


Пробовал этот код и без WM_EraseBkgnd, тоже самое...
Пробовал и так:


procedure TXListBox.WMEraseBkgnd(var Message: TWMERASEBKGND);
begin
if FPicture.Bitmap <> nil then
 begin
 BitBlt(Message.DC, 0, 0, ClientWidth, ClientHeight, FPicture.Bitmap.Canvas.Handle, 0, 0, srcCopy);
 Message.Result := 1;
 end
else
 inherited;
end;


так вообще не рисуется... помогите, что не так...

Дмитрий_05   (2005-12-03 23:28:00) [17]

Я нашел только вот что: http://delphimaster.ru/cgi-bin/forum.pl?id=1131899674&n=0
но там тема так и не расскрыта...

Джо   (2005-12-03 22:40:00) [18]


> что делать?

Читать посты в этой ветке и думать над ними. А потом уже писать "свой вариант".

Дмитрий_05   (2005-12-03 22:36:00) [19]

Мне тут посказали вот как сделать:

TXListBox = class(TListBox)
private
 procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
end;
..............
procedure TXListBox.CNDrawItem(var Message: TWMDrawItem);
begin
 with Message.DrawItemStruct^ do
   itemState:=itemState and not 16;
 inherited;
end;


Решил всетаки свой компонент сделать... Решил туда еще добавить фон, картинку:

TXListBox = class(TListBox)
 private
   FPicture: TPicture;
   procedure SetPicture(const Value: TPicture);
   procedure PictureChanged(Sender: TObject);
   procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
   procedure WMPaint(var Message: TWMPAINT); Message WM_PAINT;
   procedure WMEraseBkgnd(var Message: TWMERASEBKGND); Message WM_ERASEBKGND;
 public
   constructor Create(AOwner: TComponent); override;
   destructor Destroy; override;
 published
   property Picture: TPicture read FPicture write SetPicture;
 end;

...

constructor TXListBox.Create(AOwner: TComponent);
begin
inherited;
FPicture := TPicture.Create;
FPicture.OnChange := PictureChanged;
end;

destructor TXListBox.Destroy;
begin
FPicture.Free;
inherited;
end;

procedure TXListBox.CNDrawItem(var Message: TWMDrawItem);
begin
 with Message.DrawItemStruct^ do
   itemState := itemState and not 16;
 inherited;
end;

procedure TXListBox.SetPicture(const Value: TPicture);
begin
 FPicture.Assign(Value);
end;

procedure TXListBox.PictureChanged(Sender: TObject);
begin
Invalidate;
end;

procedure TXListBox.WMEraseBkgnd(var Message: TWMERASEBKGND);
begin
Message.Result := 1;
end;

procedure TXListBox.WMPaint(var Message: TWMPAINT);
var
 R: TRect;
begin
inherited;
with Canvas do
 begin
 Brush.Style := bsClear;
 R := ClientRect;
 if FPicture.Graphic <> nil then
   StretchDraw(R, FPicture.Graphic);
 end;
end;


Но у меня теперь картинка то рисуется, а строки исчезли... При выделении строк, часть картинки исчезает, т.е. заместо той строки какая была выделена, просто белый фон... и строки опять стали с рамкой... что делать?

XCoder   (2005-12-03 02:20:00) [20]

Можно и так, я против ничего не имею, просто рассказал как сам делал.

Страницы:   1 2

Наверх

Титульная страница Поиск, карта сайта Написать письмо