Скриншотер на Дельфи

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

• из-за использования .NET скриншотер запускается не сразу, а через некоторое время (у меня 2 секунды)
• GDI+ по умолчанию используемая в .NET достаточна медленна

Поэтому я решил написать скриншотер работающий с GDI.
Возможности следующие:

• Выделение сохраняемого участка (правильная обработка выделения из нижнего правого угла в верхний левый угол)
• автоматическое сохранение в «Мои Документы»
• Копирование в буфер обмена картинки или пути файла
• настройки выделения

Весь код написан на Дельфи без использования сторонних библиотек и использует WinAPI, а не Canvas, что увеличивает скорость.
Для настройки используется .ini файл.

unit Screens;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls,Clipbrd,INIFiles,ShlObj;

type
TFormCopy = class(TForm)
text: TStaticText;
procedure FormCreate(Sender: TObject);
procedure FormKeyPress(Sender: TObject; var Key: Char);
procedure FormDestroy(Sender: TObject);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormPaint(Sender: TObject);

private
{ Private declarations }
public
{ Public declarations }
end;

var
FormCopy: TFormCopy;

implementation

{$R *.dfm}
type TCord=record
X1,Y1,X2,Y2:integer;
Height,Width:integer;
end;

type TConfigs=record
SaveToClipboard:String;
SaveFile:Boolean;
FilePath:String;
WidthPen:integer;
ColorPen:TColor;
end;

var
BitMapHandle,BufHandle:HDC;
BitMap,Buf:HBitMap;
Copy:TCord;
RunCopy:Boolean;
Configs:Tconfigs;

////////////////////////////////////////////////////////////////////////////////

{Функция для получения путей системных папок}
function GetSpecialPath(CSIDL: word): string;
var s: string;
begin
SetLength(s, MAX_PATH);
if not SHGetSpecialFolderPath(0, PChar(s), CSIDL, true)
then s := '';
result := PChar(s);
end;

{создание снимка и буфера экрана}
Procedure CreateBitMaps;
var DesktopHandle:HDC;
begin
DesktopHandle:=GetDC(GetDesktopWindow);//Handle экрана
{копия экрана}
BitMapHandle:=CreateCompatibleDC(GetDC(0));//создание совместимого handl-а
BitMap:=CreateCompatibleBitmap(GetDC(0),screen.Width,screen.Height);//создание совместимой битовой карты
SelectObject(BitMapHandle,BitMap);//применение
BitBlt(BitMapHandle,//копирование экрана
0,0,screen.Width,screen.Height,
DesktopHandle,0,0,
SRCCOPY);

{буфер (чтобы избавиться от мерцания) }
BufHandle:=CreateCompatibleDC(GetDC(0));//создание совместимого handl-а
buf:=CreateCompatibleBitmap(GetDC(0),screen.Width,screen.Height);//создание совместимой битовой карты
SelectObject(BufHandle,Buf);//применение

DeleteDC(DesktopHandle);//удаление Handl-а экрана
end;

{INI}
Procedure LoadINI();
var ini:tinifile;
begin
ini:=tinifile.Create(ExtractFilePath(paramstr(0))+'Config.ini');//открыть INI
Configs.SaveToClipboard:=ini.ReadString('Options','SaveToClipboard','Picture');//Что в буфер обмена
Configs.SaveFile:=ini.ReadBool('Options','SaveToFile',True);//сохранять в файл?

Configs.WidthPen:=ini.ReadInteger('Style','WidthPen',4);//ширина рамки
Configs.ColorPen:=RGB(//цвет рамки
ini.ReadInteger('Style','ColorRed',40),
ini.ReadInteger('Style','ColorGreen',100),
ini.ReadInteger('Style','ColorBlue',255) );

ini.Free;
end;

{Делаем правильный прямоугольник, т.е. x1<x2,y1<y2}
function stdCord(x1,y1,x2,y2:integer;border:integer):Tcord;
var tempVar:integer;
begin
///////Делаем правильный прямоугольник///////
if y1>y2 then
begin
tempVar:=y1;
y1:=y2;
y2:=tempVar;
end;
if x1>x2 then
begin
tempVar:=x1;
x1:=x2;
x2:=tempVar;
end;
///////Увеличиваем с каждой стороны на величину Border
y1:=y1-border;
x1:=x1-border;
y2:=y2+border;
x2:=x2+border;
//if y1<0 then y1:=0;if y2<0 then y2:=0;
//if y1>SourseData.Height-1 then y1:= SourseData.Height-1;if y2>SourseData.Height-1 then y2:= SourseData.Height-1;
//if x1<0 then x1:=0;if x2<0 then x2:=0;
//if x1>SourseData.Width-1 then x1:= SourseData.Width-1;if x2>SourseData.Width-1 then x2:= SourseData.Width-1;
stdCord.X1:=x1;
stdCord.Y1:=y1;
stdCord.X2:=x2;
stdCord.Y2:=y2;
stdCord.Width:=x2-x1;
stdCord.Height:=y2-y1;
end;

{Процедура сохранения скриншота}
Procedure SavePicture(PictureHandle:HDC;CopyRect:TCord;ToClipBoard:String;saveFile:Boolean);
var SaveBitMap:TBitMap;
tempCopy: Tcord;
ClipboardFormat: Word;
PicturePalette: HPALETTE;
PictureData: THandle;
time : TSYSTEMTIME;
begin
GetLocalTime(time);//получаем локальное время
tempCopy:=stdCord(CopyRect.X1,CopyRect.Y1,CopyRect.X2,CopyRect.Y2,0);//делаем "правильные" координаты

