Delphirus - прграммирование на delphi
   Все о delphi Delphirus - прграммирование на delphi
blocks.gif
Навигация
 

Главная
Статьи
Базы данных
Графика
Защита
Интернет
Система
Тексты
Мультимедиа
Файлы
Формы и окна
Другое
Советы
Базы данных
Графика
Интернет
Мультимедиа
Система
Тексты
Файлы
Файлы
Исходники
Компоненты
Инфо
Поиск по сайту
Обратная связь
Самое популярное
Аккаунт
Карта сайта

 
 
 

Советы по delphi \ Система \ Монитор и Экран \ Снимок экрана

Снимок экрана

uses
   Graphics;

 // Capture the entire screen 
// Screenshot des gesamten Bildschirms 
procedure ScreenShot(Bild: TBitMap);
 var
   c: TCanvas;
   r: TRect;
 begin
   c := TCanvas.Create;
   c.Handle := GetWindowDC(GetDesktopWindow);
   try
     r := Rect(0, 0, Screen.Width, Screen.Height);
     Bild.Width := Screen.Width;
     Bild.Height := Screen.Height;
     Bild.Canvas.CopyRect(r, c, r);
   finally
     ReleaseDC(0, c.Handle);
     c.Free;
   end;
 end;

 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Form1.Visible := False;
   Sleep(750); // some delay, ein wenig Zeit geben 
  ScreenShot(Image1.Picture.BitMap);
   Form1.Visible := True;
 end;


 // Only active window 
// Screenshot des aktiven Fensters 
procedure ScreenShotActiveWindow(Bild: TBitMap);
 var
   c: TCanvas;
   r, t: TRect;
   h: THandle;
 begin
   c := TCanvas.Create;
   c.Handle := GetWindowDC(GetDesktopWindow);
   h := GetForeGroundWindow;
   if h <> 0 then
     GetWindowRect(h, t);
   try
     r := Rect(0, 0, t.Right - t.Left, t.Bottom - t.Top);
     Bild.Width  := t.Right - t.Left;
     Bild.Height := t.Bottom - t.Top;
     Bild.Canvas.CopyRect(r, c, t);
   finally
     ReleaseDC(0, c.Handle);
     c.Free;
   end;
 end;

 procedure TForm1.Button2Click(Sender: TObject);
 begin
   Form1.Visible := False;
   Sleep(750); //some delay,ein wenig Zeit geben 
  ScreenShotActiveWindow(Image1.Picture.BitMap);
   Form1.Visible := True;
 end;

 {**********************************************}
 // Another print screen function by Xavier P: 
// Capture the entire screen 
procedure ScreenShot(x: Integer;
   y: Integer; //(x, y) = Left-top coordinate 
  Width: Integer;
   Height: Integer; //(Width-Height) = Bottom-Right coordinate 
  bm: TBitMap); //Destination 
