PHP DM Gate v0.9 » Lupa <span class="vd">[Delphi, Windows]</span>

RusSun © (16.02.11 22:12) [0]

Доброе время суток.
Пробую переписать с VCL Экранную лупу.
Вот пока что имеется.

program Project1;

uses
windows,messages,
kol;
const
Diametre = 300;
{$R *.res}
var
form,Loupe:PControl;
hRegion: HRgn;
Width:integer;
//переменные для ScreenRelease
DeskDC : HDC;
HDeskBmp : HBitmap;

//область для процедур
procedure MouseDown(Sender: PControl;var mouse:TMouseEventData);
begin
releasecapture();
form.Perform(wm_syscommand,$F012,0);
end;

procedure ScreenRelease;
begin
if HDeskBmp<> 0 then
begin
DeleteObject(HDeskBmp);
HDeskBmp:= 0;
end;
if DeskDC<> 0 then
begin
ReleaseDC(GetDesktopWindow, DeskDC);
DeskDC:= 0;
end;
end;
procedure ScreenCapture;
var
MemDC: HDC;
W, H: Integer;
begin
if (HDeskBmp<> 0)or (DeskDC<> 0) then
Exit;
W:= GetSystemMetrics(SM_CXSCREEN);
H:= GetSystemMetrics(SM_CYSCREEN);
DeskDC:= GetDC(GetDesktopWindow);

