Отправляет email-рассылки с помощью сервиса Sendsay

Советы по Delphi

Рассылка закрыта

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

Вы можете найти рассылки сходной тематики в Каталоге рассылок.

←   Январь 2002   →
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
Автор
Сергей

Статистика

13.545 подписчиков
-22 за неделю
←   Все выпуски   →

Советы по Delphi


Служба Рассылок Subscribe.Ru

Здравствуйте, уважаемые подписчики! Извините за перерыв. Сегодня поговорим о том, как реализовать выделение "резиновым прямоугольником". Иными словами, когда пользоватьль нажимает на левую кнопку мыши и сдвигает ее, на экране появляется прямоугольник, изменяющий размеры при движении мыши, причем все объекты, попавшие в этот прямоугольник выделяются.

В качестве объекта я взял Label, меняющий цвет в зависимости от того, выделен он или нет. При нажатии мышью на форме в FirstPoint кладутся координата курсора. При дальнейшем движении мыши координаты прямоугольника будут высчитываться по FirstPoint и текущим координатам курсора. Причем, чтобы программа нормально отрабатывала случай, когда высота или ширина прямоугольника отрицательная (это произойдет, если увести мышь левее или выше начальной точки), создана процедура NormalRect. NormalRect устанавливает координаты прямоугольника sel по координатам двух протвоположенных углов прямоугольника, вне зависимости от порядка. DrawRect рисует на форме прямоугольник, использую режим XOR. Благодаря этому режиму, чтобы стереть такой прямоугольник, достаточно нарисовать его повторно.

Скачать необходимые для компиляции файлы проекта можно на program.dax.ru/subscribe/. 

uses stdctrls;

var
  Selecting: boolean = false;
  FirstPoint: TPoint;
  sel: TRect;

procedure DrawRect;
begin
  with Form1.Canvas do begin
    Pen.Style := psDot;
    Pen.Color := clGray;
    Pen.Mode := pmXor;
    Brush.Style := bsClear;
    Rectangle(sel.Left, sel.Top, sel.Right, sel.Bottom);
  end;
end;

procedure NormalRect(p1, p2: TPoint);
begin
  if p1.x < p2.x then begin
    sel.Left := p1.x;
    sel.Right := p2.x;
  end else begin
    sel.Left := p2.x;
    sel.Right := p1.x;
  end;
  if p1.y < p2.y then begin
    sel.Top := p1.y;
    sel.Bottom := p2.y;
  end else begin
    sel.Top := p2.y;
    sel.Bottom := p1.y;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var i: integer;
begin
  randomize;
  for i := 1 to random(5) + 5 do begin
    with TLabel.Create(Form1) do begin
      Caption := 'Label' + IntToStr(i);
      Left := random(Form1.ClientWidth - Width);
      Top := random(Form1.ClientHeight - Height);
      Visible := true;
      Parent := Form1;
    end;
  end;
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if selecting or (Button <> mbLeft) then Exit;
  SetCapture(Form1.Handle);
  Selecting := true;
  FirstPoint := Point(X, Y);
  sel := Bounds(X, Y, 0, 0);
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
  procedure SelectLebel(lb: TLabel; r: TRect);
  var
    select: boolean;
    res: TRect;
  begin
    select := IntersectRect(res, lb.BoundsRect, r);
    if select and (lb.Color = clNavy) then Exit;
    if select then begin
      lb.Color := clNavy;
      lb.Font.Color := clWhite;
    end else begin
      lb.Color := clBtnFace;
      lb.Font.Color := clBlack;
    end;
  end;
var
  i: integer;
begin
  if not Selecting then Exit;
  DrawRect;
  NormalRect(FirstPoint, Point(X, Y));
  for i := 0 to Form1.ComponentCount - 1 do
    if (Form1.Components[i] is TLabel) then
      SelectLebel(Form1.Components[i] as TLabel, sel);
  Application.ProcessMessages;
  DrawRect;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if (not Selecting) or (Button <> mbLeft) then Exit;
  NormalRect(FirstPoint, Point(X, Y));
  DrawRect;
  ReleaseCapture;
  Selecting := false;
end;

Программа была протестирована:
Дмитрий Бажин
Юрий Кравченко

Все советы и замечания, пожалуйста, присылайте на subscribe@program.dax.ru

Всего доброго,
Даниил Карапетян.




http://subscribe.ru/
E-mail: ask@subscribe.ru 		Отписаться
Убрать рекламу
В избранное