delphi + скриншот + белый экран

← →
acyb (2006-11-21 10:05) [0]

делаю программно скриншот, но в результате получается белый файл. 12кб
после перевода экрана в режим с 32битным цветом работает нормально. если перевести обратно на 16 тоже нормально. после перезагрузки опять тоже самое.

вот исходники

function Tservice1.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 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;

← →
Stexen © (2006-11-21 15:27) [1]

Может перед битблт стоило указать формат битмапа

← →
acyb (2006-11-21 16:17) [2]

каким образом? я в этом не силен... всю жизнь базы программил

← →
acyb (2006-11-21 17:33) [3]

подсказали тут идею про SetThreadDesktop тк програ работает как сервис, сейчас сижу ковыряю инфу в инете

← →
Stexen © (2006-11-21 19:40) [4]

не ты больно сложно берешь... зря! это в четыре строчки пишется....

вообще сейчас комилятора под рукой нет так что не могу точно сказать в чем ошибка но все таки попробуй на всяк случай
bitmap.pixelformat := pf24bit;

Перед битблт! И убери
Palette:=GetSystemPalette;

← →
acyb (2006-11-22 11:32) [5]

увы, не помогло

← →
Чапаев © (2006-11-22 12:48) [6]

> [3] acyb (21.11.06 17:33)
Если сервис неинтерактивный, то всё равно не поможет.

← →
Чапаев © (2006-11-22 12:52) [7]

> [5] acyb (22.11.06 11:32)
Может, WtsGetCurrentConsoleId()+WtsQueryUserToken()+ImpersonateLoggedOnUser()? (Это я сам недавно научился, теперь с восторгом неофита советую всем :о) )

← →
acyb (2006-11-22 13:18) [8]

делаю вот так вот - не помогает

procedure TService1.ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
var
fs: TFileStream;
Data: TMemoryStream;
btm:tbitmap;
bmp: TBItmap;
jpg: TJpegImage;
scale: Double;
jpgImg: TJPEGImage;
JPEG: TJPEGImage;
Bitmap: TBitmap;
DC: HDC;
Desk: HWND;

begin

case strtoint(Socket.ReceiveText) of
403:
begin
OpenWindowStation("WinSta0",False,GENERIC_ALL);
SetThreadDesktop(OpenInputDesktop(0,False,GENERIC_ALL));

btm:=TBitmap.Create;
JPG:=TJpegImage.Create;

try
Desk := GetDesktopWindow;
DC := GetWindowDC(Desk);
try
btm.PixelFormat:=pf24bit;
Btm.Height := Screen.Height;
Btm.Width := Screen.Width;
BitBlt(Btm.Canvas.Handle, 0, 0, Screen.Width, Screen.Height, DC, 0, 0, SRCCOPY);
finally
ReleaseDC(Desk, DC);
end;

finally
Btm.Free;
end;

JPG.Assign(btm);

//===
if jpg.Height > jpg.Width then scale := 1280 / jpg.Height
else scale := 1024/ jpg.Width;
bmp:= Tbitmap.Create;
try
bmp.Width:=Round( jpg.Width * scale );
bmp.Height:=Round( jpg.Height * scale );
bmp.Canvas.StretchDraw( bmp.Canvas.Cliprect, jpg );
jpg.Assign( bmp );
finally
bmp.free;
end;
jpg.SaveToFile("c:\scr.jpg");
jpg.free;
btm.Free;
//===