MemDC:= CreateCompatibleDC(DeskDC);
{ создаём handle для bitmap'а совместимый с устройством}
HDeskBmp:= CreateCompatibleBitmap(DeskDC, W, H);
{ выбираем битмар}
SelectObject(MemDC, HDeskBmp);
{ копируем фон }
BitBlt(MemDC, 0, 0, W, H, DeskDC, 0, 0, SRCCOPY);
{освобождаем контекст устройства }
DeleteDC(MemDC);
end;
procedure DrawFilter;
var
DrawToDC: HDC;
MemDC: HDC;
OldBmp: HBitMap;
OffsetX, OffsetY: Integer;
begin
if Loupe= nil then Exit;
DrawToDC:= Loupe.Canvas.Handle;
// Копируем фоновое изображение
MemDC:= CreateCompatibleDC(DeskDC);
OldBmp:= SelectObject(MemDC, HDeskBmp);
OffsetX:= Width div 4;
OffsetY:= Width div 4;
StretchBlt(DrawToDC, 0, 0, Width, Width, MemDC, form.Left + OffsetX, form.Top + OffsetY, Width div 2, Width div 2, SRCCOPY);
SelectObject(MemDC, OldBmp);
DeleteObject(MemDC);

with Loupe.Canvas^ do
begin
Brush.Color:= clYellow;
Brush.BrushStyle:= bsClear;
Pen.PenWidth:=2;
Pen.Color:= clYellow;
Pen.PenStyle:= psSolid;
Ellipse(1, 1, Width- 2, Width- 2);
Pen.Color:= clOlive;
Pen.PenStyle:= psSolid;
Ellipse(2, 2, Width- 1, Width- 1);
end;
end;
function FormMessage(Dummy : Pointer;var Msg: tagMSG; var Rslt: Integer): Boolean;
begin
Result := False;

if Msg.message = WM_NCACTIVATE then
ScreenCapture else ScreenRelease;

if Msg.message = WM_ERASEBKGND then
begin
Rslt := 1;
Result := TRUE;
end;
if Msg.message = WM_WINDOWPOSCHANGED then //or WM_WINDOWPOSCHANGING
begin
Rslt := 1;
Result := TRUE;
DrawFilter;
Form.Invalidate;
form.Update;
end;

//if Msg.message = WM_PAINT then form.Canvas.draw(0,0,Loupe);
end;

procedure FormPaint(Sender: TObject);
begin
//?.Draw(Loupe.Canvas.Handle,0,0); //???
end;//в VCL было form.Canvas.draw(0,0,Loupe);

procedure FormDestroy(Sender: TObject);
begin
ScreenRelease;
Loupe.Free;
end;

Begin
Applet := NewApplet('');
form:=NewForm(Applet,'Лупа').centeronparent.Tabulate;
Width := Diametre;
// создаём PaintBox "off line"
Loupe := NewPaintBox(form);
Loupe.Width:= Width;
Loupe.Height:=Width;

hRegion:= CreateEllipticRgn(0, 0, Width, Width);
if hRegion<> 0 then SetWindowRgn(form.GetWindowHandle , hRegion, TRUE);
HDeskBmp:= 0;
DeskDc:= 0;
ScreenCapture;
DrawFilter;
//область для работы
Loupe.OnMessage:=TOnMessage(MakeMethod(nil,@FormMessage));
Loupe.OnMouseDown:=TOnMouse(MakeMethod(nil,@MouseDown));
Loupe.OnPaint:=TOnPaint( MakeMethod( nil, @DrawFilter ));
//Loupe.Style := WS_POPUP or WS_VISIBLE;
Run(form);
end.

1 Рисование так и не выходит.
2 Виден заголовок.

<Цитата>
Rouse_ © (16.02.11 22:39) [1]

Внимание - вопрос:

<Цитата>
Jon © (17.02.11 04:28) [2]

I once wrote a simple screen magnifier with KOL - maybe my code will help you:

program Magnify;

uses
Windows, Messages, KOL;

const
ZoomRatio: Integer = 2; // Change this for zoom level

var
PaintBox: PControl;
Image: PBitmap;

procedure PaintPreview(Dummy: Pointer; Sender: PControl; DC: HDC);
begin
Image.Draw(Sender.Canvas.Handle, 0,0);
end;

procedure TimerTick(Dummy: Pointer; Sender: PObj);
var
ZoomRect: TRect;
DC: HDC;
Cursor: TPoint;
begin
GetCursorPos(Cursor);
ZoomRect := MakeRect(Cursor.X, Cursor.Y, Cursor.X, Cursor.Y);
InflateRect(ZoomRect, Round(Image.Width / (2 * ZoomRatio)), Round(Image.Height / (2 * ZoomRatio)));
if ZoomRect.Left < 0 then
OffsetRect(ZoomRect, -ZoomRect.Left, 0);
if ZoomRect.Top < 0 then
OffsetRect(ZoomRect, 0, -ZoomRect.Top);
if ZoomRect.Right > ScreenWidth then
OffsetRect(ZoomRect, -(ZoomRect.Right - ScreenWidth), 0);
if ZoomRect.Bottom > ScreenHeight then
OffsetRect(ZoomRect, 0, -(ZoomRect.Bottom - ScreenHeight));
DC := GetDC(GetDesktopWindow);
StretchBlt(Image.Canvas.Handle, 0, 0, Image.Width, Image.Height, DC, ZoomRect.Left, ZoomRect.Top, ZoomRect.Right - ZoomRect.Left, ZoomRect.Bottom - ZoomRect.Top, SRCCOPY);
PaintBox.Invalidate;
ReleaseDC(GetDesktopWindow, DC);
end;

procedure MouseDown(Dummy: Pointer; Sender: PControl; var Mouse: TMouseEventData);
begin
case Mouse.Button of
mbLeft: Sender.WindowedParent.DragStart;
mbRight: Applet.Close;
end;
end;

procedure AppResize(Dummy: Pointer; Sender: PObj);
begin
Image.Width := PaintBox.Width;
Image.Height := PaintBox.Height;
end;

begin
Applet := NewForm(Applet, 'KOL Zoomer');
with Applet^ do
begin
StayOnTop := True;
MinWidth := 120;
MinHeight := 120;
MaxWidth := ScreenWidth div 2;
MaxHeight := ScreenHeight div 2;
Style := Style and not WS_MAXIMIZEBOX;
Perform(WM_INITMENU, 0, 0);
SetSize(MinWidth, MinHeight);
HasCaption := False;
end;
PaintBox := NewPaintbox(Applet);
with PaintBox^ do
begin
Align := caClient;
OnPaint := TOnPaint(MakeMethod(nil, @PaintPreview));
OnMouseDown := TOnMouse(MakeMethod(nil, @MouseDown));
OnResize := TOnEvent(MakeMethod(nil, @AppResize));
end;
Image := NewBitmap(Applet.ClientWidth, Applet.ClientHeight);
with NewTimer(20)^ do
begin
OnTimer := TOnEvent(MakeMethod(nil, @TimerTick));
Enabled := True;
end;
SetProcessWorkingSetSize(GetCurrentProcess, Cardinal(-1), Cardinal(-1));
Run(Applet);
end.

<Цитата>
RusSun © (17.02.11 05:00) [3]

Thank you very much. You really helped me.

<Цитата>
Jon © (17.02.11 13:27) [4]

I'm glad that it was of help. If you improve the code then please share it.

<Цитата>
RusSun © (18.02.11 05:38) [5]

Теряется оконтовка при рисовании,
пока сделал ещё один регион.
StretchBlt(Img.Canvas.Handle, 0, 0, Width, Width, MemDC, form.Left + OffsetX, form.Top + OffsetY, Width div 2, Width div 2, SRCCOPY);
Loupe.Invalidate;//Заставляем перерисовываться чтобы избавится от мелькания
//но тогда теряется оконтовка лупы
SelectObject(MemDC, OldBmp);
DeleteObject(MemDC);
with Loupe.Canvas^ do //рисуем оконтовку
begin
Brush.Color:= clYellow;
Brush.BrushStyle:= bsClear;
Pen.PenWidth:=2;
Pen.Color:= clYellow;
Pen.PenStyle:= psSolid;
Ellipse(1, 1, Width- 2, Width- 2);
Pen.Color:= clOlive;
Pen.PenStyle:= psSolid;
Ellipse(2, 2, Width- 1, Width- 1);
end;
end;

Недостатки:

1 если запустить при открытой папке, то свернув папку будет видно что в ней
2 не сделал пока увеличение и уменьшение хочу сделать его в сообытии кручения колеса мыши.

Вот весь код:
program Project1;

uses
windows,messages,
kol;
const
Diametre = 300;
{$R *.res}
var
form,Loupe:PControl;
hRegion,hRegP: HRgn;
Width:integer;
//переменные для ScreenRelease
DeskDC : HDC;
HDeskBmp : HBitmap;
//картинка
Img: PBitmap;
//область для процедур
procedure MouseDown(Sender: PControl;var mouse:TMouseEventData);
begin
releasecapture();
form.Perform(wm_syscommand,$F012,0);

end;

procedure ScreenRelease;
begin
if HDeskBmp<> 0 then
begin
DeleteObject(HDeskBmp);
HDeskBmp:= 0;
end;
if DeskDC<> 0 then
begin
ReleaseDC(GetDesktopWindow, DeskDC);
DeskDC:= 0;
end;
end;
procedure ScreenCapture;
var
MemDC: HDC;
W, H: Integer;
begin
if (HDeskBmp<> 0)or (DeskDC<> 0) then
Exit;
W:= GetSystemMetrics(SM_CXSCREEN);
H:= GetSystemMetrics(SM_CYSCREEN);
DeskDC:= GetDC(GetDesktopWindow);

MemDC:= CreateCompatibleDC(DeskDC);
{ создаём handle для bitmap'а совместимый с устройством}
HDeskBmp:= CreateCompatibleBitmap(DeskDC, W, H);
{ выбираем битмар}
SelectObject(MemDC, HDeskBmp);
{ копируем фон }
BitBlt(MemDC, 0, 0, W, H, DeskDC, 0, 0, SRCCOPY);
{освобождаем контекст устройства }
DeleteDC(MemDC);
end;
procedure DrawFilter;
var
MemDC: HDC;
OldBmp: HBitMap;
OffsetX, OffsetY: Integer;
begin
if Loupe= nil then Exit;
// Копируем фоновое изображение
MemDC:= CreateCompatibleDC(DeskDC);
OldBmp:= SelectObject(MemDC, HDeskBmp);
OffsetX:= Width div 4;
OffsetY:= Width div 4;
StretchBlt(Img.Canvas.Handle, 0, 0, Width, Width, MemDC, form.Left + OffsetX, form.Top + OffsetY, Width div 2, Width div 2, SRCCOPY);
Loupe.Invalidate;//Заставляем перерисовываться чтобы избавится от мелькания
//но тогда теряется оконтовка лупы
SelectObject(MemDC, OldBmp);
DeleteObject(MemDC);
{with Loupe.Canvas^ do //рисуем оконтовку
begin
Brush.Color:= clYellow;
Brush.BrushStyle:= bsClear;
Pen.PenWidth:=2;
Pen.Color:= clYellow;
Pen.PenStyle:= psSolid;
Ellipse(1, 1, Width- 2, Width- 2);
Pen.Color:= clOlive;
Pen.PenStyle:= psSolid;
Ellipse(2, 2, Width- 1, Width- 1);
end;}
end;
procedure TimerTick(Dummy: Pointer; Sender: PObj);
begin
ScreenCapture;
DrawFilter;
end;

procedure FormPaint(Dummy: Pointer; Sender: PControl; DC: HDC);
begin
Img.Draw(Sender.Canvas.Handle,0,0);
end;
function AppletMessage(Dummy : Pointer;var Msg: tagMSG; var Rslt: Integer): Boolean;
begin
Result := False;
if (Msg.message = WM_KEYDOWN) and ( Msg.wParam = VK_ESCAPE) then form.close;
end;
procedure FormDestroy(Sender: TObject);
begin
ScreenRelease;
Loupe.Free;
end;

Begin
Applet := NewApplet('');
form:=NewForm(Applet,'Лупа').centeronparent.Tabulate;
Width := Diametre;

Img := NewBitmap(form.ClientWidth,form.ClientHeight);
// создаём PaintBox "off line"
hRegP:=CreateEllipticRgn(4, 4, Width-4, Width-4);
Loupe := NewPaintBox(form);
//Loupe.Align := caClient;
Loupe.Width:= Width;
Loupe.Height:=Width;
if hRegP<> 0 then SetWindowRgn(Loupe.GetWindowHandle , hRegP, TRUE);

hRegion:= CreateEllipticRgn(0, 0, Width+3, Width+3);
if hRegion<> 0 then SetWindowRgn(form.GetWindowHandle , hRegion, TRUE);
HDeskBmp:= 0;
DeskDc:= 0;
ScreenCapture;
DrawFilter;

with NewTimer(100)^ do
begin
OnTimer := TOnEvent(MakeMethod(nil, @TimerTick));
Enabled := True;
end;

//область для работы
Loupe.OnMouseDown:=TOnMouse(MakeMethod(nil,@MouseDown));
Loupe.OnPaint:=TOnPaint( MakeMethod( nil, @FormPaint ));
form.Style := WS_POPUP or WS_VISIBLE;
form.StayOnTop := True;
Applet.OnMessage:=TOnMessage(MakeMethod(nil,@AppletMessage));
SetProcessWorkingSetSize(GetCurrentProcess, Cardinal(-1), Cardinal(-1));
Run(Applet);
end.

<Цитата>
Jon © (18.02.11 15:31) [6]

I hope that I understand you correctly:

> Brush.Color:= clYellow;

Applet.Color := clYellow;

> 1.

function AppletMessage(Dummy: Pointer; var Msg: tagMSG; var Rslt: Integer): Boolean;
begin
Result := False;
if (Msg.message = WM_KEYDOWN) and (Msg.wParam = VK_ESCAPE) then
form.close;
if (Msg.message = WM_KEYDOWN) and (Msg.wParam = VK_F5) then
begin
Result := True;
form.Hide;
Sleep(100);
DeskDC := 0;
HDeskBmp := 0;
ScreenCapture;
DrawFilter;
form.Show;
end;
end;

> 2.

Use .OnMouseWheel or hook the mouse messages - SetWindowsHookEx(WH_MOUSE, @HookProc, HInstance,0) ;

<Цитата>
RusSun © (18.02.11 18:12) [7]

Yes, you understood correctly!

I found a small bug in my code.

Applet.Color := clYellow;
Width := Diametre;
form:=NewForm(Applet,'Лупа').setsize(324,324).centeronparent.Tabulate;

Again, thank you:)

About > 2. I'll try.)

<Цитата>
RusSun © (08.04.11 16:14) [8]

About > 2. I'll try.)

var ...z:real;
...
procedure MMouseWheel(Dummy:pointer;Sender: PControl;
var Mouse: TMouseEventData);
begin
if Integer( Mouse.Shift ) > 0 then
i:=i+10
else
i:=i-10;
Mouse.StopHandling := TRUE;
case i of
-10:i:=0;
0:begin z:=1;
ScreenCapture;
DrawFilter;
form.Show;
end;
10:;
20:begin z:=1.5;
ScreenCapture;
DrawFilter;
form.Show;
end;
30:;
40:begin z:=3;
ScreenCapture;
DrawFilter;
form.Show;
end;
50:;
60: i:=50;
end;{case}

end;
...
form.OnMouseWheel:=TOnMouse(MakeMethod(nil,@MMouseWheel));

Вот. Хочу к нему сделать визуальный эффект.
Это "веер" из RoundRectRgn'ов который раскрывается при усилении
увеличения лупы.

Вопрос: Как сделать область в которой развернутся регионы невидимой
чтоб видно было только веер (при развёртке)?

[URL=http://www.radikal.ru][IMG]http://s011.radikal.ru/i315/1104/ae/49f0da395296.jpg[/IMG][/URL]

<Цитата>
RusSun © (08.04.11 16:22) [9]

http://s011.radikal.ru/i315/1104/ae/49f0da395296.jpg

<Цитата>
Jon © (08.04.11 21:38) [10]

Shaping a Form around a Bitmap: http://www.delphi-central.com/BitmapShapedForm.aspx

<Цитата>
RusSun © (13.04.11 17:03) [11]

to Jon Thank you just is not quite like. But it gave some idea. True, the idea does not work either.

In such a case is cut area which in turn gives invisibility. In my case, the region should be and remain invisible so that the torsional regions which will become visible to the user.

//В таком случае происходит вырезание области что в свою очередь даёт невидимость. В моём случае область должна быть и оставаться невидимой чтоб при кручении регионы которые появятся стали видны пользователю.

<Цитата>
RusSun © (21.03.15 21:11) [12]

Итак визуальный эффект.
Хочу сделать как здесь
https://yadi.sk/d/ra70yBXofRAid

Попытки получаются такими
https://yadi.sk/d/FN8mLgTafRBB3
https://yadi.sk/d/KV9fHiqWfRBCz

Подскажите, где грабли?

<Цитата>
QAZ (22.03.15 20:40) [13]

фигасе ты упорный, 4 года лупу ваяешь
грабли наверно в том, что ты хочешь как там, где слоистое окно, а делаешь при этом региональное?

<Цитата>
Sheleh (22.03.15 21:27) [14]

По-моему лучше будет не через таймер, а рисовать по событию WM_MOUSEMOVE.
Т.е. по WM_LBUTTONDOWN запоминаем первоначальные координаты окна, по WM_MOUSEMOVE вычисляем новые координаты, и отрисовываемся. Что бы не потерять окно, я ставлю SetCapture. А сверху основного окна можно таскать одновременно окно с AlphaBlend и текстурой линзы. Ну я бы так сделал )

<Цитата>
famrus (25.03.15 19:07) [15]

> фигасе ты упорный, 4 года лупу ваяешь

Всё руки никак не доходили. Потом появилось время.
Сел. Посмотрел. Поковырял.

> По-моему лучше будет не через таймер, а рисовать по событию
> WM_MOUSEMOVE.

Если можно кинь небольшой пример так нагляднее и быстрее реализовать идею.

Спасибо за советы.

<Цитата>
QAZ (25.03.15 20:45) [16]

аяяяяй спалился, 2 форумных ника - бан тебе вечный по правилам :)

