Delphi World - Копирование экрана
Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Копирование экрана


Новая марка монохромных мониторов ViewSonic имеет в качестве символа трех пингвинов.


unit ScrnCap;

interface

uses
  WinTypes, WinProcs, Forms, Classes, Graphics, Controls;

{ Копирует прямоугольную область экрана }
function CaptureScreenRect(ARect : TRect) : TBitmap;
{ Копирование всего экрана }
function CaptureScreen : TBitmap;
{ Копирование клиентской области формы или элемента }
function CaptureClientImage(Control : TControl) : TBitmap;
{ Копирование всей формы элемента }
function CaptureControlImage(Control : TControl) : TBitmap;

implementation

function GetSystemPalette : HPalette;
var
  PaletteSize : integer;
  LogSize : integer;
  LogPalette : PLogPalette;
  DC : HDC;
  Focus : HWND;
begin
  result:=0;
  Focus:=GetFocus;
  DC:=GetDC(Focus);
  try
    PaletteSize:=GetDeviceCaps(DC, SIZEPALETTE);
    LogSize:=SizeOf(TLogPalette)+(PaletteSize-1)*SizeOf(TPaletteEntry);
    GetMem(LogPalette, LogSize);
    try
      with LogPalette^ do
      begin
        palVersion:=$0300;
        palNumEntries:=PaletteSize;
        GetSystemPaletteEntries(DC, 0, PaletteSize, palPalEntry);
      end;
      result:=CreatePalette(LogPalette^);
    finally
      FreeMem(LogPalette, LogSize);
    end;
  finally
    ReleaseDC(Focus, DC);
  end;
end;


function CaptureScreenRect(ARect : TRect) : TBitmap;
var
  ScreenDC : HDC;
begin
  Result:=TBitmap.Create;
  with result, ARect do
  begin
    Width:=Right-Left;
    Height:=Bottom-Top;
    ScreenDC:=GetDC(0);
    try
      BitBlt(Canvas.Handle, 0,0,Width,Height,ScreenDC, Left, Top, SRCCOPY );
    finally
      ReleaseDC(0, ScreenDC);
    end;
    Palette:=GetSystemPalette;
  end;
end;

function CaptureScreen : TBitmap;
begin
  with Screen do
    Result:=CaptureScreenRect(Rect(0,0,Width,Height));
end;

function CaptureClientImage(Control : TControl) : TBitmap;
begin
  with Control, Control.ClientOrigin do
    result:=CaptureScreenRect(Bounds(X,Y,ClientWidth,ClientHeight));
end;

function CaptureControlImage(Control : TControl) : TBitmap;
begin
  with Control do
    if Parent=nil then
      result:=CaptureScreenRect(Bounds(Left,Top,Width,Height))
    else
      with Parent.ClientToScreen(Point(Left, Top)) do
        result:=CaptureScreenRect(Bounds(X,Y,Width,Height));
end;

end.

Проект Delphi World © Выпуск 2002 - 2017
Автор проекта: Эксклюзивные курсы программирования