Júlio
asked on
Delphi: Screenshot opengl game full screen
I need help to take screenshots fullscreen game (quake live).
This can take screenshots but only if i hit alt+tab:
I need to do it while playing in fullscreen.
I try, Windowed := False; but don't work.
ty
This can take screenshots but only if i hit alt+tab:
procedure CaptureScreen(const FileName: string;Const FileType: TD3DXImageFileFormat);
var
pD3D: IDirect3D9;
pSurface: IDirect3DSurface9;
g_pD3DDevice: IDirect3DDevice9;
D3DPP: TD3DPresentParameters;
begin
FillChar(d3dpp, SizeOf(d3dpp), 0);
With D3DPP do
Begin
Windowed := True;
Flags := D3DPRESENTFLAG_LOCKABLE_BACKBUFFER;
SwapEffect := D3DSWAPEFFECT_DISCARD;
BackBufferWidth := Screen.Width;
BackBufferHeight := Screen.Height;
BackBufferFormat := D3DFMT_X8R8G8B8;
end;
pD3D := Direct3DCreate9(D3D_SDK_VERSION);
pD3D.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, GetDesktopWindow,D3DCREATE_SOFTWARE_VERTEXPROCESSING, @D3DPP, g_pD3DDevice);
Try
g_pD3DDevice.CreateOffscreenPlainSurface(Screen.Width, Screen.Height, D3DFMT_A8R8G8B8, D3DPOOL_SCRATCH, pSurface, nil);
g_pD3DDevice.GetFrontBufferData(0, pSurface);
D3DX9.D3DXSaveSurfaceToFile(PChar(FileName),FileType,pSurface,nil,nil);
Finally
pSurface := nil;
g_pD3DDevice := nil;
pD3D := nil;
End;
end;
ssSave := ExtractFilePath(Application.ExeName);
ssNome_local := ssSave + FormatDateTime('dd_mm_yyyy', now) + '_' + FormatDateTime('hh_mm_ss', now);
CaptureScreen(ssNome_local + '.jpeg', D3DXIFF_JPG);
I need to do it while playing in fullscreen.
I try, Windowed := False; but don't work.
ty
ASKER
This only in windowed mode:
procedure SShot(shot: string);
var
dibH : hBitmap;
bits : pointer;
info : TBITMAPINFO;
width,height : integer;
screenDC,dibDC : hDC;
f : file of byte;
FileHeader : TBITMAPFILEHEADER;
begin
screenDC := getDC(getDeskTopWindow);
dibDC := createCompatibleDC(screenDC);
width := getDeviceCaps(screenDC,HORZRES);
height := getDeviceCaps(screenDC,VERTRES);
info.bmiHeader.biXPelsPerMeter := round(getDeviceCaps(screenDC,LOGPIXELSX)*39.37);
info.bmiHeader.biYPelsPerMeter := round(getDeviceCaps(screenDC,LOGPIXELSY)*39.37);
zeromemory(@info,sizeOf(info));
with info.bmiHeader do
begin
biSize := sizeOf(TBITMAPINFOHEADER);
biWidth := width;
biheight := height;
biplanes := 1;
biBitCount := 24;
biCompression := BI_RGB;
end;
dibH := createDIBSection(dibDC,info,DIB_RGB_COLORS,bits,0,0);
selectObject(dibDC,dibH);
bitblt(
dibDC,
0,0,width,height,
screenDC,
0,0,
SRCCOPY);
releaseDC(getDeskTopWindow,screenDC);
assignFile(f,shot);
reWrite(f);
if width and 3 <> 0 then
width := 4*((width div 4)+1);
with fileHeader do
begin
bfType := ord('B')+(ord('M')shl 8);
bfSize := sizeOf(TBITMAPFILEHEADER)+sizeOf(TBITMAPINFOHEADER)+width*height*3;
bfOffBits := sizeOf(TBITMAPINFOHEADER);
end;
blockWrite(f,fileHeader,sizeOf(TBITMAPFILEHEADER));
blockWrite(f,info.bmiHeader,sizeOf(TBITMAPINFOHEADER));
blockWrite(f,bits^,width*height*3);
closeFile(f);
deleteObject(dibH);
deleteDC(dibDC);
end;
I try your code and with little modification work for me:
another versions are described in old EE quesitons:
http://www.experts-exchang e.com/Prog ramming/La nguages/Pa scal/Delph i/Q_266143 93.html
http://www.experts-exchang e.com/Prog ramming/La nguages/Pa scal/Delph i/Q_251471 97.html
GL variant:
(using: dglOpenGL.pas)
procedure CaptureScreen(const FileName: string;Const FileType: TD3DXImageFileFormat);
var
pD3D: IDirect3D9;
pSurface: IDirect3DSurface9;
g_pD3DDevice: IDirect3DDevice9;
D3DPP: TD3DPresentParameters;
begin
FillChar(d3dpp, SizeOf(d3dpp), 0);
With D3DPP do
Begin
Windowed := True;
Flags := D3DPRESENTFLAG_LOCKABLE_BACKBUFFER or D3DPRESENTFLAG_DEVICECLIP or D3DPRESENTFLAG_VIDEO;
SwapEffect := D3DSWAPEFFECT_DISCARD;
BackBufferWidth := Screen.Width;
BackBufferHeight := Screen.Height;
BackBufferFormat := D3DFMT_X8R8G8B8;
end;
pD3D := Direct3DCreate9(D3D_SDK_VERSION);
pD3D.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, GetDesktopWindow,
D3DCREATE_SOFTWARE_VERTEXPROCESSING, @D3DPP, g_pD3DDevice);
Try
g_pD3DDevice.CreateOffscreenPlainSurface(Screen.Width, Screen.Height, D3DFMT_A8R8G8B8,
D3DPOOL_SYSTEMMEM, pSurface, nil); //D3DPOOL_SCRATCH
g_pD3DDevice.GetFrontBufferData(0, pSurface);
Winapi.D3DX9.D3DXSaveSurfaceToFile(PChar(FileName),FileType,pSurface,nil,nil);
Finally
pSurface := nil;
g_pD3DDevice := nil;
pD3D := nil;
End;
end;
another versions are described in old EE quesitons:
http://www.experts-exchang
http://www.experts-exchang
GL variant:
(using: dglOpenGL.pas)
procedure CaptureScreen2(const AFileName: string);
var
hWin: HWND;
MyDC: HDC;
MyRC: HGLRC;
pPixels: PIntegerArray;
pLine: PIntegerArray;
bmp: TBitmap;
i, j, iWidth, iHeight: Integer;
rgba: Cardinal;
begin
InitOpenGL;
iWidth := Screen.Width;
iHeight := Screen.Height;
hWin := GetDesktopWindow;
MyDC := GetDc(hWin);
MyRC := CreateRenderingContext(MyDC, [opDoubleBuffered], 32, 24, 8, 0, 0, 0);
ActivateRenderingContext(MyDC, MyRC);
try
bmp := TBitmap.Create;
try
//get buffer memory
GetMem(pPixels, iWidth * iHeight * 4);
try
bmp.PixelFormat := pf32bit;
bmp.Height := iHeight;
bmp.Width := iWidth;
//set byte align?
glPixelStorei(GL_PACK_ALIGNMENT, 1);
//gl which gl buffer
glReadBuffer(GL_FRONT);
//get pixels
glReadPixels(0, 0, iWidth, iHeight, GL_RGBA, GL_UNSIGNED_BYTE, pPixels);
//scan each line from bitmap and copy color bytes with byte transformation
for i := 0 to iHeight-1 do
begin
pLine := bmp.ScanLine[i];
//get each 32bit color in a row
for j := 0 to iWidth-1 do
begin
rgba := pPixels[(iHeight-1-i) * iWidth + j];
pLine^[j] :=
(rgba and $FF000000) or
((rgba shl 16) and $00FF0000) or
(rgba and $0000FF00) or
((rgba shr 16) and $000000FF); //abgr -> argb
end;
end;
bmp.SaveToFile(AFileName);
finally
FreeMem(pPixels);
end;
finally
bmp.Free;
end;
finally
//Deactivates current context
DeactivateRenderingContext;
wglDeleteContext(myRC);
ReleaseDC(GetDesktopWindow, myDC);
end;
end;
ASKER
1- OpenGl code error:
delphi system error. Code: -1073283066
dglOpenGL unit: DescribePixelFormat(DC, PixelFormat, SizeOf(PFDescriptor), PFDescriptor);
Error all time.
I think the problem is here:
MyRC := CreateRenderingContext(MyD C, [opDoubleBuffered], 32, 24, 8, 0, 0, 0); With the "MyDC"
I change de opDoubleBuffered to opGDI, but the schreenshot is gray, but don't give error and it's very slow to create the file.
opDoubleBuffered = with acceleration, opGDI without acceleration.
I'm using the last nvidia driver 331.65 (opengl 4.3).
2- Directx Code error:
Access violation at addres 00524821... Read of address 0000000000.
These error happen when I enter the game full screen.
What you need to help me?
opengl-screen-problem.PNG
delphi system error. Code: -1073283066
dglOpenGL unit: DescribePixelFormat(DC, PixelFormat, SizeOf(PFDescriptor), PFDescriptor);
Error all time.
I think the problem is here:
MyRC := CreateRenderingContext(MyD
I change de opDoubleBuffered to opGDI, but the schreenshot is gray, but don't give error and it's very slow to create the file.
opDoubleBuffered = with acceleration, opGDI without acceleration.
I'm using the last nvidia driver 331.65 (opengl 4.3).
2- Directx Code error:
Access violation at addres 00524821... Read of address 0000000000.
These error happen when I enter the game full screen.
What you need to help me?
opengl-screen-problem.PNG
Seem that in that moment MyDC is zero. These threads try to use window handle from game and DC from it but think without success:
Topic 1 and
Topic 2
try to use zero for handle:
Topic 1 and
Topic 2
try to use zero for handle:
hWin := 0;
MyDC := GetDc(hWin);
if MyDC>0 then
begin
MyRC := CreateRenderingContext(MyDC, [opDoubleBuffered], 32, 24, 0, 0, 0, 0);
ActivateRenderingContext(MyDC, MyRC);
...
ASKER
With "0" don't work too.
What i need? Hook?
Trying this one, generate a tga file with 1kb =/:
What i need? Hook?
Trying this one, generate a tga file with 1kb =/:
procedure GLScreenShot(name : string);
type TTGAHEADER = packed record
tfType : Byte;
tfColorMapType : Byte;
tfImageType : Byte;
tfColorMapSpec : Array[0..4] of Byte;
tfOrigX : Array [0..1] of Byte;
tfOrigY : Array [0..1] of Byte;
tfWidth : Array [0..1] of Byte;
tfHeight : Array [0..1] of Byte;
tfBpp : Byte;
tfImageDes : Byte;
end;
const MaxSize_ = 1920 * 1080 * 4 + 1;
var Buffer : array of Byte;
c,i,j,temp : integer;
f : file;
tgaHeader : TTGAHEADER;
ffwidth, ffheight : integer;
viewport : Array[0..3] of integer;
Bit : TBitMap;
begin
glGetIntegerv(GL_VIEWPORT, @viewport);
ffwidth := viewport[2];
ffheight:= viewport[3];
c:= ffWidth * ffHeight * 4;
if c > maxsize_ then Exit;
SetLength(buffer,c);
ZeroMemory(@tgaHeader, SizeOf(tgaHeader));
// Fill the structure with info for the image to be saved
tgaHeader.tfImageType := 2; // TGA_RGB = 2
tgaHeader.tfWidth[0] := ffWidth and 255;
tgaHeader.tfWidth[1] := ffWidth shr 8;
tgaHeader.tfHeight[0] := ffHeight and 255;
tgaHeader.tfHeight[1] := ffHeight shr 8;
tgaHeader.tfBpp := 24;
// glReadBuffer(GL_FRONT);
glReadPixels(0,0,ffWidth, ffHeight, GL_RGBA, GL_UNSIGNED_BYTE, @Buffer[0]); // get image as 32-bit format
// swap rgb to bgr
i := 0;
while ( i < c) do
begin
temp := buffer[i];
buffer[i] := buffer[i+2];
buffer[i+2] := temp;
inc(i,4);
end;
c := ffwidth * ffheight * 3;
i := 0;
j := 0;
while ( i < c) do // convert from 32-bit to 24 bitformat
begin
Buffer[i] := Buffer[j];
Buffer[i+1] := Buffer[j+1];
Buffer[i+2] := Buffer[j+2];
Inc(i,3);
Inc(j,4);
end;
AssignFile(f, name);
Rewrite( f,1 );
BlockWrite(F, tgaHeader, SizeOf(tgaHeader));
BlockWrite(f, buffer[0], c );
CloseFile(f);
SetLength(buffer, 0 );
end;
In Topic 1 and Topc 2 (upper post) there are few examples - can you try some?
Try to do debug with step by step (F8) and step in (F7) and go in CreateRenderingContext function wich fail to look/find place...
Try to do debug with step by step (F8) and step in (F7) and go in CreateRenderingContext function wich fail to look/find place...
ASKER
I'm trying.
Debug your code give this, the problem is with PixelFormat:
PixelFormat := ChoosePixelFormat(DC, @PFDescriptor);
if GetPixelFormat(DC) <> PixelFormat then
if not SetPixelFormat(DC, PixelFormat, @PFDescriptor) then
RaiseLastOSError;
Debug your code give this, the problem is with PixelFormat:
PixelFormat := ChoosePixelFormat(DC, @PFDescriptor);
if GetPixelFormat(DC) <> PixelFormat then
if not SetPixelFormat(DC, PixelFormat, @PFDescriptor) then
RaiseLastOSError;
Maybe you need right combination - couse function ChoosePixelFormat didn't find compatible format:
your example for saving in tga works?
MyRC := CreateRenderingContext(MyDC, [opDoubleBuffered], 24, 16, 0, 0, 0, 0);
or
MyRC := CreateRenderingContext(MyDC, [opDoubleBuffered], 24, 0, 0, 0, 0, 0);
your example for saving in tga works?
ASKER
Yes, The problem is with PixelFormat, look what i did to get handle and now the error is:
"System Error. Code: 2000.
The pixel format is invalid."
"System Error. Code: 2000.
The pixel format is invalid."
unit unir_principal;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, jpeg,
dglOpenGL, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
ListBox1: TListBox;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
private
procedure CaptureScreen2(const AFileName: string);
{ Private declarations }
public
RC : HGLRC;
DC : HDC;
FoundWindow : hwnd;
{ Public declarations }
end;
var
Form1: TForm1;
implementation
//-------------------here
function AllWindows(wHnd: THandle; List: TStringList): Bool; stdcall;
var
Buffer: array[0..255] of char;
begin
SendMessage(wHnd, WM_GETTEXT, 255, LongInt(@Buffer[0]));
if (Buffer <> '') and IsWindow(wHnd) then
begin
List.AddObject(Buffer, TObject(wHnd));
end;
Result := True;
end;
//-----------------------
{$R *.dfm}
procedure TForm1.CaptureScreen2(const AFileName: string);
var
hWin: HWND;
MyDC: HDC;
MyRC: HGLRC;
pPixels: PIntegerArray;
pLine: PIntegerArray;
bmp: TBitmap;
i, j, iWidth, iHeight: Integer;
rgba: Cardinal;
ListIndex : Integer;
begin
InitOpenGL;
iWidth := Screen.Width;
iHeight := Screen.Height;
//-------------------here
ListIndex := ListBox1.ItemIndex;
hWin := THandle(ListBox1.Items.Objects[ListIndex]);
//---------------------
// hWin := GetDesktopWindow;
MyDC := GetDc(hWin);
MyRC := CreateRenderingContext(MyDC, [opDoubleBuffered], 32, 24, 8, 0, 0, 0);
ActivateRenderingContext(MyDC, MyRC);
try
bmp := TBitmap.Create;
try
GetMem(pPixels, iWidth * iHeight * 4);
try
bmp.PixelFormat := pf32bit;
bmp.Height := iHeight;
bmp.Width := iWidth;
glPixelStorei(GL_PACK_ALIGNMENT, 1);
glReadBuffer(GL_FRONT);
glReadPixels(0, 0, iWidth, iHeight, GL_RGBA, GL_UNSIGNED_BYTE, pPixels);
for i := 0 to iHeight-1 do
begin
pLine := bmp.ScanLine[i];
for j := 0 to iWidth-1 do
begin
rgba := pPixels[(iHeight-1-i) * iWidth + j];
pLine^[j] :=
(rgba and $FF000000) or
((rgba shl 16) and $00FF0000) or
(rgba and $0000FF00) or
((rgba shr 16) and $000000FF); //abgr -> argb
end;
end;
bmp.SaveToFile(AFileName);
finally
FreeMem(pPixels);
end;
finally
bmp.Free;
end;
finally
DeactivateRenderingContext;
wglDeleteContext(myRC);
ReleaseDC(GetDesktopWindow, myDC);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
Var
ListIndex : Integer;
begin
InitOpenGL;
//-------------------here
ListIndex := ListBox1.ItemIndex;
FoundWindow := THandle(ListBox1.Items.Objects[ListIndex]);
//--------------------------
if foundwindow > 0 then
begin
DC := GetDC(FoundWindow);
RC := CreateRenderingContext(DC, [opDoubleBuffered], 32, 24, 0, 0, 0, 0);
ActivateRenderingContext(DC, RC);
glEnable(GL_DEPTH_TEST);
glDepthFunc(GL_LESS);
glClearColor(0,0,0,0);
Form1.Caption := inttostr (FoundWindow);
end
else
Form1.Caption := 'Game Not Found';
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
CaptureScreen2('t_est.bmp');
end;
procedure TForm1.Button3Click(Sender: TObject); //find all then i select the game
begin
ListBox1.Clear;
EnumWindows(@AllWindows, LParam(ListBox1.Items));
end;
end.
ASKER
With tga don't work too, i got a file with 1kb and corrupt.
The handle problem maybe is solved, now need to find a solution to pixel, let me try what you told. =)
The handle problem maybe is solved, now need to find a solution to pixel, let me try what you told. =)
ASKER
I fix it, but screenshot is black. =(
1- Enter a server of Quake live (quakelive.com)
2- Press Button3 "List All"
3- Select the window of the game (listbox)
4- Press Button1 "Handle"
5- Go play fullscreen and use the shortcut CTRL + A (button3 "screenshot").
6- bmp all black.
unit unir_principal;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, jpeg,
dglOpenGL, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
ListBox1: TListBox;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
hotkey1 : Integer;
procedure CaptureScreen2(const AFileName: string);
procedure WMHotKey(var Msg : TWMHotKey); message WM_HOTKEY;
{ Private declarations }
public
RC : HGLRC;
DC : HDC;
FoundWindow : hwnd;
{ Public declarations }
end;
var
Form1: TForm1;
implementation
function AllWindows(wHnd: THandle; List: TStringList): Bool; stdcall;
var
Buffer: array[0..255] of char;
begin
SendMessage(wHnd, WM_GETTEXT, 255, LongInt(@Buffer[0]));
if (Buffer <> '') and IsWindow(wHnd) then
begin
List.AddObject(Buffer, TObject(wHnd));
end;
Result := True;
end;
{$R *.dfm}
procedure TForm1.CaptureScreen2(const AFileName: string);
var
hWin: HWND;
MyDC: HDC;
MyRC: HGLRC;
pPixels: PIntegerArray;
pLine: PIntegerArray;
bmp: TBitmap;
i, j, iWidth, iHeight: Integer;
rgba: Cardinal;
ListIndex : Integer;
begin
InitOpenGL;
iWidth := Screen.Width;
iHeight := Screen.Height;
ListIndex := ListBox1.ItemIndex;
hWin := THandle(ListBox1.Items.Objects[ListIndex]);
// hWin := GetDesktopWindow;
MyDC := GetDc(hWin);
MyRC := CreateRenderingContext(MyDC, [opDoubleBuffered], 24, 16, 0, 0, 0, 0);
ActivateRenderingContext(MyDC, MyRC);
try
bmp := TBitmap.Create;
try
GetMem(pPixels, iWidth * iHeight * 4);
try
bmp.PixelFormat := pf32bit;
bmp.Height := iHeight;
bmp.Width := iWidth;
glPixelStorei(GL_PACK_ALIGNMENT, 1);
glReadBuffer(GL_FRONT);
glReadPixels(0, 0, iWidth, iHeight, GL_RGBA, GL_UNSIGNED_BYTE, pPixels);
for i := 0 to iHeight-1 do
begin
pLine := bmp.ScanLine[i];
for j := 0 to iWidth-1 do
begin
rgba := pPixels[(iHeight-1-i) * iWidth + j];
pLine^[j] :=
(rgba and $FF000000) or
((rgba shl 16) and $00FF0000) or
(rgba and $0000FF00) or
((rgba shr 16) and $000000FF); //abgr -> argb
end;
end;
bmp.SaveToFile(AFileName);
finally
FreeMem(pPixels);
end;
finally
bmp.Free;
end;
finally
DeactivateRenderingContext;
wglDeleteContext(myRC);
ReleaseDC(GetDesktopWindow, myDC);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
const MOD_CONTROL = 2;
VK_A = 65;
begin
hotkey1 := GlobalAddAtom('Hotkey1');
RegisterHotKey(handle, hotkey1, MOD_CONTROL,VK_A);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
UnRegisterHotKey(handle, hotkey1);
end;
procedure TForm1.WMHotKey(var Msg: TWMHotKey);
begin
if msg.HotKey = hotkey1 then button2.Click;
end;
procedure TForm1.Button1Click(Sender: TObject);
Var
ListIndex : Integer;
begin
InitOpenGL;
ListIndex := ListBox1.ItemIndex;
FoundWindow := THandle(ListBox1.Items.Objects[ListIndex]);
if foundwindow > 0 then
begin
DC := GetDC(FoundWindow);
RC := CreateRenderingContext(DC, [opDoubleBuffered], 24, 16, 0, 0, 0, 0);
ActivateRenderingContext(DC, RC);
glEnable(GL_DEPTH_TEST);
glDepthFunc(GL_LESS);
glClearColor(0,0,0,0);
Form1.Caption := inttostr (FoundWindow);
end
else
Form1.Caption := 'Game Not Found';
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
CaptureScreen2(FormatDateTime('dd_mm_yyyy', now) + '_' + FormatDateTime('hh_mm_ss', now) + '.bmp');
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
ListBox1.Clear;
EnumWindows(@AllWindows, LParam(ListBox1.Items));
end;
end.
1- Enter a server of Quake live (quakelive.com)
2- Press Button3 "List All"
3- Select the window of the game (listbox)
4- Press Button1 "Handle"
5- Go play fullscreen and use the shortcut CTRL + A (button3 "screenshot").
6- bmp all black.
ASKER
Maybe the problem of black screenshot is here:
When i remove screenshot is white =p
Do i need a OpenGL Hook? If so, i don't know how to hook.
for i := 0 to iHeight-1 do
begin
pLine := bmp.ScanLine[i];
for j := 0 to iWidth-1 do
begin
rgba := pPixels[(iHeight-1-i) * iWidth + j];
pLine^[j] :=
(rgba and $FF000000) or
((rgba shl 16) and $00FF0000) or
(rgba and $0000FF00) or
((rgba shr 16) and $000000FF); //abgr -> argb
end;
end;
When i remove screenshot is white =p
Do i need a OpenGL Hook? If so, i don't know how to hook.
I think that hook is not needed. Conversion abgr -> argb is for color only. For "black"/"white" pixels you can try glReadBuffer(GL_BACK) instead of glReadBuffer(GL_FRONT)
ASKER
glReadBuffer(GL_BACK) screenshot is all black too =(.
I don't know what to do.
I don't know what to do.
ASKER
I found something, i think.
The client game windows is a sub-handle.
The handle i was talking is de main of application, let say Handle 919112.
The in-game "handle" is 002508E0.
I found this with Spy++.
How to find sub-handle (caption and class always quake live) starting at main handle?
This is like a Twebbrower inside of a form. Quake Live ia web-browser 3D opengl game.
handle-game.PNG
The client game windows is a sub-handle.
The handle i was talking is de main of application, let say Handle 919112.
The in-game "handle" is 002508E0.
I found this with Spy++.
How to find sub-handle (caption and class always quake live) starting at main handle?
This is like a Twebbrower inside of a form. Quake Live ia web-browser 3D opengl game.
handle-game.PNG
when you find main window with FindWindow for example then you can fin sub child window with FindWindowEx. It is quite easy to do this when you know class and/or text.
http://msdn.microsoft.com/ en-us/libr ary/window s/desktop/ ms633500%2 8v=vs.85%2 9.aspx
My suggestion is to use EnumWindows function which will go to all windows not depending of parent/child relationship.
http://www.swissdelphicent er.ch/torr y/showcode .php?id=41 0
Another thought is to use "third part" tools:
http://www.frontiernet.net /~w2m/appr ehend.html
http://taksi.sourceforge.n et/
http://msdn.microsoft.com/
My suggestion is to use EnumWindows function which will go to all windows not depending of parent/child relationship.
http://www.swissdelphicent
Another thought is to use "third part" tools:
http://www.frontiernet.net
http://taksi.sourceforge.n
ASKER
This is my code:
All windows:
Child of Main handle:
This is not a window, how i get the handle of the child, the id is 0?
Maybe this is the key to solve the black screenshot.
If you want i can send my project.
This is always "0" when i try FindWindowEx with the selected child:
Taksi don't work too, because of the child.
All windows:
"function AllWindows(wHnd: THandle; List: TStringList): Bool; stdcall;
var
Buffer: array[0..255] of char;
begin
SendMessage(wHnd, WM_GETTEXT, 255, LongInt(@Buffer[0]));
if (Buffer <> '') and IsWindow(wHnd) then
begin
List.AddObject(Buffer, TObject(wHnd));
end;
Result := True;
end;
EnumWindows(@AllWindows, LParam(ListBox1.Items));
Child of Main handle:
function EnumChildProc(wnd: HWND; List_child: TListBox): BOOL; stdcall;
var
buf, caption: array[0..255] of char;
id_control: Integer;
begin
GetClassName(wnd, buf, SizeOf(buf) - 1); //class
SendMessage(wnd, WM_GETTEXT, 256, Integer(@Caption)); //name
id_control := GetDlgCtrlID(wnd); //id
List_child.Items.Add('ID: ' + IntToStr(id_control) + ' - ' + ' Classe: ' + (buf) + ' - Caption: ' + (caption));
Result := True;
end;
EnumChildWindows(FoundWindow, @EnumChildProc, Integer(ListBox2));
This is not a window, how i get the handle of the child, the id is 0?
Maybe this is the key to solve the black screenshot.
If you want i can send my project.
This is always "0" when i try FindWindowEx with the selected child:
Var
listIndex1 : Integer;
begin
ListIndex1 := ListBox2.ItemIndex;
FoundWindow2 := THandle(ListBox2.Items.Objects[ListIndex1]);
FoundWindow3 := FindWindowEx(FoundWindow, 0, 'Quake Live', 0);
if FoundWindow3 > 0 then
Listbox3.Items.Add(inttostr(FoundWindow3))
Else
Begin
exit; // FoundWindow4 := GetDlgItem(FoundWindow2, ?);
End;
end;
Taksi don't work too, because of the child.
ASKER
I tested with a standalone opengl game and all screenshots are black too.
The game is windowed 800x600 and the screenshot is 1920x1080 all black.
Solution:
All sceenshot is black =(
I wa thinking about sruface, and if the game is in a different surface, how to find it?
The game is windowed 800x600 and the screenshot is 1920x1080 all black.
Solution:
GetWindowRect(hWin, WindRect);
iWidth := WindRect.Width;
iHeight := WindRect.Height;
All sceenshot is black =(
I wa thinking about sruface, and if the game is in a different surface, how to find it?
dm0000 have you still got glReadBuffer(GL_FRONT) commented out in your current code?
Yes, this is a layer issue. AFAIK you don't have to define the layer you are looking at just ignore the front one.
<disclaimer - I am NOT a programmer !!>
Yes, this is a layer issue. AFAIK you don't have to define the layer you are looking at just ignore the front one.
<disclaimer - I am NOT a programmer !!>
ASKER
Don't work remove glReadBuffer(GL_FRONT) .
I think if i need is glReadBuffer(GL_BACK) because it is doublebufferd and GL_FRONT single.
Yes, this a layer problem, with quake 3 same engine of Quake Live, screenshot is all black too, so the problem ins't the handle.
I think if i need is glReadBuffer(GL_BACK) because it is doublebufferd and GL_FRONT single.
Yes, this a layer problem, with quake 3 same engine of Quake Live, screenshot is all black too, so the problem ins't the handle.
As much as I enjoy all this messing with surfaces and buffers, have you considered grabbing the window image with BitBlt or something similar? This is the relevant page from MSDN. It's not clever, or especially fast, but it will get around the black screen issue.
ASKER
Don't work too, screenshot now are all gray.
const
CAPTUREBLT = $40000000;
var
hdcScreen : DWORD;
hdcCompatible : DWORD;
hbmScreen : DWORD;
bmp : TBitmap;
begin
bmp := TBitmap.Create;
try
hdcScreen := CreateDC('DISPLAY', nil, nil, nil);
if hdcScreen = 0 then begin
ShowMessage('CreateDC: '+SysErrorMessage(GetLastError));
Exit;
end;
try
hdcCompatible := CreateCompatibleDC(hdcScreen);
if hdcCompatible = 0 then begin
ShowMessage('CreateCompatibleDC: '+SysErrorMessage(GetLastError));
Exit;
end;
try
SetStretchBltMode(hdcCompatible,HALFTONE);
StretchBlt(hdcCompatible, 0, 0, bmp.Width, bmp.Height,
hdcScreen,
0,0,
GetSystemMetrics (SM_CXSCREEN),
GetSystemMetrics (SM_CYSCREEN),
SRCCOPY);
hbmScreen := CreateCompatibleBitmap(hdcScreen,GetDeviceCaps(hdcScreen, HORZRES),GetDeviceCaps(hdcScreen, VERTRES));
if hbmScreen = 0 then begin
ShowMessage('CreateCompatibleBitmap: '+SysErrorMessage(GetLastError));
Exit;
end;
try
SelectObject(hdcCompatible, hbmScreen);
bmp.Handle := hbmScreen;
BitBlt(hdcCompatible, 0, 0, bmp.Width, bmp.Height, hdcScreen, 0, 0,
SRCCOPY or CAPTUREBLT);
bmp.SaveToFile(ExtractFilePath(application.ExeName) + 'Screenshot.bmp');
finally
DeleteObject(hbmScreen);
end;
finally
DeleteDC(hdcCompatible);
end;
finally
DeleteDC(hdcScreen);
end;
finally
FreeAndNil(bmp);
end;
end;
What is the StretchBlt on line 26 for?
ASKER
To map pixels, i think.
I don't think that part of the code achieves anything. After CreateCompatibleDC, hdcCompatble will be a 1x1 monochrome memory DC. So the StretchBlt probably won't do anything useful. That DC only has a size after selecting hbmScreen into it. Then the code does a BitBlt that should work, Its using HORZRES and VERTRES to create the bitmap, then bmp.Width and bmp.Height for the blit, can you check they are the same values?
ASKER
Don't work to 3D Application.
Maybe inject dll with opengl code and take screenshot without hook? I'm not good with hook.
Opengl code:
Procedure TForm1.SS(const file_name : string);
const
CAPTUREBLT = $40000000;
var
hdcScreen : DWORD;
hdcCompatible : DWORD;
hbmScreen : DWORD;
bmp : TBitmap;
ListIndex : Integer;
iWidth : Integer;
iHeight : integer;
WindRect : TRect;
hwin : HWND;
begin
ListIndex := Listbox1.ItemIndex;
hWin := THandle(ListBox1.Items.Objects[ListIndex]); //1
begin
bmp := TBitmap.Create;
try
hdcScreen := CreateDC('DISPLAY', nil, nil, nil);
if hdcScreen = 0 then begin
ShowMessage('CreateDC: '+SysErrorMessage(GetLastError));
Exit;
end;
try
hdcCompatible := CreateCompatibleDC(hdcScreen);
if hdcCompatible = 0 then begin
ShowMessage('CreateCompatibleDC: '+SysErrorMessage(GetLastError));
Exit;
end;
try
GetWindowRect(hWin, WindRect);
iWidth := WindRect.Width;
iHeight := WindRect.Height;
hbmScreen := CreateCompatibleBitmap(hdcScreen,WindRect.Width,WindRect.Height); //GetDeviceCaps(hdcScreen, HORZRES) GetDeviceCaps(hdcScreen, VERTRES))
if hbmScreen = 0 then begin
ShowMessage('CreateCompatibleBitmap: '+SysErrorMessage(GetLastError));
Exit;
end;
try
SelectObject(hdcCompatible, hbmScreen);
bmp.Handle := hbmScreen;
BitBlt(hdcCompatible, 0, 0, WindRect.Width, WindRect.Height, hdcScreen, 0, 0, SRCCOPY or CAPTUREBLT);
bmp.SaveToFile(file_name);
finally
DeleteObject(hbmScreen);
end;
finally
DeleteDC(hdcCompatible);
end;
finally
DeleteDC(hdcScreen);
end;
finally
FreeAndNil(bmp);
end;
end;
end;
Maybe inject dll with opengl code and take screenshot without hook? I'm not good with hook.
Opengl code:
procedure TForm1.CaptureScreen2(const AFileName: string);
var
hWin: HWND;
MyDC: HDC;
MyRC: HGLRC;
pPixels: PIntegerArray;
pLine: PIntegerArray;
bmp: TBitmap;
i, j, iWidth, iHeight: Integer;
rgba: Cardinal;
ListIndex, ListIndex2 : Integer;
WindRect : TRect;
begin
InitOpenGL;
ListIndex := Listbox1.ItemIndex;
hWin := THandle(ListBox1.Items.Objects[ListIndex]); //1
if hwin <> 0 then
Begin
GetWindowRect(hWin, WindRect);
iWidth := WindRect.Width;
iHeight := WindRect.Height;
End
Else
Begin
Label4.Caption := 'No handle.';
Exit;
End;
MyDC := GetDc(hWin);
MyRC := CreateRenderingContextVersion(MyDC, [opDoubleBuffered], 4, 0, TRUE, 32, 24, 8, 0, 0, 0); //CreateRenderingContextVersion(MyDC, [opDoubleBuffered], 4, 0, TRUE, 32, 24, 8, 0, 0, 0);`(opDoubleBuffered, opGDI, opStereo);
ActivateRenderingContext(MyDC, MyRC);
try
bmp := TBitmap.Create;
try
GetMem(pPixels, iWidth * iHeight * 4);
try
bmp.PixelFormat := pf32bit;
bmp.Height := iHeight;
bmp.Width := iWidth;
glReadBuffer(GL_BACK);
glPixelStorei(GL_PACK_ALIGNMENT, 1);
glReadPixels(0, 0, iWidth, iHeight, GL_RGBA, GL_UNSIGNED_BYTE, pPixels);
for i := 0 to iHeight-1 do
begin
pLine := bmp.ScanLine[i];
for j := 0 to iWidth-1 do
begin
rgba := pPixels[(iHeight-1-i) * iWidth + j];
pLine^[j] := (rgba and $FF000000) or
((rgba shl 16) and $00FF0000) or (rgba and $0000FF00) or
((rgba shr 16) and $000000FF); //abgr -> argb
end;
end;
bmp.Canvas.Brush.Color := clGreen;
bmp.Canvas.TextOut(0, 0, FormatDateTime('dd_mm_yyyy', now) + '_' + FormatDateTime('hh_mm_ss', now));
bmp.SaveToFile(AFileName);
ListBox3.Items.Add(IntToStr(hwin) + ' : Screenshot');
finally
FreeMem(pPixels);
end;
finally
bmp.Free;
end;
finally
DeactivateRenderingContext;
wglDeleteContext(myRC);
ReleaseDC(hWin, myDC);
end;
end;
If this is going to work, it can't create its own rendering context in that way. Unless a context is shared, it will have its own back buffer. So the back buffer you read from will be different to the buffer being used by the program. To capture it would need the buffers used by the game. This is why it's easier to read from the shared display buffer. If you have a DLL that is running in the process of the game, you could try getting the active context for OpenGL and using that.
ASKER
I don't know how to do that.
Need to inject and hook or just inject em call?
Could you please give me a exmaple?
hook SwapBuffers and do a readback with glReadPixels
Need to inject and hook or just inject em call?
Could you please give me a exmaple?
hook SwapBuffers and do a readback with glReadPixels
ASKER
Like this?
I inject dll with this:
dll to screenshot:
I can inject, but my dll don't work. =(
I inject dll with this:
function InjectDLL(dwPID: DWORD; DLLPath: PWideChar): integer;
var
dwThreadID: Cardinal;
hProc, hThread, hKernel: THandle;
BytesToWrite, BytesWritten: SIZE_T;
pRemoteBuffer, pLoadLibrary: Pointer;
begin
hProc := OpenProcess(PROCESS_CREATE_THREAD or PROCESS_QUERY_INFORMATION or PROCESS_VM_OPERATION or PROCESS_VM_WRITE or PROCESS_VM_READ, False, dwPID);
if hProc = 0 then
exit(0);
try
BytesToWrite := SizeOf(WideChar)*(Length(DLLPath) + 1);
pRemoteBuffer := VirtualAllocEx(hProc, nil, BytesToWrite, MEM_COMMIT, PAGE_READWRITE);
if pRemoteBuffer = nil then
exit(0);
try
if not WriteProcessMemory(hProc, pRemoteBuffer, DLLPath, BytesToWrite, BytesWritten) then
exit(0);
hKernel := GetModuleHandle('kernel32.dll');
pLoadLibrary := GetProcAddress(hKernel, 'LoadLibraryW');
hThread := CreateRemoteThread(hProc, nil, 0, pLoadLibrary, pRemoteBuffer, 0, dwThreadID);
try
WaitForSingleObject(hThread, INFINITE);
finally
CloseHandle(hThread);
end;
finally
VirtualFreeEx(hProc, pRemoteBuffer, 0, MEM_RELEASE);
end;
finally
CloseHandle(hProc);
end;
exit(1);
end;
dll to screenshot:
library Project2;
uses
Winapi.Windows,
Winapi.Messages,
System.SysUtils,
System.Variants,
System.Classes,
Vcl.Graphics,
Vcl.Controls,
Vcl.Forms,
Vcl.Dialogs,
Vcl.StdCtrls,
TLHelp32,
dglOpenGL in '..\..\..\Desktop\QLShot2\Win32\Debug\dglOpenGL.pas';
Var
SwapBuffers : Function(DC: HDC): BOOL;
SwapHook : HHOOK;
Listproc, Listproc2 : TStringList;
Handle_game : THandle;
{$R *.res}
// Gdi32.dll
Function ProcessIDFromAppname32( appname: String ): DWORD;
Var
HDL : THandle;
Estrutura : TProcessEntry32;
Begin
Result := 0;
appName := UpperCase( appname );
HDL := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
If HDL <> 0 Then
try
Estrutura.dwSize := Sizeof(Estrutura);
If Process32First(HDL, Estrutura) Then
Repeat
If Pos(appname, UpperCase(ExtractFilename(StrPas(Estrutura.szExeFile)))) > 0
Then
Begin
Result:= Estrutura.th32ProcessID;
Break;
End;
Until not Process32Next(HDL, Estrutura);
finally
CloseHandle(HDL);
End;
End;
Procedure ListarProcessos;
var
HDL : THandle;
Estrutura : TProcessEntry32;
begin
Listproc := TStringList.Create;
HDL := CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);
Try
Estrutura.dwSize:=Sizeof(TProcessEntry32);
if Process32First(HDL, Estrutura) then
Listproc.Add(Estrutura.szExeFile);
// ListBox.Items.Add(Estrutura.szExeFile);
while Process32Next(HDL, Estrutura) do
Listproc.Add(Estrutura.szExeFile);
//ListBox.Items.Add(Estrutura.szExeFile);
if Listproc.IndexOf('Quake') > -1 Then
Handle_game := ProcessIDFromAppname32(listproc.Strings[Listproc.IndexOf('Quake')]);
Finally
Listproc.Free;
End;
end;
Function SwapBufferCallBack(DC: HDC) : BOOL;
Begin
if DC > 0 then
Result := Swapbuffers(DC);
End;
procedure CaptureScreen2(const AFileName: string);
var
hWin: HWND;
MyDC: HDC;
MyRC: HGLRC;
pPixels: PIntegerArray;
pLine: PIntegerArray;
bmp: TBitmap;
i, j, iWidth, iHeight: Integer;
rgba: Cardinal;
ListIndex, ListIndex2 : Integer;
WindRect : TRect;
begin
InitOpenGL;
//ListIndex := Listbox1.ItemIndex;
// hWin := THandle(ListBox1.Items.Objects[ListIndex]); //1
hWin := Handle_game;
if hwin <> 0 then
Begin
GetWindowRect(hWin, WindRect);
iWidth := WindRect.Width;
iHeight := WindRect.Height;
End
Else
Begin
// Label4.Caption := 'No handle.';
Exit;
End;
MyDC := GetDc(hWin);
MyRC := CreateRenderingContextVersion(MyDC, [opDoubleBuffered], 4, 0, TRUE, 32, 24, 8, 0, 0, 0); //CreateRenderingContextVersion(MyDC, [opDoubleBuffered], 4, 0, TRUE, 32, 24, 8, 0, 0, 0);`(opDoubleBuffered, opGDI, opStereo);
ActivateRenderingContext(MyDC, MyRC);
try
bmp := TBitmap.Create;
try
GetMem(pPixels, iWidth * iHeight * 4);
try
bmp.PixelFormat := pf32bit;
bmp.Height := iHeight;
bmp.Width := iWidth;
SwapBufferCallBack(MyDC);
glReadBuffer(GL_BACK);
glPixelStorei(GL_PACK_ALIGNMENT, 1);
glReadPixels(0, 0, iWidth, iHeight, GL_RGBA, GL_UNSIGNED_BYTE, pPixels);
for i := 0 to iHeight-1 do
begin
pLine := bmp.ScanLine[i];
for j := 0 to iWidth-1 do
begin
rgba := pPixels[(iHeight-1-i) * iWidth + j];
pLine^[j] := (rgba and $FF000000) or
((rgba shl 16) and $00FF0000) or (rgba and $0000FF00) or
((rgba shr 16) and $000000FF); //abgr -> argb
end;
end;
bmp.Canvas.Brush.Color := clGreen;
bmp.Canvas.TextOut(0, 0, FormatDateTime('dd_mm_yyyy', now) + '_' + FormatDateTime('hh_mm_ss', now));
bmp.SaveToFile(AFileName);
//ListBox3.Items.Add(IntToStr(hwin) + ' : Screenshot');
finally
FreeMem(pPixels);
end;
finally
bmp.Free;
end;
finally
DeactivateRenderingContext;
wglDeleteContext(myRC);
ReleaseDC(hWin, myDC);
end;
end;
begin
Swaphook:= SetWindowsHookEx(WH_GETMESSAGE, @SwapBufferCallBack, 0, GetCurrentThreadID);
CaptureScreen2(FormatDateTime('dd_mm_yyyy', now) + '_' + FormatDateTime('hh_mm_ss', now) + '.bmp');
UnhookWindowsHookEx(SwapHook);
end.
I can inject, but my dll don't work. =(
ASKER
Help!
I'd like to, but I'm not sure how to inject code into a running game except to substitute a DLL for the original OpenGL. Most of the functions just call the corresponding function in the original DLL. You might do your screen grab thing in glSwapBuffers, before passing it on. I've never done this, I remember somebody asking about it on EE a while back, they were injecting into Direct3D.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
sinisav's comment reminded me of another reason this wouldn't work without injecting. OpenGL is not multi-threaded, to use its functions correctly you have to be in the thread that created the OpenGL context. A DLL runs in the thread that calls it, unless it creates it own child threads.
Some interesting discussion about the topic:
http://stackoverflow.com/questions/15840143/injecting-a-frame-buffer
http://www.mpcforum.com/showthread.php?10529-Opengl-Hack-Injection-methods
Some interesting discussion about the topic:
http://stackoverflow.com/questions/15840143/injecting-a-frame-buffer
http://www.mpcforum.com/showthread.php?10529-Opengl-Hack-Injection-methods
ASKER
I've requested that this question be closed as follows:
Accepted answer: 0 points for dm0000's comment #a39644895
for the following reason:
I accpet, but need to work iin this.
Accepted answer: 0 points for dm0000's comment #a39644895
for the following reason:
I accpet, but need to work iin this.
ASKER
Not the finnal soluction, but he deserv the credits.
ASKER
Open in new window