var
   dc: HDC;
   lpPal: PLOGPALETTE;
 begin
   {test width and height}
   if ((Width = 0) or
     (Height = 0)) then
     Exit;
   bm.Width  := Width;
   bm.Height := Height;
   {get the screen dc}
   dc := GetDc(0);
   if (dc = 0) then
     Exit;
   {do we have a palette device?}
   if (GetDeviceCaps(dc, RASTERCAPS) and
     RC_PALETTE = RC_PALETTE) then
   begin
     {allocate memory for a logical palette}
     GetMem(lpPal,
       SizeOf(TLOGPALETTE) +
     (255 * SizeOf(TPALETTEENTRY)));
     {zero it out to be neat}
     FillChar(lpPal^,
       SizeOf(TLOGPALETTE) +
     (255 * SizeOf(TPALETTEENTRY)),
       #0);
     {fill in the palette version}
     lpPal^.palVersion := $300;
     {grab the system palette entries}
     lpPal^.palNumEntries :=
       GetSystemPaletteEntries(dc,
       0,
       256,
       lpPal^.palPalEntry);
     if (lpPal^.PalNumEntries <> 0) then
       {create the palette}
       bm.Palette := CreatePalette(lpPal^);
     FreeMem(lpPal, SizeOf(TLOGPALETTE) +
     (255 * SizeOf(TPALETTEENTRY)));
   end;
   {copy from the screen to the bitmap}
   BitBlt(bm.Canvas.Handle,
     0,
     0,
     Width,
     Height,
     Dc,
     x,
     y,
     SRCCOPY);
   {release the screen dc}
   ReleaseDc(0, dc);
 end;


 // Example: 
procedure TForm1.Button1Click(Sender: TObject);
 begin
  ScreenShot(0,0,Screen.Width, Screen.Height, Image1.Picture.Bitmap);
 end;


 {**********************************************}
 // Capture a window 
procedure ScreenShot(hWindow: HWND; bm: TBitmap);
 var
   Left, Top, Width, Height: Word;
   R: TRect;
   dc: HDC;
   lpPal: PLOGPALETTE;
 begin
   {Check if valid window handle}
   if not IsWindow(hWindow) then Exit;
   {Retrieves the rectangular coordinates of the specified window}
   GetWindowRect(hWindow, R);
   Left := R.Left;
   Top := R.Top;
   Width := R.Right - R.Left;
   Height := R.Bottom - R.Top;
   bm.Width  := Width;
   bm.Height := Height;
   {get the screen dc}
   dc := GetDc(0);
   if (dc = 0) then
    begin
     Exit;
   end;
   {do we have a palette device?}
   if (GetDeviceCaps(dc, RASTERCAPS) and
     RC_PALETTE = RC_PALETTE) then
    begin
     {allocate memory for a logical palette}
     GetMem(lpPal,
       SizeOf(TLOGPALETTE) +
     (255 * SizeOf(TPALETTEENTRY)));
     {zero it out to be neat}
     FillChar(lpPal^,
       SizeOf(TLOGPALETTE) +
     (255 * SizeOf(TPALETTEENTRY)),
       #0);
     {fill in the palette version}
     lpPal^.palVersion := $300;
     {grab the system palette entries}
     lpPal^.palNumEntries :=
       GetSystemPaletteEntries(dc,
       0,
       256,
       lpPal^.palPalEntry);
     if (lpPal^.PalNumEntries <> 0) then
      begin
       {create the palette}
       bm.Palette := CreatePalette(lpPal^);
     end;
     FreeMem(lpPal, SizeOf(TLOGPALETTE) +
     (255 * SizeOf(TPALETTEENTRY)));
   end;
   {copy from the screen to the bitmap}
   BitBlt(bm.Canvas.Handle,
     0,
     0,
     Width,
     Height,
     Dc,
     Left,
     Top,
     SRCCOPY);
   {release the screen dc}
   ReleaseDc(0, dc);
 end;
 // Example: Capture the foreground window: 
procedure TForm1.Button1Click(Sender: TObject);
 begin
   ScreenShot(GetForeGroundWindow, Image1.Picture.Bitmap);
 end;


 {**********************************************}
 // by Daniel Wischnewski 
Sometimes you want to take a screen shot,
 however often Windows has trouble with big data amounts and becomes very slow.
 The simple solution is to make many small screen shots and paste the result together.
 It''s not light speed, however often faster than taking the whole screen at once.
 const
   cTileSize = 50;
 function TForm1.GetSCREENSHOT: TBitmap;
 var
   Locked: Boolean;
   X, Y, XS, YS: Integer;
   Canvas: TCanvas;
   R: TRect;
 begin
   Result := TBitmap.Create;
   Result.Width := Screen.Width;
   Result.Height := Screen.Height;
   Canvas := TCanvas.Create;
   Canvas.Handle := GetDC(0);
   Locked := Canvas.TryLock;
   try
     XS := Pred(Screen.Width div cTileSize);
     if Screen.Width mod cTileSize > 0 then
       Inc(XS);
     YS := Pred(Screen.Height div cTileSize);
     if Screen.Height mod cTileSize > 0 then
       Inc(YS);
     for X := 0 to XS do
       for Y := 0 to YS do
       begin
         R := Rect(
           X * cTileSize, Y * cTileSize, Succ(X) * cTileSize,
           Succ(Y) * cTileSize);
         Result.Canvas.CopyRect(R, Canvas, R);
       end;
   finally
     if Locked then
       Canvas.Unlock;
     ReleaseDC(0, Canvas.Handle);
     Canvas.Free;
   end;
 end;

Название: Снимок экрана
Дата публикации: 2004-09-09 (3513 Прочтено)

 
 

 

Page generation 0.047 seconds