Link to home
Start Free TrialLog in
Avatar of winexec
winexec

asked on

Screen capture

Hello.

Here is an example of screen capture:

procedure GetDesktop;
var
   aDC,MemDC:HDC;
   hBmap,OldBitmap:HBitmap;
   bmp:TBitmap;
begin
   aDC:=GetDC(GetDesktopWindow);
   MemDC:=CreateCompatibleDC(aDC);
   hBmap:=CreateCompatibleBitmap(aDC,1024,768);
   OldBitmap:=SelectObject(MemDC,hBmap);
   BitBlt(MemDC,0,0,1024,768,ADC,0,0,SRCCOPY);
   SelectObject(MemDC,OldBitmap);
   bmp:=TBitmap.Create;
   bmp.Handle:=hbmap;
   bmp.SaveToFile('c:\screen.bmp');
   bmp.Free;
   DeleteDC(MemDC);
   ReleaseDC(GetDesktopWindow,aDC);
end;

The code is OK, the only problem being that I don't want to use the Graphix unit. The TBitmap wich I used belongs to Graphix and all I need is to save the screenshot without using that unit.

Anyone can help me?

Thanks,
Winexec
Avatar of Robn
Robn

you could copy the code out of TBitmap.WriteStream.

Here it is...
This code uses the TCanvas but that is easy enough to remove.

procedure TBitmap.WriteStream(Stream: TStream; WriteSize: Boolean);
const
  PalSize: array [Boolean] of Byte = (sizeof(TRGBQuad), sizeof(TRGBTriple));
var
  Size, ColorCount: DWORD;
  HeaderSize: DWORD;
  BMF: TBitmapFileHeader;
  Save: THandle;
  BC: TBitmapCoreHeader;
  Colors: array [Byte] of TRGBQuad;
begin
  FillChar(BMF, sizeof(BMF), 0);
  BMF.bfType := $4D42;
  if FImage.FSaveStream <> nil then
  begin
    Size := FImage.FSaveStream.Size;
    if WriteSize then
      Stream.WriteBuffer(Size, sizeof(Size));
    Stream.Write(FImage.FSaveStream.Memory^, FImage.FSaveStream.Size);
    Exit;
  end;
  DIBNeeded;
  with FImage do
  begin
    Size := 0;
    if FDIBHandle <> 0 then
    begin
      InternalGetDIBSizes(FDIBHandle, HeaderSize, Size, FDIB.dsbmih.biClrUsed);
      if FOS2Format then
      begin // OS2 format cannot have partial palette
        HeaderSize := sizeof(BC);
        if FDIB.dsbmih.biBitCount <= 8 then
          Inc(HeaderSize, sizeof(TRGBTriple) * (1 shl FDIB.dsbmih.biBitCount));
      end;
      Inc(Size, HeaderSize + sizeof(BMF));

      FillChar(BMF, sizeof(BMF), 0);
      BMF.bfType := $4D42;

      Canvas.RequiredState([csHandleValid]);
      Save := GDICheck(SelectObject(FCanvas.FHandle, FDIBHandle));
      ColorCount := GetDIBColorTable(FCanvas.FHandle, 0, 256, Colors);
      SelectObject(FCanvas.FHandle, Save);
      // GetDIBColorTable always reports the full palette; trim it back for partial palettes
      if (0 < FDIB.dsbmih.biClrUsed) and (FDIB.dsbmih.biClrUsed < ColorCount) then
        ColorCount := FDIB.dsbmih.biClrUsed;
      if (not FOS2Format) and (ColorCount = 0) and (FPalette <> 0) and not FHalftone then
      begin
        ColorCount := PaletteToDIBColorTable(FPalette, Colors);
        if FDIB.dsbmih.biBitCount > 8 then
        begin  // optional color palette for hicolor images (non OS2)
          Inc(Size, ColorCount * sizeof(TRGBQuad));
          Inc(HeaderSize, ColorCount * sizeof(TRGBQuad));
        end;
      end;

      BMF.bfSize := Size;
      BMF.bfOffBits := sizeof(BMF) + HeaderSize;
    end;

    if WriteSize then Stream.WriteBuffer(Size, SizeOf(Size));

    if Size <> 0 then
    begin
      FixupBitFields(FDIB);
      if (ColorCount <> 0) then
      begin
        if (FDIB.dsbmih.biClrUsed = 0) or (FDIB.dsbmih.biClrUsed <> ColorCount) then
          FDIB.dsbmih.biClrUsed := ColorCount;
        if FOS2Format then RGBQuadToTriple(Colors, Integer(ColorCount));
      end;
      if FOS2Format then
      begin
        with BC, FDIB.dsbmih do
        begin
          bcSize := sizeof(BC);
          bcWidth := biWidth;
          bcHeight := biHeight;
          bcPlanes := 1;
          bcBitCount := biBitCount;
        end;
        Stream.WriteBuffer(BMF, sizeof(BMF));
        Stream.WriteBuffer(BC, sizeof(BC));
      end
      else
      begin
        Stream.WriteBuffer(BMF, Sizeof(BMF));
        Stream.WriteBuffer(FDIB.dsbmih, Sizeof(FDIB.dsbmih));
        if (FDIB.dsbmih.biBitCount > 8) and
          ((FDIB.dsbmih.biCompression and BI_BITFIELDS) <> 0) then
          Stream.WriteBuffer(FDIB.dsBitfields, 12);
      end;
      Stream.WriteBuffer(Colors, ColorCount * PalSize[FOS2Format]);
      Stream.WriteBuffer(FDIB.dsbm.bmBits^, FDIB.dsbmih.biSizeImage);
    end;
  end;
