Форум: "Основная";
Текущий архив: 2009.10.18;
Скачать: [xml.tar.bz2];
ВнизРеализация полупрозрачного прямоугольника Найти похожие ветки
← →
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;
Скачать: [xml.tar.bz2];
Память: 0.46 MB
Время: 0.009 c