fs:=TFileStream.Create("c:\scr.jpg", fmOpenRead);
try
fs.Position:= 0;
Socket.SendText("Size:"+IntToStr(fs.Size) + #0);
Socket.SendStream(fs);
finally
end;
end;

405:

← →
RASkov (2006-11-23 04:29) [9]

procedure TForm1.Button1Click(Sender: TObject); var Bmp: TBitMap; SDC: HDC; Jpg: TJpegImage; begin Bmp:=TBitMap.Create; Jpg:=TJpegImage.Create; SDC:=GetDC(0); try Bmp.Width:=Screen.Width; Bmp.Height:=Screen.Height; case GetDeviceCaps(SDC, BITSPIXEL) of 16: Bmp.PixelFormat:=pf16bit; 32: Bmp.PixelFormat:=pf32bit; else Bmp.PixelFormat:=pf16bit; end; BitBlt(Bmp.Canvas.Handle, 0, 0, Screen.Width, Screen.Height, SDC, 0, 0, SRCCOPY ); Jpg.CompressionQuality:=10; Jpg.Assign(Bmp); Bmp.SaveToFile("C:\1.bmp"); Jpg.SaveToFile("C:\1.jpg"); Canvas.StretchDraw(Canvas.ClipRect, Jpg); finally ReleaseDC(0, SDC); Bmp.Free; Jpg.Free; end; end;

Но может я не совсем въехал в вопрос, тогда sorry:(

← →
acyb (2006-11-23 10:00) [10]

увы, не помогло...

← →
acyb (2006-11-23 10:13) [11]

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

← →
Чапаев © (2006-11-23 12:20) [12]

Вот работающий код. Писался "на коленке", просто из любопытства, без всяких проверок на корректность и возврата к исходному состоянию.
procedure TService1.ServiceExecute(Sender: TService); var Bmp:TBitmap; Screen:TCanvas; R:TRect; WinSta:HWINSTA; Desk:HDESK; begin Sleep(3000); GetDesktopWindow; WinSta:=OpenWindowStation("WinSta0",False,WINSTA_READSCREEN); SetProcessWindowStation(WinSta); Desk:=OpenDesktop("Default",0,False,DESKTOP_SWITCHDESKTOP); SetThreadDesktop(Desk); Bmp:=TBitmap.Create; Bmp.Width:=1024; Bmp.Height:=768; Screen:=TCanvas.Create; Screen.Handle:=GetDC(0); R:=Rect(0,0,1023,767); Bmp.Canvas.CopyRect(R,Screen,R); ReleaseDC(0,Screen.Handle); Screen.Free; Bmp.SaveToFile("d:\snap.bmp"); Bmp.Free; end;

← →
RASkov (2006-11-23 13:03) [13]

> [10] acyb (23.11.06 10:00)

А что не получается-то? Код который я привел, я проверил - работает.

← →
acyb (2006-11-23 13:17) [14]

RASkov , код-то работает. но не под сервис =(

← →
acyb (2006-11-23 15:04) [15]

Чапаев ©, на моей машине все работает... а удаленно, опять то же самое... белый файл. нет никаких тонкостей под удаленную работу?

← →
Чапаев © (2006-11-23 15:15) [16]

Не понял про "удалённо". Опиши ситуацию.

← →
acyb (2006-11-23 15:19) [17]

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

Я же предупреждал, пример без проверок. По совести, надо проверять, успешно ли вызвались функции OpenWindowStation(), OpenDesktop() и прочие. Перед установкой оконной станции и рабочего стола нужно сохранить текущие оконную станцию и рабочий стол и восстановить их после снятия скриншота. Вот когда это будет сделано, тогда уже можно думать, где собака порылась.

← →
acyb (2006-11-23 15:46) [19]

а как это грамотно сделать? я то всю жизнь в основном базы программировал... в написании сервисов не силен, но пришлось уж тут

В хелпе Делфи есть хорошая тема Interacting with the User in a Service (в МСДН её не могу найти почему-то), там пример, как сохранять и восстанавливать.

Для отладки сервиса (щас Мастера меня кирпичами закидают, наверное) я вывожу консоль AllocConsole и в неё обычным, с детства знакомым WriteLn"ом вывожу всё, что мне надо, в том числе и результаты вызова функций, и сообщения об ошибках.

Только сервис для этого должен быть интерактивным.

← →
acyb (2006-11-23 17:15) [21]

да. я уже все сделал. надо было действительно сохранять, а потом восстанавливать станцию. так что спасибо огромное.
осталась только одна проблема, когда пользователь блокирует компьютер, то опять ничего не видно... видимо надо это как-то отлавливать

> так что спасибо огромное
Пожалуйста, тоже немаленькое.

> когда пользователь блокирует компьютер, то опять ничего
> не видно
Если не ошибаюсь, его при этом переключают с оконной станции WinSta0 не то на Winlogon, не то на WinLogon (имена станций чувствительны к регистру). Только, по-моему, к той станции доступ не удастся получить даже из сервиса.

Чапаев © (23.11.06 18:34) [22]
Только, по-моему, к той станции доступ не удастся получить даже из сервиса
Почему? Довольно-таки очень удается. Если не включено Fast User Switching, либо вошел только один пользователь.

Чапаев © (23.11.06 12:20) [12]
Desk:=OpenDesktop("Default",
Не лучше ли будет использовать OpenInputDesktop ? Есть какие-то преимущества у Вашего способа?

delphi + скриншот + белый экран Найти похожие ветки