end;
Avatar of winexec

ASKER

Thx for response Robn, but doesn't help me.

Sorry cause I didn't specify more clear my problem: I want to use only Windows unit, and not Graphics, Classes (which is used in your sample) etc.
You can use CreateFile and GetMem instead of a stream. Manage canvas handles, Palettes, brushes, etc yourself (without using the Delphi units). I was just showing the algorithm used to save a bitmap image. It would come in handy when you re-write it to use only API method calls.
It would be a lot of work though. If I was doing it, I would write a DLL that would take in a bitmap handle and filename and save that to file.
Avatar of winexec

ASKER

Yes, thx, I know I can use GetMem, CreateFile etc. in the place of the Classes stream, but I'm not so advanced to do it. Also, I have to get rid of Canvas... Seems pretty hard for me...

Hm, I didn't think it's so hard :( Can you Robn gimme an example (if you had one)? Or anybody else?

I increased the points to 300, but I need a sample.

Thx.
OK, let me try ;-)

procedure TForm1.Button1Click(Sender: TObject);
var
  hdcScreen,hdcCompatible: hdc;
  hbmScreen:Hbitmap;
begin
  hdcScreen := CreateDC('DISPLAY', nil, nil, nil);
  hdcCompatible:=CreateCompatibleDC(hdcScreen);
  hbmScreen:= CreateCompatibleBitmap(hdcScreen,
     GetDeviceCaps(hdcScreen, HORZRES),
     GetDeviceCaps(hdcScreen, VERTRES));
  SelectObject(hdcCompatible, hbmScreen);
  BitBlt(hdcCompatible,0,0,GetDeviceCaps(hdcScreen, HORZRES),
      GetDeviceCaps(hdcScreen, VERTRES),hdcScreen,
      0,0,SRCCOPY);

  // Additional code, uses Clipbrd unit
  OpenClipboard(Handle);
  EmptyClipboard;
  SetClipboardData(CF_BITMAP,hbmScreen);
  CloseClipboard;

  DeleteObject(hbmScreen);
  DeleteDC(hdcCompatible);
  DeleteDC(hdcScreen);
end;

Screen is stored in hbmScreen variable of HBitmap.
This code uses Windows unit only, as wanted.
ASKER CERTIFIED SOLUTION
Avatar of Member_2_248744
Member_2_248744
Flag of United States of America 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
OK, I tried to hard to simplify this, and gave a formular that less code, but is not as it needs to be, you should change the line

biSizeImage := (biWidth * (BitC div 8)) * biHeight;

to these Two lines -

  biSizeImage := ((biWidth * biBitCount) + 31) and not 31;
  biSizeImage := Integer(biSizeImage div 8) * biHeight;


this will make sure each scan line (width) is DWORD aligned
Avatar of winexec

ASKER

Thx a lot Slick812, that's what I wanted :)

One more thing I need to know (out of that question, if you could help): what could be done to retrieve a black&white screenshot ?
????

I am not sure what you are asking about the black&white screenshot. . . There's more to a Graphic than just calling it black&white

so I do not have any Idea what you may mean,
I true black&white is in 1 bit color depth. . . however, that is never worth doing for a Full color monitor

You probaly mean "GreyScale". . . bot there are 4 bit, 8 bit and Full color greyscale. . .

and that's something for a whole NEW question, since it ain't so easy