Текущий архив: 2009.10.18;
Скачать: CL | DM;

Вниз

Реализация полупрозрачного прямоугольника   Найти похожие ветки 

← →
dmitry_12_08_73 ©   (2008-08-24 15:59) [0]

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

---

← →
{RASkov} ©   (2008-08-24 16:06) [1]

Подготовка: Снимаем скриншот экрана и показываем форму без бордюров и на весь экран, на которую "наносим" снятый скриншот картинку.
Далее уже работаем с картинкой. Обрабатывая события мыши и рисуем на картинке прямоугольник какой душе угодно.
После отпускания кнопки мыши, прячем форму со скриншотом. А у нас теперь есть рект, область на экране.... Далее...

---

← →
{RASkov} ©   (2008-08-24 16:56) [2]

Примерная реализация [1] "на коленке"
unit Unit1;
interface
uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;

type
 TForm1 = class(TForm)
   Button1: TButton;
   procedure Button1Click(Sender: TObject);
 private
   BMP: TBitmap;
   RC: TRect;
   DC: HDC;
   FMouseDown: Boolean;
   procedure FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
   procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
   procedure FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
   procedure FrmPaint(Sender: TObject);
   { Private declarations }
 public
   { Public declarations }
 end;

var
 Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
 RC.Left:=X;
 RC.Top:=Y;
 FMouseDown:=True;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
 if not FMouseDown then Exit;
 RC.Right:=X;
 RC.Bottom:=Y;
 TForm(Sender).Invalidate;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
 FMouseDown:=False;
 if (RC.Left>=RC.Right) or (RC.Top>=RC.Bottom) then
  ShowMessage("Не верно выделен прямоугольник! Пробуйте ещё")
 else TForm(Sender).Close;
end;

procedure TForm1.FrmPaint(Sender: TObject);
begin
 with TForm(Sender).Canvas do begin
  Draw(0,0, BMP);
  if FMouseDown then with TForm(Sender).Canvas do begin
   Brush.Style:=bsDiagCross;
   if (RC.Left>=RC.Right) or (RC.Top>=RC.Bottom) then Pen.Color:=clRed else Pen.Color:=clBlue;
   Rectangle(RC);
  end;
 end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 Hide;
 Sleep(100); //Иначе окна не успевают перерисоваться :(
 BMP:=TBitmap.Create;
 try
  with TForm.Create(nil) do try
   FMouseDown:=False;
   DoubleBuffered:=True;
   WindowState:=wsMaximized;
   BorderStyle:=bsNone;
   OnMouseDown:=FormMouseDown;
   OnMouseMove:=FormMouseMove;
   OnMouseUp:=FormMouseUp;
   OnPaint:=FrmPaint;
   BMP.Width:=Screen.Width;
   BMP.Height:=Screen.Height;
   DC:=GetDC(0);
   BitBlt(BMP.Canvas.Handle, 0, 0, BMP.Width, BMP.Height, DC, 0, 0, SRCCOPY);
   ShowModal;
   BMP.Width:=RC.Right-RC.Left;
   BMP.Height:=RC.Bottom-RC.Top;
   BitBlt(BMP.Canvas.Handle, 0, 0, BMP.Width, BMP.Height, DC, RC.Left, RC.Top, SRCCOPY);
  finally
   Free;
  end;
 finally
  Show;
  Self.Canvas.Draw(10, 10, BMP);
  BMP.Free;
 end;
end;

end.

С рисованием я не шибко знаком, поэтому полупрозрачную рамку не стал делать, да и "косяки" есть в коде, но думаю, для примера хватит...

---

← →
{RASkov} ©   (2008-08-24 17:01) [3]

Ой, DC забыл высвободить :(
ReleaseDC(0, DC); в первом финале т.е. во внутреннем....

---

← →
{RASkov} ©   (2008-08-24 17:38) [4]

В FrmPaint достаточно одного with ...первого :)
И после ShowModal тоже нужно поспать немножко, иначе тажа проблема с перерисовкой....)
BMP можно не освобождать, а рисовать его на OnPaint основного окна...(это для этого примера)
procedure TForm1.FormPaint(Sender: TObject);
begin
 if Assigned(BMP) then Canvas.Draw(10, Button1.Height+10, BMP);
end;
Это наверное не все косяки(недоделки).... так, что внимательнее, а не копи-паст...
Да и вообще можно(или нужно) все переделать по уму, а не на коленке...)

---

← →
dmitry_12_08_73 ©   (2008-08-24 20:23) [5]

Спасибо Вам, буду пробовать

---

Страницы: 1 вся ветка

Текущий архив: 2009.10.18;
Скачать: CL | DM;

Наверх

Память: 0.48 MB
Время: 0.014 c