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.

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.

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;

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.

Applet.Color := clYellow;

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;

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

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));

procedure ScreenCopy();
var W,H: integer;
begin
 W:= GetSystemMetrics(SM_CXVIRTUALSCREEN);
 H:= GetSystemMetrics(SM_CYVIRTUALSCREEN);
 BgScrBt := NewBitmap( W, H );
 BitBlt(BgScrBt.canvas.Handle, 0,0, W, H, GetDC(0), 0, 0, SRCCOPY);
end;

   WM_ERASEBKGND:
    begin
      If (sender.left < 0) or (sender.Top < 0) then
         FillRect(DC,MakeRect(0,0,Sender.Width+sender.left, Sender.Height+Sender.Top), GetStockObject(BLACK_BRUSH));
      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;