Link to home
Start Free TrialLog in
Avatar of Júlio
JúlioFlag for Brazil

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:

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;

Open in new window


ssSave := ExtractFilePath(Application.ExeName);
ssNome_local := ssSave + FormatDateTime('dd_mm_yyyy', now) + '_' + FormatDateTime('hh_mm_ss', now);
CaptureScreen(ssNome_local + '.jpeg', D3DXIFF_JPG);

Open in new window


I need to do it while playing in fullscreen.
I try, Windowed := False; but don't work.

ty
Avatar of Júlio
Júlio
Flag of Brazil image

ASKER

Opengl code, don't work too, all black.

Procedure QLSS(salvar: string);
var
   pbuf: pointer;
   y: integer;
   bmp: TBitmap;
   p1, p2: pointer;
begin
   GetMem( pbuf, Screen.Width * Screen.Height * 4);
   glReadBuffer(GL_FRONT);
   glReadPixels( 0, 0, Screen.Width, Screen.Height, GL_RGBA, GL_UNSIGNED_BYTE, pbuf);
   bmp := TBitmap.Create;
   bmp.PixelFormat := pf32bit;
   bmp.Width := Screen.Width;
   bmp.Height := Screen.height;
   for y := 0 to (Screen.Height -1) do
   begin
      p1 := bmp.ScanLine[y];
      p2 := pointer( integer(pbuf)+ (y * bmp.Width * 4));
      CopyMemory( p1, p2, bmp.Width * 4);
   end;
   bmp.SaveToFile(salvar);
   bmp.Free;
   FreeMem( pbuf);
end;

Open in new window

Avatar of Júlio

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;

Open in new window

Avatar of Sinisa Vuk
I try your code and with little modification work for me:

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;

Open in new window


another versions are described in old EE quesitons:
http://www.experts-exchange.com/Programming/Languages/Pascal/Delphi/Q_26614393.html
http://www.experts-exchange.com/Programming/Languages/Pascal/Delphi/Q_25147197.html

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;

Open in new window

Avatar of Júlio

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(MyDC, [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
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:
hWin := 0;
MyDC := GetDc(hWin);
if MyDC>0 then
begin
  MyRC := CreateRenderingContext(MyDC, [opDoubleBuffered], 32, 24, 0, 0, 0, 0);
  ActivateRenderingContext(MyDC, MyRC);
...  

Open in new window

Avatar of Júlio

ASKER

With "0" don't work too.
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;

Open in new window

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...
Avatar of Júlio

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;
Maybe you need right combination - couse function ChoosePixelFormat didn't find compatible format:

MyRC := CreateRenderingContext(MyDC, [opDoubleBuffered], 24, 16, 0, 0, 0, 0);

or

MyRC := CreateRenderingContext(MyDC, [opDoubleBuffered], 24, 0, 0, 0, 0, 0);

Open in new window


your example for saving in tga works?
Avatar of Júlio

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."

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.

Open in new window

Avatar of Júlio

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. =)
Avatar of Júlio

ASKER

I fix it, but screenshot is 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.

Open in new window


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.
Avatar of Júlio

ASKER

Maybe the problem of black screenshot is here:

     
  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;

Open in new window


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)
Avatar of Júlio

ASKER

glReadBuffer(GL_BACK) screenshot is all black too =(.

I don't know what to do.
Avatar of Júlio

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?

User generated image
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/library/windows/desktop/ms633500%28v=vs.85%29.aspx

My suggestion is to use EnumWindows function which will go to all windows not depending of parent/child relationship.
http://www.swissdelphicenter.ch/torry/showcode.php?id=410

Another thought is to use "third part" tools:
http://www.frontiernet.net/~w2m/apprehend.html
http://taksi.sourceforge.net/
Avatar of Júlio

ASKER

This is my code:

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;

Open in new window


EnumWindows(@AllWindows, LParam(ListBox1.Items));

Open in new window


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;

Open in new window


EnumChildWindows(FoundWindow, @EnumChildProc, Integer(ListBox2));

Open in new window



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;

Open in new window


Taksi don't work too, because of the child.
Avatar of Júlio

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:

 GetWindowRect(hWin, WindRect);
   iWidth := WindRect.Width;
   iHeight := WindRect.Height;

Open in new window


All sceenshot is black =(

I wa thinking about sruface, and if the game is in a different surface, how to find it?
Avatar of ☠ MASQ ☠
☠ MASQ ☠

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 !!>
Avatar of Júlio

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.
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.
Avatar of Júlio

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;

Open in new window

What is the StretchBlt on line 26 for?
Avatar of Júlio

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?
Avatar of Júlio

ASKER

Don't work to 3D Application.

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;

Open in new window


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;

Open in new window

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.
Avatar of Júlio

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
Avatar of Júlio

ASKER

Like this?

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;

Open in new window


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.

Open in new window


I can inject, but my dll don't work. =(
Avatar of Júlio

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
Avatar of Sinisa Vuk
Sinisa Vuk
Flag of Croatia image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
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
Avatar of Júlio

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.
Avatar of Júlio

ASKER

Not the finnal soluction, but he deserv the credits.