/ Snippet Library - View Code

Visual Basic / Display / Capture

Snippet details

ID: 198

Viewed: 1301

Added: 2002-04-29

Version:

Snippets in this catagory
Show Printable Version

Class that allows the capturing of controls or forms by hWnd properties and saving as a .BMP.

General Details

Snippet uploaded by: snippet

Email : webmaster@snippetlibrary.com

Snippet By: Clint LaFever

Snippet By:	Clint LaFever
Declarations
Highlight All'------------------------------------------------------------ ' Author: Clint LaFever [lafeverc@usa.net] ' Purpose: Allows screen captureing of controls/windows based on hWnd and save to a .BMP. ' Parameters: ' Example: '------------------------------------------------------------ Option Explicit Private Const CCHDEVICENAME = 32 Private Const CCHFORMNAME = 32 Public FileName As String Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type DEVMODE dmDeviceName As String * CCHDEVICENAME dmSpecVersion As Integer dmDriverVersion As Integer dmSize As Integer dmDriverExtra As Integer dmFields As Long dmOrientation As Integer dmPaperSize As Integer dmPaperLength As Integer dmPaperWidth As Integer dmScale As Integer dmCopies As Integer dmDefaultSource As Integer dmPrintQuality As Integer dmColor As Integer dmDuplex As Integer dmYResolution As Integer dmTTOption As Integer dmCollate As Integer dmFormName As String * CCHFORMNAME dmUnusedPadding As Integer dmBitsPerPel As Integer dmPelsWidth As Long dmPelsHeight As Long dmDisplayFlags As Long dmDisplayFrequency As Long End Type Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function EmptyClipboard Lib "user32" () As Long Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long Private Declare Function CloseClipboard Lib "user32" () As Long 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 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 Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As DEVMODE) As Long Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long Private Sub ScrnCap(Lt, Top, Rt, Bot) On Error GoTo ErrorScrnCap Dim rWIDTH As Long, rHEIGHT As Long Dim SourceDC As Long, DestDC As Long, bHANDLE As Long, Wnd As Long Dim dHANDLE As Long, dm As DEVMODE rWIDTH = Rt - Lt rHEIGHT = Bot - Top SourceDC = CreateDC("DISPLAY", 0&, 0&, dm) DestDC = CreateCompatibleDC(SourceDC) bHANDLE = CreateCompatibleBitmap(SourceDC, rWIDTH, rHEIGHT) SelectObject DestDC, bHANDLE BitBlt DestDC, 0, 0, rWIDTH, rHEIGHT, SourceDC, Lt, Top, &HCC0020 Wnd = Screen.ActiveForm.hwnd OpenClipboard Wnd EmptyClipboard SetClipboardData 2, bHANDLE CloseClipboard DeleteDC DestDC ReleaseDC dHANDLE, SourceDC Exit Sub ErrorScrnCap: MsgBox Err & ":Error in ScrnCap(). Error Message:" & Err.Description, vbCritical, "Warning" Exit Sub End Sub '------------------------------------------------------------ ' Author: Clint LaFever [lafeverc@usa.net] ' Purpose: Captures a control/window based on hWnd and save to a .BMP. ' Parameters: hWnd=Control/Window to capture, fNAME=Save .BMP to... ' Example: obj.Capture lvLIST.hWnd,"TEST.BMP" '------------------------------------------------------------ Public Sub Capture(control_hWnd As Long, Optional fNAME As String = "") On Error GoTo ErrorCapture Dim sp As RECT, x As Long If fNAME = "" Then fNAME = Me.FileName Else Me.FileName = fNAME End If If Me.FileName <> "" Then x = GetWindowRect(control_hWnd, sp) ScrnCap sp.Left, sp.Top, sp.Right, sp.Bottom SavePicture Clipboard.GetData, Me.FileName End If Exit Sub ErrorCapture: MsgBox Err & ":Error in Caputre(). Error Message:" & Err.Description, vbCritical, "Warning" Exit Sub End Sub
Code
Highlight Allnone

No Reviews to show