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

ċ
CapturaPantallayGuarda.rar
Ver Descargar
Descargue el Ejemplo  174 kb v. 1 6/7/2011 16:57 Jefferson Jimenez
Comments