<Цитата>
RusSun © (26.03.15 19:44) [17]

Не обратил внимания. Ник один. Сорри.

<Цитата>
RusSun © (26.03.15 19:47) [18]

Уважаемый модератор Удалите сообщения с ником famrus. Спасибо.

<Цитата>
Sheleh (28.03.15 06:26) [19]

Вот немного накидал для демонстрации производительности.

program Lupe; uses Windows, KOL, messages; var LupeForm: PControl; Diametre: Integer; StartPos: TPoint; Moving: Boolean; DC:hDC; BgScrBt: PBitmap; procedure ScreenCopy(); var W,H: integer; begin W:= GetSystemMetrics(SM_CXSCREEN); H:= GetSystemMetrics(SM_CYSCREEN); BgScrBt := NewBitmap( W, H ); BitBlt(BgScrBt.canvas.Handle, 0,0, W, H, GetDC(0), 0, 0, SRCCOPY); end; function LupeWndProc(Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; var pt: TPoint; R: TRect; begin Result:=False; case Msg.message of WM_CREATE: begin ScreenCopy; DC:=GetDC(LupeForm.Handle); end; WM_LBUTTONDOWN: begin GetCursorPos(pt); Moving:=True; Sender.Caption:='Moving'; StartPos.X:=pt.x-Sender.Left; StartPos.Y:=pt.Y-Sender.Top; SetCapture(Sender.Handle); end; WM_LBUTTONUP: begin Moving:=False; Sender.Caption:='Lupe'; ReleaseCapture(); end; WM_MOUSEMOVE: if Moving then begin GetCursorPos(pt); SetWindowPos(Sender.Handle,0, pt.X-StartPos.X, pt.Y-StartPos.Y, 0, 0, SWP_NOSIZE {or SWP_NOREDRAW}); end; WM_ERASEBKGND: begin StretchBlt(DC, 0, 0, Sender.Width, Sender.Height, BgScrBt.Canvas.Handle, Sender.Left, Sender.Top, Sender.Width div 2, Sender.Width div 2, SRCCOPY); Result:=True; end; WM_PAINT: begin Result:=True; end; end; end; begin Diametre:=300; LupeForm:=NewForm(Applet, 'Lupe').Size(Diametre, Diametre); LupeForm.AttachProc(@LupeWndProc); Run(LupeForm); end.

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

<Цитата>