SaveBitMap:=TBitMap.Create;//создаем BitMap
SaveBitMap.Width:=TempCopy.Width;//размер по выделению
SaveBitMap.Height:=TempCopy.Height;

{Копирование в BitMap}
BitBlt(SaveBitMap.Canvas.Handle, //куда
0,0,TempCopy.X2,TempCopy.Y2,//координаты и размер
PictureHandle, //откуда
TempCopy.X1,TempCopy.Y1, //координаты
SRCCOPY); //режим копирования

if SaveFile then
begin
{Если нет требуемой директории, то создаем её}
if not DirectoryExists(GetSpecialPath(CSIDL_PERSONAL)+'\Screen',true) then
CreateDir(GetSpecialPath(CSIDL_PERSONAL)+'\Screen');
{Сохраняем картинку}
SaveBitMap.SaveToFile(GetSpecialPath(CSIDL_PERSONAL)+
'\Screen\'+
inttostr(time.wHour)+'-'+
inttostr(time.wMinute)+'-'+
inttostr(time.wSecond)+' '+
inttostr(time.wDay)+'.'+
inttostr(time.wMonth)+'.'+
inttostr(time.wYear)+
'.bmp');
end;

if ToClipBoard='Path' then//если надо копировать в буфер обмена
begin
Clipboard.SetTextBuf(PChar(GetSpecialPath(CSIDL_PERSONAL)+
'\Screen\'+
inttostr(time.wHour)+'-'+
inttostr(time.wMinute)+'-'+
inttostr(time.wSecond)+' '+
inttostr(time.wDay)+'.'+
inttostr(time.wMonth)+'.'+
inttostr(time.wYear)+
'.bmp'));
end else
begin
SaveBitMap.SaveToClipboardFormat(ClipboardFormat,PictureData,PicturePalette);
ClipBoard.SetAsHandle (ClipboardFormat, PictureData);
end;
SaveBitMap.Free;//освобождаем память
end;

{Рисование}
Procedure Drawing(BitMapHandle{скрин},BufHandle{буффер},Disp{куда рисовать}:HDC;
Copy:Tcord{Прямоугольник выделения};
WidthPen{ширина рамки}:integer;Color{цвет}:Tcolor);
var pen:HPen;
LogBrush:TLogBrush;
tempCopy:Tcord;
begin
BitBlt(bufHandle, //копирование снимка экрана в буфер
0,0,screen.Width,screen.Height,
BitMapHandle,0,0,
SRCCOPY);

if RunCopy=true then//если надо рисовать то...
begin
LogBrush.lbColor:=color;//Цвет кисти
LogBrush.lbStyle:=PS_SOLID;//Стиль (Сплошная)
pen:=ExtCreatePen(PS_INSIDEFRAME or PS_GEOMETRIC or PS_ENDCAP_FLAT or PS_JOIN_MITER ,
WidthPen,LogBrush, 0,nil);//Создаем перо на основе кисти
SelectObject(BufHandle,Pen);//применение
SelectObject(BufHandle,GetStockObject(NULL_BRUSH) );//делаем фон прямоугольника прозрачным
tempCopy:=stdCord(Copy.X1,Copy.Y1,Copy.X2,Copy.Y2,0);//делаем "правильные" координаты
Rectangle(BufHandle,//Рисуем выделение
tempCopy.X1-WidthPen,
tempCopy.Y1-WidthPen,
tempCopy.X2+WidthPen,
tempCopy.Y2+WidthPen );
SelectObject(BufHandle, GetStockObject(NULL_PEN)); //выбрали в контекст пустое перо
DeleteObject(Pen);//удаление пера из памяти
end else
begin
//
end;

BitBlt(Disp,//копируем буфер на экран
0,0,screen.Width,screen.Height,
BufHandle,0,0,
SRCCOPY);
end;

procedure TFormCopy.FormCreate(Sender: TObject);
begin
LoadINI;//загрузка настроек
CreateBitMaps;//создаем BitMap
{Размеры формы}
Width:=screen.Width;
Height:=screen.Height;
Visible:=true;//показываем форму
end;

procedure TFormCopy.FormDestroy(Sender: TObject);
begin
DeleteDC(BitMapHandle);
DeleteObject(BitMap);

DeleteDC(BufHandle);
DeleteObject(Buf);
end;

procedure TFormCopy.FormKeyPress(Sender: TObject; var Key: Char);
begin
close;
end;

procedure TFormCopy.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Copy.X1:=X;//начальные координаты
Copy.Y1:=Y;
Copy.X2:=X;
Copy.Y2:=Y;
runCopy:=true;//началось выделение
paint;
end;

procedure TFormCopy.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if runCopy=true then//если идет выделение то...
begin
Copy.X2:=X+1;
Copy.Y2:=Y+1;
paint;
end;
end;

procedure TFormCopy.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
paint;
runCopy:=false;//закончилось выделение
SavePicture(BufHandle,copy,Configs.SaveToClipboard,Configs.SaveFile);//сохранение
close;
end;

procedure TFormCopy.FormPaint(Sender: TObject);
begin
Drawing(BitMapHandle,BufHandle,canvas.Handle,
copy,configs.WidthPen,configs.ColorPen);
end;

end.

Проект Дельфи:Gdi_Screen.rar
Исполняемый файл:GDI_SCREEN_EXE.rar