How to create all sorts of screen shots (Views: 27)
Problem/Question/Abstract: How to create all sorts of screen shots Answer: a) Copying the screen content into a form Solve 1: procedure TScrnFrm.GrabScreen; var DeskTopDC: HDc; DeskTopCanvas: TCanvas; DeskTopRect: TRect; begin DeskTopDC := GetWindowDC(GetDeskTopWindow); DeskTopCanvas := TCanvas.Create; DeskTopCanvas.Handle := DeskTopDC; DeskTopRect := Rect(0, 0, Screen.Width, Screen.Height); ScrnForm.Canvas.CopyRect(DeskTopRect, DeskTopCanvas, DeskTopRect); ReleaseDC(GetDeskTopWindow, DeskTopDC); end; Solve 2: { ... } var Image1: TImage; { ... } procedure TSaverForm.CopyScreen; var DeskTopDC: HDC; DeskTopCanvas: TCanvas; DeskTopRect: TRect; begin Image1 := TImage.Create(SaverForm); with Image1 do begin Height := Screen.Height; Width := Screen.Width; end; Image1.Canvas.copymode := cmSrcCopy; DeskTopDC := GetWindowDC(GetDeskTopWindow); DeskTopCanvas := TCanvas.Create; DeskTopCanvas.Handle := DeskTopDC; Image1.Canvas.CopyRect(Image1.Canvas.ClipRect, DeskTopCanvas, DeskTopCanvas.ClipRect); Image2.Picture.Assign(Image1.Picture); {image2 is on the saver form, aligned to client} end; procedure TSaverForm.FormClose(Sender: TObject; var Action: TCloseAction); begin Image1.Free; end; b) Copying the screen content into a TImage Create a form, drop a TImage control to the form, make it a decent size, and drop a button on it. DblClick the button and add the following code. var ScreenDC: HDC; begin ScreenDC := CreateDC('DISPLAY', nil, nil, nil); BitBlt(Image1.Canvas.Handle, 0, 0, Image1.Width, Image1.Height, ScreenDC, 0, 0, SRCCOPY); Image1.Refresh; DeleteDC(ScreenDC); end; That will copy the desktop into the Image Control. Play around with the 0,0 near the ScreenDC to move the TopLeft of the image to want to capture. Move your form around and click the button. c) Copying the screen content into a bitmap procedure ScreenShot(x: integer; y: integer; Width: integer; Height: integer; bm: TBitmap); var dc: HDC; lpPal: PLOGPALETTE; begin {test width and height} if ((Width < 1) or (Height < 1)) then begin exit; end; bm.Width := Width; bm.Height := Height; {get the screen dc} dc := GetDc(0); if (dc = 0) then begin exit; end; {do we have a palette device?} if (GetDeviceCaps(dc, RASTERCAPS) and RC_PALETTE = RC_PALETTE) then begin {allocate memory for a logical palette} GetMem(lpPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY))); {zero it out to be neat} FillChar(lpPal^, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)), #0); {fill in the palette version} lpPal^.palVersion := $300; {grab the system palette entries} lpPal^.palNumEntries := GetSystemPaletteEntries(dc, 0, 256, lpPal^.palPalEntry); if (lpPal^.PalNumEntries <> 0) then begin {create the palette} bm.Palette := CreatePalette(lpPal^); end; FreeMem(lpPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY))); end; {copy from the screen to the bitmap} BitBlt(bm.Canvas.Handle, 0, 0, Width, Height, Dc, x, y, SRCCOPY); {release the screen dc} ReleaseDc(0, dc); end; d) Copying the screen content into a memory bitmap { ... } var ScreenDC: HDC; fBitmap: TBitmap; begin fBitmap := TBitmap.Create; fBitmap.Width := 100; fBitmap.Height := 100; ScreenDC := CreateDC('DISPLAY', nil, nil, nil); BitBlt(FBitmap.Canvas.Handle, 0, 0, FBitmap.Width, FBitmap.Height, ScreenDC, 0, 0, SRCCOPY); { You now have a copy of the screen from (0,0,100,100) in the fBitmap. You now can do what you want to it, merge it with another bitmap, or anything else you want to. } { Clean Up } DeleteDC(ScreenDC); fBitmap.Free end; e) Various screenshot procedures unit Scrncap; interface uses WinTypes, WinProcs, Forms, Classes, Graphics; function CaptureScreenRect(ARect: TRect): TBitmap; function CaptureScreen: TBitmap; function CaptureClientImage(Control: TControl): TBitmap; function CaptureControlImage(Control: TControl): TBitmap; implementation { Use this to capture a rectangle on the screen } function 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; end; end; { Use this to capture the entire screen } function CaptureScreen: TBitmap; begin with Screen do Result := CaptureScreenRect(Rect(0, 0, Width, Height)); end; { Use this to capture just the client area of a form or control...} function CaptureClientImage(Control: TControl): TBitmap; begin with Control, Control.ClientOrigin do Result := CaptureScreenRect(Bounds(X, Y, ClientWidth, ClientHeight)); end; { Use this to capture an entire form or control } function CaptureControlImage(Control: TControl): TBitmap; begin with Control do if Parent = nil then Result := CaptureScreenRect(Bounds(Left, Top, Width, Height)) else with Parent.ClientToScreen(Point(Left, Top)) do Result := CaptureScreenRect(Bounds(X, Y, Width, Height)); end; end. |