Форум: "Основная";
Текущий архив: 2005.08.07;
Скачать: [xml.tar.bz2];

Вниз

Как снять скриншот ?   Найти похожие ветки 

← →
Скрин   (2005-07-13 03:39) [0]

Мне дали одну функцию, как это делать. Но она глючит. Часто вылетает какая то ошибка "неверный параметр". Не знаю, что это такое. Может у кого есть безглючный вариант ?

---

← →
Essence   (2005-07-13 04:03) [1]

procedure MakeScreenShot(const ATarget: TBitmap);
var
 DesktopDC: HDC;
begin
 DesktopDC := CreateDC("DISPLAY", nil, nil, nil);
 try
   ATarget.PixelFormat := pfDevice;
   ATarget.Width := Screen.Width;
   ATarget.Height := Screen.Height;
 
   BitBlt(ATarget.Canvas.Handle, 0, 0, Screen.Width, Screen.Height, DesktopDC, 0, 0, SRCCOPY);
 finally
   DeleteDC(DesktopDC);
 end;
end;

В процедуру нужно передавать объект типа TBitmap:
procedure TForm1.Button1Click(Sender: TObject);
begin
MakeScreenShot(Image1.Picture.Bitmap);
end;

---

← →
Просто Джо ©   (2005-07-13 04:09) [2]

Вот, держив "самопал" из одного проекта.
При необходимости, накладывает даже изображение курсора.


unit ScrUtil;

interface
uses Windows, SysUtils, Graphics;

procedure MakeScreenshot (Bmp: TBitmap; CaptureCursor: Boolean = True);

implementation
uses Controls, Forms;

procedure MakeScreenshot (Bmp: TBitmap; CaptureCursor: Boolean = True);
var
 DC: HDC;
 ACursor: HICON;
 Pt: TPoint;
 CurInfo: tagCURSORINFO;
 IcoInfo: _ICONINFO;
begin
 Bmp.Width := Screen.Width;
 Bmp.Height := Screen.Height;

 DC := GetDC (GetDesktopWindow);
 try
   BitBlt (
     Bmp.Canvas.Handle,
     0,0,Bmp.Width,Bmp.Height,
     DC,
     0,0,
     SRCCOPY);

   // -- курсор
   if CaptureCursor then
   begin

     CurInfo.cbSize := SizeOf(CurInfo);
     GetCursorInfo(CurInfo);

     ACursor := CurInfo.hCursor;
     Pt := CurInfo.ptScreenPos;

     GetIconInfo (ACursor,IcoInfo);

     DrawIcon(
       Bmp.Canvas.Handle,
       Pt.X-IcoInfo.xHotspot,
       Pt.Y-IcoInfo.yHotspot,
       ACursor
     )
   end;

 finally
   ReleaseDC (GetDesktopWindow,DC);
 end;
end;

end.


Пример использования:

procedure TScrnShtFrm.Button5Click(Sender: TObject);
var
 Bmp: TBitmap;
begin
 Bmp := TBitmap.Create;
 try
   // снимаем изображение экрана с курсором
   MakeScreenshot(Bmp,True);
   // и сохраняем его в файл директории программы
   Bmp.SaveToFile(ExtractFilePath(ParamStr(0))+"screen.bmp");
 finally
   Bmp.Free;
 end;
end;


---

← →
Скрин   (2005-07-21 01:20) [3]

> Essence   (13.07.05 04:03) [1]
> procedure MakeScreenShot(const ATarget: TBitmap);
> var
>  DesktopDC: HDC;
> begin
>  DesktopDC := CreateDC("DISPLAY", nil, nil, nil);
>  try
>    ATarget.PixelFormat := pfDevice;
>    ATarget.Width := Screen.Width;
>    ATarget.Height := Screen.Height;
>  
>    BitBlt(ATarget.Canvas.Handle, 0, 0, Screen.Width, Screen.Height,
> DesktopDC, 0, 0, SRCCOPY);
>  finally
>    DeleteDC(DesktopDC);
>  end;
> end;
>
> В процедуру нужно передавать объект типа TBitmap:
> procedure TForm1.Button1Click(Sender: TObject);
> begin
> MakeScreenShot(Image1.Picture.Bitmap);
> end;


Эта функция делает скриншот не всего. Пропускает некоторые элементы изображения.

Я делаю :

 const
   NumColors = 256;
 var
   Canv : TCanvas;
   LP   : PLogPalette;
   Size : Integer;
   TmpPalette : HPalette;

...

Canv       := TCanvas.Create;
try
 Canv.Handle := GetDC(HWND_DESKTOP);
 try
   Img.Canvas.CopyRect(Rect1, Canv, Rec2);
   Size := SizeOf(TLogPalette) +(Pred(NumColors) *SizeOf(TPaletteEntry));
   LP   := AllocMem(Size);
   try
     LP^.palVersion    := $300;
     LP^.palNumEntries := NumColors;
     GetSystemPaletteEntries(Canv.Handle, 0, NumColors, LP^.palPalEntry);
     TmpPalette := CreatePalette(LP^);
     Img.Picture.Bitmap.Palette := TmpPalette;
     DeleteObject(TmpPalette);
   finally
     FreeMem(LP, Size);
   end
 finally
   ReleaseDC(HWND_DESKTOP, Canv.Handle);
 end;
finally
 Canv.Free;
end;

Эта функция и глючит. Почему ? Как поправить ?

---

← →
Essence   (2005-07-21 23:12) [4]

unit Unit1;

interface

uses
 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
 StdCtrls, ExtCtrls;

type
 TForm1 = class(TForm)
   ButtonExit: TButton;
   Button1: TButton;
   procedure ButtonExitClick(Sender: TObject);
   procedure Button1Click(Sender: TObject);
 private
 public
   procedure MakeScreenShot(const AusSchnitt: TBitmap);
 end;

var
 Form1: TForm1;

implementation

{$R *.DFM}
function EnumMiniProc (Wd: HWnd; Param: LongInt): Boolean; stdcall;
begin
 if Wd = Form1.Handle then
   If  IsWindowVisible(WD) then
     If  not IsIconic(WD) then
       If  isWindow(WD) then
         ShowWindow(WD, SW_MINIMIZE);

 EnumMiniProc := TRUE;
end;

procedure TForm1.ButtonExitClick(Sender: TObject);
begin
 Close;
end;

procedure TForm1.MakeScreenShot(const AusSchnitt: TBitmap);
var
DesktopDC: HDC;
begin
DesktopDC := GetDC(HWND_DESKTOP);
try
  AusSchnitt.PixelFormat := pfDevice;
  StretchBlt(AusSchnitt.Canvas.Handle, AusSchnitt.Width, AusSchnitt.Height,
             -AusSchnitt.Width, -AusSchnitt.Height, DesktopDC, 0, 0,Screen.Width,
             Screen.Height, SRCCOPY);

  BitBlt(DesktopDC, 0, 0, AusSchnitt.Width, AusSchnitt.Height,
         AusSchnitt.Canvas.Handle, 0, 0, SRCCOPY);
finally
  DeleteDC(DesktopDC);
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
 Bmp: TBitmap;
begin
 EnumWindows(@EnumMiniProc, 0);

 Bmp := TBitmap.Create;
 try
   Bmp.Width := Screen.Width;
   Bmp.Height := Screen.Height;
   MakeScreenShot(Bmp);
   Bmp.SaveToFile("TestDSK.bmp");
 finally
   Bmp.Free;
 end;
end;

---

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

Форум: "Основная";
Текущий архив: 2005.08.07;
Скачать: [xml.tar.bz2];

Наверх

Память: 0.46 MB
Время: 0.048 c