Capture part of a form as a .jpg file 4

[DevonTaig]

Is there a way through code to perform a screen capture on just a part of a Visual Basic form? For example, I might want to programatically capture a listbox...or the upper-right corner of a form.

Thanks

 

[wekkew]

Hi

you could use SendKeys to simulate the PrintScreen key and then, when the picture is on the clipboard copy/save from there. Not sure about how you'd crop just a part though cos depending on resolution you wouldn't know the area would you?

Kate

 

[Custom24]

Did anyone figure this out? The only thing I know is the SavePicture function, which needs a picture object. But the picture object of a form does not include the controls on it. I'm looking for an API call, but have not found one yet....

 

[strongm]

I've got a partial solution that i just need to play around with a little more. I'll be back...

 

[strongm]

OK, the following is basically a screen grabber written in VB. Given a RECT containing the top, bottom, left and right coordinates of a given area of screen in pixels it returns a a snapshot of the area as a Picture object. This can then be used like any other Picture object (eg assign it to a picturebox, or do a SavePicture). What you can't do is save it as a JPEG, as VB doesn't know about JPEGs and neither do any of the included controls. However the following link contains a freebie JPEG-writing DLL for use in VB:

http://dilib.hypermart.net/dl/dijpg.htm

And here's the screen grabber code. Drop it into a module:
[tt]
Option Explicit

' Required GDI API declarations
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

' Needed for conversion of bitmap handle into StdPicture
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PictDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

' Device context functions
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long

' Required if we want to convert application window coordinates into scree coordinates
Public Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long

' Type of bitblt
Public Const SRCCOPY = &HCC0020

' various required types
Public Type POINTAPI
x As Long
y As Long
End Type

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type

Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Type PictDesc
cbSizeofStruct As Long
picType As Long
hImage As Long
xExt As Long
yExt As Long
End Type

Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type

Public Function BitmapToPicture(ByVal hBmp As Long, Optional ByVal hPal As Long = 0) As IPicture
' Fill picture description
Dim IPic As Picture
Dim picdes As PictDesc
Dim iidIPicture As GUID

With picdes
.cbSizeofStruct = Len(picdes)
.picType = vbPicTypeBitmap
.hImage = hBmp
End With

With iidIPicture
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With

' Create picture from bitmap handle
OleCreatePictureIndirect picdes, iidIPicture, True, IPic
' Result will be valid Picture or Nothing — either way set it
Set BitmapToPicture = IPic
End Function

Public Function GrabScreenAreaAsPicture(scrRect As RECT) As StdPicture
Dim DeskDC As Long
Dim hdcWorkDC As Long
Dim hbmpWork As Long
Dim hbmpOriginal As Long

DeskDC = GetDC(GetDesktopWindow())
hdcWorkDC = CreateCompatibleDC(DeskDC)
hbmpWork = CreateCompatibleBitmap(DeskDC, scrRect.Right - scrRect.Left, scrRect.Bottom - scrRect.Top)

' Select in our compatible bitmap
hbmpOriginal = SelectObject(hdcWorkDC, hbmpWork)

' Snapshot screen area into compatible bitmap in our compatible DC
BitBlt hdcWorkDC, 0, 0, scrRect.Right - scrRect.Left, scrRect.Bottom - scrRect.Top, DeskDC, scrRect.Left, scrRect.Top, SRCCOPY

' Unselect our compatible bitmap so that BitMapToPicture can use it
hbmpWork = SelectObject(hdcWorkDC, hbmpOriginal)
' Do the magic
Set GrabScreenAreaAsPicture = BitmapToPicture(hbmpWork)

' Clean up
DeleteDC hdcWorkDC
ReleaseDC GetDesktopWindow, DeskDC
End Function
[/tt]
To test the example add a form to your project with two command buttons and a picturebox. Drop the following code into the form:
[tt]
Option Explicit

Private Sub Command1_Click()
'
Dim ScreenRect As RECT

' GrabScreenAreaAsPictures works in pixels
ScreenRect.Top = 64
ScreenRect.Bottom = 500
ScreenRect.Left = 100
ScreenRect.Right = 500

Picture1.Picture = GrabScreenAreaAsPicture(ScreenRect)

End Sub


Private Sub Command2_Click()
' Just an example of grabbing an area from a form
' Note that example only considers client area; borders and title bars won't get grabbed
Dim FormRect As RECT
Dim WindowPoint As POINTAPI

WindowPoint.x = Form1.Left
WindowPoint.y = Form1.Top

' ClientToScreen works in twips, but GrabScreenAreaAsPicture works in pixels
' so we do a bunch of work to convert
ClientToScreen Form1.hwnd, WindowPoint
FormRect.Left = WindowPoint.x / Screen.TwipsPerPixelX
FormRect.Top = WindowPoint.y / Screen.TwipsPerPixelY

WindowPoint.x = Form1.Left + 500 * Screen.TwipsPerPixelX
WindowPoint.y = Form1.Top + 500 * Screen.TwipsPerPixelY

ClientToScreen Form1.hwnd, WindowPoint


FormRect.Right = WindowPoint.x / Screen.TwipsPerPixelX
FormRect.Bottom = WindowPoint.y / Screen.TwipsPerPixelY

Picture1.Picture = GrabScreenAreaAsPicture(FormRect)
End Sub

 

[petermeachem]

Strongm, you are a real hero. Thanks. I'm glad you don't live around here, you could probably do my days work by about 10am. Cheers. Peter Meachem
peter@accuflight.com

 

[strongm]

Heh! I suspect I may be closer than you think, though...

 

[petermeachem]

Where are you? Please not England! Peter Meachem
peter@accuflight.com

 

[strongm]

Oh yes, definitely England. London, in fact.

 

[petermeachem]

Um, a bit close. You are much too smart you know. Thanks for all your posts Peter Meachem
peter@accuflight.com