Top.Mail.Ru
Мастера DELPHI, Delphi programming community Титульная страница Поиск, карта сайта Написать письмо 
| Новости | Поиск | FAQ | Статьи | Книги | Новости VCL |
| Форумы ЧАТ | Орешник | KOL и MCK |
Форумы -» Основная («Начинающим»)/ Базы / WinAPI / Компоненты / Сети / Media / Игры / Corba и COM / KOL / FreePascal / .Net / Прочее / RSDN.ORG

« предыдущая ветвь | форум | следующая ветвь »

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


Страницы:   1 2

acyb ©   (2006-11-21 10:05:00) 

делаю программно скриншот, но в результате получается белый файл. 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;

kami   (2006-12-05 15:26:00) [1]

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

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

Чапаев   (2006-11-23 18:34:00) [2]

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


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

acyb   (2006-11-23 17:15:00) [3]

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

Чапаев   (2006-11-23 16:37:00) [4]

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

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

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

acyb   (2006-11-23 15:46:00) [5]

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

Чапаев   (2006-11-23 15:39:00) [6]

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

acyb   (2006-11-23 15:19:00) [7]

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

Чапаев   (2006-11-23 15:15:00) [8]

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

acyb   (2006-11-23 15:04:00) [9]

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

acyb   (2006-11-23 13:17:00) [10]

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

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

> [10] acyb   (23.11.06 10:00)

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

Чапаев   (2006-11-23 12:20:00) [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;

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

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

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

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

RASkov   (2006-11-23 04:29:00) [15]

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-22 13:18:00) [16]

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

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:

Чапаев   (2006-11-22 12:52:00) [17]

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

Чапаев   (2006-11-22 12:48:00) [18]

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

acyb   (2006-11-22 11:32:00) [19]

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

Stexen   (2006-11-21 19:40:00) [20]

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

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

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

Страницы:   1 2

Наверх

Титульная страница Поиск, карта сайта Написать письмо