Опытный
Профиль
Группа: Участник
Сообщений: 908
Регистрация: 3.12.2006
Где: Moscow
Репутация: нет
Всего: 30
|
MelonY, Цитата(MelonY @ 26.8.2008, 16:46  ) | | Возможно это, если да то каким образом? |
получаеш снимок экрана | Цитата |
Получение изображения экрана
Previous Top Next
Code:
// В качестве параметров передаются:
// AHandle - хэндл окна, скриншот которого мы хочем получить
// CompressPercent - процент сжатия картинки
// AImage - картинка, в которую будет помещено изображение
// в случае успешного скриншота функция вернет True
{©Drkb v.3(2007): www.drkb.ru}
function GetScreenShot(const AHandle: THandle; const CompressPercent: Byte;
var AImage: TJPEGImage): Boolean;
var
fBitmap: TBitmap;
DC: HDC;
Rect: TRect;
begin
Result := False;
if AImage = nil then Exit;
DC := GetDC(AHandle);
if DC <> 0 then
try
fBitmap := TBitmap.Create;
try
if not GetClientRect(AHandle, Rect) then Exit;
fBitmap.Width := Rect.Right - Rect.Left;
fBitmap.Height := Rect.Bottom - Rect.Top;
fBitmap.PixelFormat := pf32bit;
Result := BitBlt(fBitmap.Canvas.Handle, 0, 0, fBitmap.Width,
fBitmap.Height, DC, 0, 0, SRCCOPY);
if not Result then Exit;
AImage.Assign(fBitmap);
AImage.CompressionQuality := CompressPercent;
finally
fBitmap.Free;
end;
finally
ReleaseDC(AHandle, DC);
end;
end;
// Пример использования...
procedure TForm1.Button1Click(Sender: TObject);
var
Image: TJPEGImage;
begin
// Скриншот рабочего стола
Image := TJPEGImage.Create;
try
if GetScreenShot(GetDesktopWindow, 150, Image) then
Image1.Picture.Assign(Image);
finally
Image.Free;
end;
// Скриншот нашей формы
Image := TJPEGImage.Create;
try
if GetScreenShot(Handle, 150, Image) then
Image2.Picture.Assign(Image);
finally
Image.Free;
end;
end;
Автор Rouse_
©Drkb::01847
Взято из http://forum.sources.ru
--------------------------------------------------------------------------------
Code:
keybd_event(VK_SNAPSHOT,1,KEYEVENTF_KEYUP,0);
OpenClipBoard(Form1.handle);
try
SetClipBoardData(CF_DIB,Form1.handle);
vv:=GetClipBoardData(CF_BITMAP);
Image1.Picture.LoadFromClipboardFormat(CF_BITMAP,vv,0);
finally
CloseClipBoard;
EmptyClipBoard;
end;
©Drkb::01848
Автор: Song
Взято из http://forum.sources.ru
--------------------------------------------------------------------------------
Еще один способ получения скриншота окна, на чистом WinApi:
Code:
function CreateWindwowBitmap(Wnd: HWND): HBITMAP;
{©Drkb v.3(2007): www.drkb.ru}
var
R: TRect;
W, H: Integer;
DC, memDC: HDC;
bm, oldBM: HBITMAP;
begin
GetWindowRect(Wnd, R);
W := R.Right - R.Left;
H := R.Bottom - R.Top;
DC := GetWindowDC(Wnd);
memDC := CreateCompatibleDC(DC);
bm := CreateCompatibleBitmap(DC, W, H);
oldBM := SelectObject(memDC, bm);
BitBlt(memDC, 0,0, w, h, DC, 0,0, SRCCOPY);
SelectObject(memDC, oldBM);
DeleteDC(memDC);
DeleteObject(oldBM);
ReleaseDC(Wnd, DC);
Result := bm;
end;
Автор: Krid
Взято из http://forum.sources.ru
©Drkb::01849
--------------------------------------------------------------------------------
Универсальный способ - скриншот с прозрачностью:
Code:
procedure CaptureScreen(AFileName: string);
const
CAPTUREBLT = $40000000;
var
hdcScreen: HDC;
hdcCompatible: HDC;
bmp: TBitmap;
hbmScreen: HBITMAP;
begin
// Create a normal DC and a memory DC for the entire screen. The
// normal DC provides a "snapshot" of the screen contents. The
// memory DC keeps a copy of this "snapshot" in the associated
// bitmap.
hdcScreen := CreateDC('DISPLAY', nil, nil, nil);
hdcCompatible := CreateCompatibleDC(hdcScreen);
// Create a compatible bitmap for hdcScreen.
hbmScreen := CreateCompatibleBitmap(hdcScreen,
GetDeviceCaps(hdcScreen, HORZRES),
GetDeviceCaps(hdcScreen, VERTRES));
// Select the bitmaps into the compatible DC.
SelectObject(hdcCompatible, hbmScreen);
bmp := TBitmap.Create;
bmp.Handle := hbmScreen;
BitBlt(hdcCompatible,
0, 0,
bmp.Width, bmp.Height,
hdcScreen,
0, 0,
SRCCOPY or CAPTUREBLT);
bmp.SaveToFile(AFileName);
bmp.Free;
DeleteDC(hdcScreen);
DeleteDC(hdcCompatible);
end;
// from http://www.swissdelphicenter.ch
©Drkb::01850
--------------------------------------------------------------------------------
Используйте стандартный Windows API:
используйте hWnd := GetDesktopWindow для получения дескриптора 'рабочего стола';
используйте hDC := GetDC (hWnd) для получения HDC (дескриптора контекста экрана) ;
и не забывайте освобождать (уничтожать дескриптор) hDC после выполнения задачи.
Используя TCanvas.Handle в качестве HDC, можно при помощи WinAPI реализовать функции рисования, или, если это возможно, можно присвоить HDC свойству Handle непосредственно при создании TCanvas.
©Drkb::01851
http://delphiworld.narod.ru/
DelphiWorld 6.0
--------------------------------------------------------------------------------
В D1 (по идее должно работать и в D2) попробуйте это:
Разместите на форме TPaintBox и TButton.
Code:
procedure TForm1.Button1Click(Sender: TObject);
var
DeskTop: TCanvas;
begin
DeskTop := TCanvas.Create;
try
with DeskTop do
Handle := GetWindowDC(GetDesktopWindow);
with PaintBox1.Canvas do
CopyRect(Rect(0, 0, 200, 200),
DeskTop,
Rect(0, 0, 200, 200))
finally
DeskTop.Free;
end
end;
Это скопирует верхнюю левую область рабочего стола в верхнюю левую область вашего TPaintBox.
©Drkb::01853
http://delphiworld.narod.ru/
DelphiWorld 6.0
--------------------------------------------------------------------------------
Например, с помощью WinAPI так -
Code:
var
bmp: TBitmap;
DC: HDC;
begin
bmp:=TBitmap.Create;
bmp.Height:=Screen.Height;
bmp.Width:=Screen.Width;
DC:=GetDC(0); //Дескpиптоp экpана
bitblt(bmp.Canvas.Handle, 0, 0, Screen.Width, Screen.Height,
DC, 0, 0, SRCCOPY);
bmp.SaveToFile('Screen.bmp');
ReleaseDC(0, DC);
end;
Или с помощью обертки TCanvas -
Объект Screen[.width,height] - размеры
Code:
Var
Desktop: TCanvas ;
BitMap: TBitMap;
begin
DesktopCanvas:=TCanvas.Create;
DesktopCanvas.Handle:=GetDC(Hwnd_Desktop);
BitMap := TBitMap.Create;
BitMap.Width := Screen.Width;
BitMap.Height:=Screen.Height;
Bitmap.Canvas.CopyRect(Bitmap.Canvas.ClipRect,
DesktopCanvas, DesktopCanvas.ClipRect);
........
end;
©Drkb::01854
http://delphiworld.narod.ru/
DelphiWorld 6.0
--------------------------------------------------------------------------------
Code:
unit ScrnCap;
interface
uses
WinTypes, WinProcs, Forms, Classes, Graphics, Controls;
{ Копирует прямоугольную область экрана }
function CaptureScreenRect(ARect : TRect) : TBitmap;
{ Копирование всего экрана }
function CaptureScreen : TBitmap;
{ Копирование клиентской области формы или элемента }
function CaptureClientImage(Control : TControl) : TBitmap;
{ Копирование всей формы элемента }
function CaptureControlImage(Control : TControl) : TBitmap;
implementation
function GetSystemPalette : HPalette;
var
PaletteSize : integer;
LogSize : integer;
LogPalette : PLogPalette;
DC : HDC;
Focus : HWND;
begin
result:=0;
Focus:=GetFocus;
DC:=GetDC(Focus);
try
PaletteSize:=GetDeviceCaps(DC, SIZEPALETTE);
LogSize:=SizeOf(TLogPalette)+(PaletteSize-1)*SizeOf(TPaletteEntry);
GetMem(LogPalette, LogSize);
try
with LogPalette^ do
begin
palVersion:=$0300;
palNumEntries:=PaletteSize;
GetSystemPaletteEntries(DC, 0, PaletteSize, palPalEntry);
end;
result:=CreatePalette(LogPalette^);
finally
FreeMem(LogPalette, LogSize);
end;
finally
ReleaseDC(Focus, DC);
end;
end;
function CaptureScreenRect(ARect : TRect) : TBitmap;
var
ScreenDC : HDC;
begin
Result:=TBitmap.Create;
with result, ARect do
begin
Width:=Right-Left;
Height:=Bottom-Top;
ScreenDC:=GetDC(0);
try
BitBlt(Canvas.Handle, 0,0,Width,Height,ScreenDC, Left, Top, SRCCOPY );
finally
ReleaseDC(0, ScreenDC);
end;
Palette:=GetSystemPalette;
end;
end;
function CaptureScreen : TBitmap;
begin
with Screen do
Result:=CaptureScreenRect(Rect(0,0,Width,Height));
end;
function CaptureClientImage(Control : TControl) : TBitmap;
begin
with Control, Control.ClientOrigin do
result:=CaptureScreenRect(Bounds(X,Y,ClientWidth,ClientHeight));
end;
function CaptureControlImage(Control : TControl) : TBitmap;
begin
with Control do
if Parent=nil then
result:=CaptureScreenRect(Bounds(Left,Top,Width,Height))
else
with Parent.ClientToScreen(Point(Left, Top)) do
result:=CaptureScreenRect(Bounds(X,Y,Width,Height));
end;
end.
©Drkb::01855
http://delphiworld.narod.ru/
DelphiWorld 6.0
--------------------------------------------------------------------------------
Code:
// Для копирования изображения, находящегося в клиентской части
// формы есть метод GetFormImage. Для копирования любого
// прямоугольника экрана можно воспользоваться функциями GDI.
// Копирование произвольной прямоугольной области экрана
Function CaptureScreenRect( ARect: TRect ): TBitmap;
var
ScreenDC: HDC;
begin
Result := TBitmap.Create;
with Result, ARect do
begin
Width := Right - Left;
Height := Bottom - Top;
// получаем для экрана контекст устройства
ScreenDC := GetDC( 0 );
try
// копируем оттуда прямоугольную область на канву
// растрового изображения
BitBlt( Canvas.Handle, 0, 0, Width, Height, ScreenDC,
Left, Top, SRCCOPY );
finally
ReleaseDC( 0, ScreenDC );
end;
end;
end;
// Таким образом, задавая нужный прямоугольник, можно получить
// изображение любой части экрана, получить изображение любого
// элемента формы(кнопок , выпадающих списков и так далее).
// Пример для копирования нужного элемента формы или всей формы,
// включая и заголовок и рамку:
Function CaptureControlImage( Control: TControl ): TBitmap;
begin
with Control do
IF Parent = nil Then
Result := CaptureScreenRect( Bounds( Left, Top, Width,Height ))
Else
With Parent.ClientToScreen( Point( Left, Top )) DO
Result := CaptureScreenRect( Bounds( X, Y, Width,Height ));
end;
©Drkb::01856
http://delphiworld.narod.ru/
DelphiWorld 6.0
--------------------------------------------------------------------------------
Code:
uses
Graphics;
// Capture the entire screen
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;
©Drkb::01857
Взято с сайта: http://www.swissdelphicenter.ch
--------------------------------------------------------------------------------
Code:
// Capture Only active window
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;
©Drkb::01858
Взято с сайта: http://www.swissdelphicenter.ch
--------------------------------------------------------------------------------
Code:
// 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;
©Drkb::01859
Взято с сайта: http://www.swissdelphicenter.ch
--------------------------------------------------------------------------------
Code:
// 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;
©Drkb::01860
Взято с сайта: http://www.swissdelphicenter.ch
--------------------------------------------------------------------------------
Code:
{**********************************************}
// 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;
©Drkb::01861
Взято с сайта: http://www.swissdelphicenter.ch
--------------------------------------------------------------------------------
|
© drkb любым из этих способов, далее береш TServerSocket, TClientSocket, соединяешся. | Код |
ServerSocket.Port = 777;
ServerSocket.Active = true;
ClientSocket.Adress = какойтотамIP;
ClientSocket.Port = 777;
ClientSocket.Active = true;
|
посылаеш строку ClientSocket.SendText("INeedScreen"); на сервер в OnReceive принимаеш: | Код |
string s = ServerSocket.ReceiveString;
|
далее что нить в этом роде if (s = "INeedScreen") делаеш снимок экрана, и копируеш это все дело в MemoryStream (либо буфер) и отсылаеш | Код |
for (int i = 0; i < ServerSocket.Socket.ActiveConnection; i++)
if (ServerSocket.Socket.Connection[i].Handle <> 0)
ServerSocket.Socket.Connection[i].SendBuff(твойБуфер)
|
на клиенте принимаеш | Код |
твой буфер = ClientSocket.ReceiveBuff();
|
и получаеш картринку зы. сори код написан прямо тут, если ответов не дадут, дома приду приведу пример более подробно. зыы. Все это образно, чтобы дать ответ "Каким образом" ;) Удачи =) Добавлено через 6 минут и 42 секунды| Цитата(MelonY @ 26.8.2008, 16:46 ) | | RAdmin, RemoteDesktop |
это врятли
--------------------
"Решение зависит от выбранного геморроя" © Snowy
"у нас как в армии - либо работает, либо так и задумано" |
запрос с клиента на передачу файла с сервера, оч прошу помогите 
Дата 26.8.2008, 14:56 (
Загрузка ...
Дата 16.1.2010, 05:52 (
