Captura la Pantalla y Guardarla en formato BMP (Codigo VBA Access)
Option Compare Database
'***************************************************************
'& &*
'& &*
'& &*
'& &*
'& Jefferson Jimenez (JJJT) &*
'& Cabimas - Venezuela &*
'& Julio - 2011 &*
'& &*
'& &*
'& &*
'& &*
'& &*
'***************************************************************
'Codigo extraido de un foro de Microsoft Access http://www.access-programmers.co.uk/forums/showthread.php?t=192171
'la Estructura del Objeto PicBmp
Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
'la Estructura del Objeto Guid
Private Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
'Las Api's del clipboard (Access Nativo no posee Clipboard)
Private Declare Function OpenClipboard Lib "user32" (ByVal Hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
'Api para enviar pulsaciones de tecla y capturar la pantalla o ventana
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal _
bScan As Byte, ByVal dwFlags As Long, _
ByVal dwExtraInfo As Long)
'Api Crea un objeto inicializado nueva imagen de acuerdo a una estructura PICTDESC
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
(PicDesc As PicBmp, RefIID As Guid, _
ByVal fPictureOwnsHandle As Long, _
IPic As IPicture) As Long
'Api que verifica un ruta existente
Private Declare Function JJJTExisteFile Lib "shlwapi.dll" Alias "PathFileExistsA" _
(ByVal pszPath As String) As Boolean
'Declaramos la Variables
Private Pic As PicBmp
Private IPic As IPicture
Private IID_IDispatch As Guid
Public TodaPantalla As Boolean
Public Function CapturaClipBoard_Guarda( _
Optional TipoPantalla As Boolean = False)
On Error Resume Next
'Dependiendo de la seleccion copio al Portapapeles
If TipoPantalla Then
Call keybd_event(44, 0, 0&, 0&)
Else
Call keybd_event(44, 1, 0&, 0&)
TipoPantalla = False
End If
'Verifico no este creado el BITMAP y de ser asi lo elimino
If JJJTExisteFile(DondeGuardo_y_Nombre) Then Kill DondeGuardo_y_Nombre
CreaBITMAP
'Intercepto el error de Memoria y repito el codigo
If Err.Number = 7 Then OpenClipboard (0): CreaBITMAP: MsgBox "Creado Exitosamente", vbInformation
End Function
Private Sub CreaBITMAP()
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With Pic
.Size = Len(Pic)
.Type = 1
.hBmp = GetClipboardData(2)
End With
DoEvents
OleCreatePictureIndirect Pic, IID_IDispatch, 1, IPic ' Create the picture object
stdole.SavePicture IPic, DondeGuardo_y_Nombre ' Save the file
EmptyClipboard 'Empty the clipboard
CloseClipboard ' Close the clipboard
End Sub
Function DondeGuardo_y_Nombre()
DondeGuardo_y_Nombre = CurrentProject.Path & "\ImagenBITMAP.bmp"
End Function