Текущий архив: 2005.10.23;
Скачать: CL | DM;

Вниз

помогите сохранить экран на API...?   Найти похожие ветки 

← →
NikNet ©   (2005-08-19 02:46) [0]

Помогите сохранить в файл...

program ScrShop;
uses
Windows,
Messages;

Function ApiScrCapture(FileName:String):HDC;
Type
TScr = array [0..10000000*3] of Byte;
PScr =  ^TScr;
var
TBmp     : TBitmap;
hBmp     : hBitmap;
DeskDC   : hDC;
DC       : hDC;
BmpInfo  : tagBitmapInfo;
ScrX,ScrY: Integer;
F        : File;
ScrSize  : Cardinal;
Bits     : PScr;
begin
GetMem(Bits,ScrSize);
SCRX     := GetSystemMetrics(SM_CXSCREEN);
SCRY     := GetSystemMetrics(SM_CYSCREEN);
ScrSize  := ScrX*ScrY*3;
New(bits);

DeskDC   := GetWindowDC(GetDesktopWindow);
hBmp     := CreateCompatibleBitmap(deskdc,ScrX,ScrY);
DC       := CreateCompatibleDC(DeskDC);

SelectObject(dc,hbmp);
BitBlt(Dc,0,0,SCRX,SCRY,deskdc,0,0,SrcCopy);

BmpInfo.bmiHeader.biSize:=sizeof(tagBitmapInfoHeader);
BmpInfo.bmiHeader.biBitCount:=0;
GetDiBits(DeskDC,hBmp,0,SCRY,nil,BmpInfo,DIB_RGB_COLORS);

BmpInfo.bmiHeader.biWidth:=SCRX;
BmpInfo.bmiHeader.biHeight:=SCRY;
BmpInfo.bmiHeader.biPlanes:=1;
BmpInfo.bmiHeader.biBitCount:=24;
BmpInfo.bmiHeader.biCompression:=BI_RGB;
BmpInfo.bmiHeader.biSizeImage:=ScrSize;
BmpInfo.bmiHeader.biClrImportant:=0;

GetDiBits(DeskDC,hbmp,0,SCRY,Bits,BmpInfo,DIB_RGB_COLORS);
DeleteObject(hbmp);
Result:=DeskDC;
//------- Что то несохраняется :( -------//
AssignFile(F,FileName);
Rewrite(F,1);
Blockwrite(F,bits^,ScrSize);
closeFile(F);
FreeMem(Bits,ScrSize);
end;

begin
ApiScrCapture("1.bmp");
end.

---

← →
alpet ©   (2005-08-19 07:16) [1]


var sn: dword = 0;
procedure  Snapshot;
var dc: TCanvas;
   ssht: TBitmap;
   r: TRect;
begin
dc := TCanvas.Create;
// dc.Handle := CreateDC ("DISPLAY", nil, nil, nil);;
dc.Handle := GetDeviceContext (0);
// Создание буффера
ssht := TBitmap.Create;
r.Left := 0;
r.Right := screen.Width;
r.Top := 0;
r.Bottom := screen.Height;
ssht.Canvas.CopyMode := SrcCopy;
ssht.PixelFormat := pf32bit;
with ssht do
 case GetDeviceCaps (dc.handle, BITSPIXEL) of
  8: pixelFormat := pf8bit;
 15: pixelFormat := pf15bit;
 16: pixelFormat := pf16bit;
 24: pixelFormat := pf24bit;
end;
ssht.width := r.Right - r.left;
ssht.Height := r.Bottom - r.Top;
ssht.Canvas.CopyRect (r, dc, r);
ssht.SaveToFile("sshot" + word2hex (sn) + ".bmp" );
inc (sn);
ReleaseDC (0, dc.Handle);
dc.Free;
ssht.Free;
end;

See also:
TCanvas.Create, GetDeviceContext, Handle, Palette example

---

← →
XProger ©   (2005-08-19 08:29) [2]

Ошибка в выделении памяти под Bits, и не знании структуры bmp файлов.

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.


---

← →
Sapersky   (2005-08-19 10:45) [3]

Если под чистым API подразумевается неиспользование VCL, то вот ещё такой вариант:

Uses FastDIB; // http://prdownloads.sourceforge.net/skinner/FastLib.zip?download

procedure ApiScrCapture(Const FileName : String);
Var FDIB : TFastDIB;
   DC : HDC;
begin
FDIB := TFastDIB.Create;
FDIB.SetSize(GetSystemMetrics(SM_CXSCREEN), GetSystemMetrics(SM_CYSCREEN), 24);
DC := GetDC(0);
BitBlt(FDIB.hDC, 0, 0, FDIB.Width, FDIB.Height, DC, 0, 0, SRCCOPY);
ReleaseDC(0, DC);
FDIB.SaveToFile(FileName);
FDIB.Free;
end;

---

← →
XProger ©   (2005-08-20 00:18) [4]

Sapersky, см. [2] - это называется чистый Win API...

---

← →
NikNet ©   (2005-08-20 01:23) [5]

СПАСИБООООООО тебе и другим :)

---

Страницы: 1 вся ветка

Текущий архив: 2005.10.23;
Скачать: CL | DM;

Наверх

Память: 0.47 MB
Время: 0.036 c