Сохранение изображения экрана в файле
Falk0ner, вс, 06/07/2008 - 15:34.
Сохранение изображения экрана в файле
На форме у меня стоит TImage (его можно сделать невидимым)
var
{©Drkb v.3(2007): <a href="http://www.drkb.ru" title="www.drkb.ru">www.drkb.ru</a>,
®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}
Dwh : HWND;
DRect: TRect;
DescDC: HDC;
Canv: TCanvas;
i: TJPEGImage;
begin
try
i := TJPEGImage.create;
try
Canv := TCanvas.Create();
i.CompressionQuality := 100;
image.Width := screen.width;
image.height := screen.height;
DWH := GetDesktopWindow;
GetWindowRect(DWH, DRect);
DescDC := GetDeviceContext(DWH);
Canv.Handle := DescDC;
DRect.Left := 0;
DRect. := 0;
DRect.Right := screen.Width;
DRect.Bottom := screen.Height;
Image.Canvas.CopyRect(DRect, Canv, DRect);
i.assign(Image.Picture.Bitmap);
I.SaveToFile('M:\MyFile.jpg');
Canv.free;
finally
i.free;
end;
except
end;
{©Drkb v.3(2007): <a href="http://www.drkb.ru" title="www.drkb.ru">www.drkb.ru</a>,
®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}
Dwh : HWND;
DRect: TRect;
DescDC: HDC;
Canv: TCanvas;
i: TJPEGImage;
begin
try
i := TJPEGImage.create;
try
Canv := TCanvas.Create();
i.CompressionQuality := 100;
image.Width := screen.width;
image.height := screen.height;
DWH := GetDesktopWindow;
GetWindowRect(DWH, DRect);
DescDC := GetDeviceContext(DWH);
Canv.Handle := DescDC;
DRect.Left := 0;
DRect. := 0;
DRect.Right := screen.Width;
DRect.Bottom := screen.Height;
Image.Canvas.CopyRect(DRect, Canv, DRect);
i.assign(Image.Picture.Bitmap);
I.SaveToFile('M:\MyFile.jpg');
Canv.free;
finally
i.free;
end;
except
end;
Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org)
program ScrShop;
uses
Windows;
procedure ApiScrCapture(FileName: String);
type
TScr = array [0..1] of Byte;
PScr = ^TScr;
var
hBmp : hBitmap;
DeskDC : hDC;
DC : hDC;
BFH : BITMAPFILEHEADER;
BIH : tagBITMAPINFO;
ScrX, ScrY : Integer;
F : File;
ScrSize : Cardinal;
Bits : PScr;
begin
SCRX := GetSystemMetrics(SM_CXSCREEN);
SCRY := GetSystemMetrics(SM_CYSCREEN);
ScrSize := ScrX * ScrY * 3;
GetMem(Bits, ScrSize);
DeskDC := GetDC(0);
hBmp := CreateCompatibleBitmap(DeskDC, ScrX, ScrY);
DC := CreateCompatibleDC(DeskDC);
SelectObject(DC, hbmp);
BitBlt(DC, 0, 0, SCRX, SCRY, DeskDC, 0, 0, SrcCopy);
with BFH do
begin
bfType := $4D42;
bfSize := SCRX * SCRY * 3 + SizeOf(BFH) + SizeOf(BIH);
bfReserved1 := 0;
bfReserved2 := 0;
bfOffBits := SizeOf(BFH) + SizeOf(BIH);
end;
with BIH.bmiHeader do
begin
biSize := sizeof(BIH);
biWidth := SCRX;
biHeight := SCRY;
biPlanes := 1;
biBitCount := 24;
biCompression := BI_RGB;
biSizeImage := ScrSize;
biClrImportant := 0;
end;
GetDiBits(DC, hbmp, 0, SCRY, Bits, BIH, DIB_RGB_COLORS);
DeleteObject(hbmp);
AssignFile(F, FileName);
Rewrite(F, 1);
Blockwrite(F, BFH, SizeOf(BFH));
Blockwrite(F, BIH, SizeOf(BIH));
Blockwrite(F, bits^, ScrSize);
CloseFile(F);
FreeMem(Bits);
end;
begin
ApiScrCapture('1.bmp');
end.
Автор: Arazel Взято из http://forum.sources.ru
uses
Windows;
procedure ApiScrCapture(FileName: String);
type
TScr = array [0..1] of Byte;
PScr = ^TScr;
var
hBmp : hBitmap;
DeskDC : hDC;
DC : hDC;
BFH : BITMAPFILEHEADER;
BIH : tagBITMAPINFO;
ScrX, ScrY : Integer;
F : File;
ScrSize : Cardinal;
Bits : PScr;
begin
SCRX := GetSystemMetrics(SM_CXSCREEN);
SCRY := GetSystemMetrics(SM_CYSCREEN);
ScrSize := ScrX * ScrY * 3;
GetMem(Bits, ScrSize);
DeskDC := GetDC(0);
hBmp := CreateCompatibleBitmap(DeskDC, ScrX, ScrY);
DC := CreateCompatibleDC(DeskDC);
SelectObject(DC, hbmp);
BitBlt(DC, 0, 0, SCRX, SCRY, DeskDC, 0, 0, SrcCopy);
with BFH do
begin
bfType := $4D42;
bfSize := SCRX * SCRY * 3 + SizeOf(BFH) + SizeOf(BIH);
bfReserved1 := 0;
bfReserved2 := 0;
bfOffBits := SizeOf(BFH) + SizeOf(BIH);
end;
with BIH.bmiHeader do
begin
biSize := sizeof(BIH);
biWidth := SCRX;
biHeight := SCRY;
biPlanes := 1;
biBitCount := 24;
biCompression := BI_RGB;
biSizeImage := ScrSize;
biClrImportant := 0;
end;
GetDiBits(DC, hbmp, 0, SCRY, Bits, BIH, DIB_RGB_COLORS);
DeleteObject(hbmp);
AssignFile(F, FileName);
Rewrite(F, 1);
Blockwrite(F, BFH, SizeOf(BFH));
Blockwrite(F, BIH, SizeOf(BIH));
Blockwrite(F, bits^, ScrSize);
CloseFile(F);
FreeMem(Bits);
end;
begin
ApiScrCapture('1.bmp');
end.
procedure TForm1.Button1Click(Sender: TObject);
var
DC: HDC;
Canva: TCanvas;
B: TBitmap;
begin
Canva := TCanvas.Create;
B := TBitmap.Create;
DC := GetDC(0);
try
Canva.Handle := DC;
with Screen do
begin
B.Width := Width;
B.Height := Height;
B.Canvas.CopyRect(Rect(0, 0, Width, Height),
Canva, Rect(0, 0, Width, Height));
B.SaveToFile('c:\Мои документы\screentofile.bmp');
end
finally
ReleaseDC(0, DC);
B.Free;
Canva.Free
end
end;
http://delphiworld.narod.ru/
DelphiWorld 6.0
var
DC: HDC;
Canva: TCanvas;
B: TBitmap;
begin
Canva := TCanvas.Create;
B := TBitmap.Create;
DC := GetDC(0);
try
Canva.Handle := DC;
with Screen do
begin
B.Width := Width;
B.Height := Height;
B.Canvas.CopyRect(Rect(0, 0, Width, Height),
Canva, Rect(0, 0, Width, Height));
B.SaveToFile('c:\Мои документы\screentofile.bmp');
end
finally
ReleaseDC(0, DC);
B.Free;
Canva.Free
end
end;
Отправить комментарий