Save image to disk from clipboard using VBA

Hi All,

I've got a image saved to the clipboard by emulating PRINTSCREEN using the below code. Hopefully very easy: how to I get from there, to saving the data to file as an image?

Many thanks!

K.

Option Compare Database
Option Explicit

Type RECT_Type

   left As Long
   top As Long
   right As Long
   bottom As Long

End Type

'The following declare statements are case sensitive.

Declare Function GetActiveWindow Lib "User32" () As Long
Declare Function GetDesktopWindow Lib "User32" () As Long
Declare Sub GetWindowRect Lib "User32" (ByVal hwnd As Long, _
                                    lpRect As RECT_Type)
Declare Function GetDC Lib "User32" (ByVal hwnd As Long) As Long
Declare Function CreateCompatibleDC Lib "Gdi32" (ByVal hdc As Long) _
                                    As Long
Declare Function CreateCompatibleBitmap Lib "Gdi32" (ByVal hdc _
                                    As Long, ByVal nWidth As Long, _
                                    ByVal nHeight As Long) As Long
Declare Function SelectObject Lib "Gdi32" (ByVal hdc As Long, _
                                    ByVal hObject As Long) As Long
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
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, _
                                    ByVal hMem As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function ReleaseDC Lib "User32" (ByVal hwnd As Long, _
                                    ByVal hdc As Long) As Long
Declare Function DeleteDC Lib "Gdi32" (ByVal hdc As Long) As Long

Global Const SRCCOPY = &HCC0020
Global Const CF_BITMAP = 2





Function ScreenDump()
   Dim AccessHwnd As Long, DeskHwnd As Long
   Dim hdc As Long
   Dim hdcMem As Long
   Dim rect As RECT_Type
   Dim junk As Long
   Dim fwidth As Long, fheight As Long
   Dim hBitmap As Long

   DoCmd.Hourglass True

   '---------------------------------------------------
   ' Get window handle to Windows and Microsoft Access
   '---------------------------------------------------
   DeskHwnd = GetDesktopWindow()
   AccessHwnd = GetActiveWindow()

   '---------------------------------------------------
   ' Get screen coordinates of Microsoft Access
   '---------------------------------------------------
   Call GetWindowRect(AccessHwnd, rect)
   fwidth = rect.right - rect.left
   fheight = rect.bottom - rect.top

   '---------------------------------------------------
   ' Get the device context of Desktop and allocate memory
   '---------------------------------------------------
   hdc = GetDC(DeskHwnd)
   hdcMem = CreateCompatibleDC(hdc)
   hBitmap = CreateCompatibleBitmap(hdc, fwidth, fheight)

   If hBitmap <> 0 Then
      junk = SelectObject(hdcMem, hBitmap)

      '---------------------------------------------
      ' Copy the Desktop bitmap to memory location
      ' based on Microsoft Access coordinates.
      '---------------------------------------------
      junk = BitBlt(hdcMem, 0, 0, fwidth, fheight, hdc, rect.left, _
                    rect.top, SRCCOPY)

      '---------------------------------------------
      ' Set up the Clipboard and copy bitmap
      '---------------------------------------------
      junk = OpenClipboard(DeskHwnd)
      junk = EmptyClipboard()
      junk = SetClipboardData(CF_BITMAP, hBitmap)
      junk = CloseClipboard()
   End If

   '---------------------------------------------
   ' Clean up handles
   '---------------------------------------------
   junk = DeleteDC(hdcMem)
   junk = ReleaseDC(DeskHwnd, hdc)

   DoCmd.Hourglass False
   Stop
   'image is now in clipboard
   'save to disk

End Function

Open in new window

katerina-pAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Jeffrey CoachmanMIS LiasonCommented:
Not sure if applicable, ...but I use one of the many "screen capture" utilities.
Most of them can be set up to automatically save a screenshot to a file automatically...
You can set the file type, and the default name can set t be be sequential:
screen1.bmp, screen2.bmp, ...etc

Many other useful options as well...

JeffCoachman
0
katerina-pAuthor Commented:
Hi Jeff,

Yes essentially I want a image of the current form/user screen saved and sent to me.

K.
0
Jeffrey CoachmanMIS LiasonCommented:
Again, I like to keep things simple.

You can create/open an email in Access
Then just have the users paste in the image...

But you can wait for another expert to answer your question directly...
;-)

Jeff
0
The Ultimate Tool Kit for Technolgy Solution Provi

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy for valuable how-to assets including sample agreements, checklists, flowcharts, and more!

IrogSintaCommented:
The way I handled this was to create an exe in VB6 that I can call from Access using the Shell  method.  If you have VB6 or Visual Studio, you can create a project with a single module with the following code:
Public Sub Main()
    Dim objPic As StdPicture
    Dim strCommandLine As String
    
    strCommandLine = Command
    If Clipboard.GetFormat(vbCFBitmap) Then
        Set objPic = Clipboard.GetData(vbCFBitmap)
        SavePicture objPic, strCommandLine
    End If
    
End Sub

Open in new window

From there I create an executable called ClipboardPaste.exe which I then incorporate in Access like so

Dim fileName As String
    Dim retval        

    fileName = "C:\yourPathToImageFolder\NameOfFile.jpg"
    retval = Shell("c:\yourPathToExe\ClipboardPaste.exe " & fileName, 0)

Open in new window


Ron
0
Vadim RappCommented:
This solution published at stackoverflow will work:

Export pictures from excel file into jpg using VBA

When I tried it in Access, it successfully saved relatively small images, but larger ones resulted in "out of memory", so may need some tweaking.

As an alternative, you can write COM dll in VB6 using native statement SavePicture, or in Visual Studio.Net using article "How to save a graphic from the Clipboard to a file by using Visual Basic .NET or Visual Basic 2005"
0
katerina-pAuthor Commented:
larger ones resulted in "out of memory", so may need some tweaking.

Thanks - yes, I'd come across this code before. I always get the memory issue; do you have any idea how to 'tweak'?
0
katerina-pAuthor Commented:
Is there really no way to access the image on the clipboard from VBA? I know you can access text:

Dim MyData As DataObject
   Set MyData = New DataObject
   Dim sClipText As String
   On Error GoTo NotText

   ' Get data from the clipboard.
   MyData.GetFromClipboard

   ' Assign clipboard contents to string variable sClipText.
   sClipText = MyData.GetText(1)
   MsgBox "Data on clipboard is: " & sClipText

Open in new window




After running the code in my OP, I can simply go into Paint and Ctrl-V and the screen shot is there.
0
Vadim RappCommented:
http://www.access-programmers.co.uk/forums/showthread.php?t=192171 seems to have resolved "out of memory". But I would rather use my own suggestion #3, the code is tiny, and it can create jpeg, while OleCreatePictureIndirect , as I understand, only can create .bmp.
0
Vadim RappCommented:
> Is there really no way to access the image on the clipboard from VBA?

you sure can do whatever you want with win32 functions.

> Dim MyData As DataObject

if you are using managed object, then again the easiest is probably to use the code from MSKB article, you don't even need external dll then.
0
katerina-pAuthor Commented:
Thank you Ron; unfortunately I don't have VB6 or Visual Studio so I can't create that exe... :(
0
IrogSintaCommented:
The Express versions of Visual Studio are free.
You can download the Visual Basic 2010 Express version here:
http://www.microsoft.com/visualstudio/eng/downloads#d-2010-express
0
katerina-pAuthor Commented:
Have got this working consistently for me - now just need to convert from a .bmp!

Option Compare Database
Option Explicit

Private Const vbPicTypeBitmap = 1

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

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

    Private Declare Function OleCreatePictureIndirect Lib _
   "olepro32.dll" _
   (PicDesc As PictDesc, RefIID As IID, _
    ByVal fPictureOwnsHandle As Long, _
    IPic As IPicture) As Long


'''Windows API Function Declarations

'Does the clipboard contain a bitmap/metafile?
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long

'Open the clipboard to read
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long

'Get a pointer to the bitmap/metafile
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long

'Close the clipboard
Private Declare Function CloseClipboard Lib "user32" () As Long

'Create our own copy of the metafile, so it doesn't get wiped out bysubsequent clipboard updates.
Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long

'Create our own copy of the bitmap, so it doesn't get wiped out bysubsequent clipboard updates.
Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long

'The API format types we're interested in
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const CF_ENHMETAFILE = 14
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
' Addded by SL Apr/2000
Const xlPicture = CF_BITMAP
Const xlBitmap = CF_BITMAP


Private Declare Function apiDeleteObject Lib "gdi32" _
          Alias "DeleteObject" (ByVal hObject As Long) As Long
          
          
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal _
  bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Private Const KEYEVENTF_KEYUP = &H2
Private Const VK_SNAPSHOT = &H2C
Private Const VK_MENU = &H12

Public Sub ScreenGrabToBMP()
Const sDir As String = strTempDir
Const sFilename As String = "screen.bmp"


Dim lngRet As Long
Dim lngBytes As Long
Dim hPix As IPicture
Dim hBitmap As Long



'If bFullScreen Then
'  PrintScreen
'Else
  AltPrintScreen
'End If

hBitmap = GetClipBoard
Set hPix = BitmapToPicture(hBitmap)
SavePicture hPix, strTempDir & sFilename
apiDeleteObject (hBitmap)


Set hPix = Nothing
End Sub




Sub PrintScreen()
    keybd_event VK_SNAPSHOT, 1, 0, 0
End Sub
Sub AltPrintScreen()
    keybd_event VK_MENU, 0, 0, 0
    keybd_event VK_SNAPSHOT, 0, 0, 0
    keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0
    keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0
End Sub



        '*******************************************
        'DEVELOPED AND TESTED UNDER MICROSOFT ACCESS 97 VBA ONLY
        '
        'Copyright: Lebans Holdings 1999 Ltd.
        '           May not be resold in whole or part. Please feel
        '           free to use any/all of this code within your
        '           own application without cost or obligation.
        '           Please include the one line Copyright notice
        '           if you use this function in your own code.
        '
        'Name:      BitmapToPicture &
        '           GetClipBoard
        '
        'Purpose:   Provides a method to save the contents of a
        '           Bound or Unbound OLE Control to a Disk file.
        '           This version only handles BITMAP files.
        '           '
        'Author:    Stephen Lebans
        'Email:     Ste...@lebans.com
        'Web Site:  www.lebans.com
        'Date:      Apr 10, 2000, 05:31:18 AM
        '
        'Called by: Any
        '
        'Inputs:    Needs a Handle to a Bitmap.
        '           This must be a 24 bit bitmap for this release.
        '
        'Credits:
        'As noted directly in Source :-)
        '
        'BUGS:
        'To keep it simple this version only works with Bitmap files of16 or 24 bits.
        'I'll go back and add the
        'code to allow any depth bitmaps and add support for
        'metafiles as well.
        'No serious bugs notices at this point in time.
        'Please report any bugs to my email address.
        '
        'What's Missing:
        '
        '
        'HOW TO USE:
        '
        '*******************************************


    Public Function BitmapToPicture(ByVal hBmp As Long, _
    Optional ByVal hPal As Long = 0&) _
    As IPicture    '

    ' The following code is adapted from
    ' Bruce McKinney's "Hardcore Visual Basic"
    ' And Code samples from:
    ' http://www.mvps.org/vbnet/code/bitmap/printscreenole.htmv
    ' and examples posted on MSDN

    ' The handle to the Bitmap created by CreateDibSection
    ' cannot be passed directly as the PICTDESC.Bitmap element
    ' that get's passed to OleCreatePictureIndirect.
    ' We need to create a regular bitmap from our CreateDibSection
    'Dim hBmptemp As Long, hBmpOrig As Long
    'Dim hDCtemp As Long

    'Fill picture description
    Dim lngRet As Long
    Dim IPic As IPicture, picdes As PictDesc, iidIPicture As IID

    'hDCtemp = apiCreateCompatibleDC(0)
    'hBmptemp = apiCreateCompatibleBitmap _
    '(mhDCImage, lpBmih.bmiHeader.biWidth, _
    'lpBmih.bmiHeader.biHeight)

    'hBmpOrig = apiSelectObject(hDCtemp, hBmptemp)

   '  lngRet = apiBitBlt(hDCtemp, 0&, 0&, lpBmih.bmiHeader.biWidth, _
    '        lpBmih.bmiHeader.biHeight, mhDCImage, 0, 0, SRCCOPY)

    'hBmptemp = apiSelectObject(hDCtemp, hBmpOrig)
    'Call apiDeleteDC(hDCtemp)


    picdes.Size = Len(picdes)
    picdes.Type = vbPicTypeBitmap
    picdes.hBmp = hBmp

    ' No palette info here
    ' Everything is 24bit for now

    picdes.hPal = hPal
    ' ' Fill in magic IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
    iidIPicture.Data1 = &H7BF80980
    iidIPicture.Data2 = &HBF32
    iidIPicture.Data3 = &H101A
    iidIPicture.Data4(0) = &H8B
    iidIPicture.Data4(1) = &HBB
    iidIPicture.Data4(2) = &H0
    iidIPicture.Data4(3) = &HAA
    iidIPicture.Data4(4) = &H0
    iidIPicture.Data4(5) = &H30
    iidIPicture.Data4(6) = &HC
    iidIPicture.Data4(7) = &HAB
    '' Create picture from bitmap handle
    lngRet = OleCreatePictureIndirect(picdes, iidIPicture, True, IPic)
    '' Result will be valid Picture or Nothing-either way set it
    Set BitmapToPicture = IPic
    End Function


Function GetClipBoard() As Long
' Adapted from original Source Code by:
'* MODULE NAME:     Paste Picture
'* AUTHOR & DATE:   STEPHEN BULLEN, Business Modelling Solutions Ltd.
'*                  15 November 1998
'*
'* CONTACT:         Ste...@BMSLtd.co.uk
'* WEB SITE:        http://www.BMSLtd.co.uk

' Handles for graphic Objects
Dim hClipBoard As Long
Dim hBitmap As Long
Dim hBitmap2 As Long

'Check if the clipboard contains the required format
'hPicAvail = IsClipboardFormatAvailable(lPicType)

 ' Open the ClipBoard
 hClipBoard = OpenClipboard(0&)

 If hClipBoard <> 0 Then
    ' Get a handle to the Bitmap
    hBitmap = GetClipboardData(CF_BITMAP)

    If hBitmap = 0 Then GoTo exit_error
    ' Create our own copy of the image on the clipboard, in theappropriate format.
    'If lPicType = CF_BITMAP Then
        hBitmap2 = CopyImage(hBitmap, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
     '   Else
      '  hBitmap2 = CopyEnhMetaFile(hBitmap, vbNullString)
       ' End If

        'Release the clipboard to other programs
        hClipBoard = CloseClipboard

 GetClipBoard = hBitmap2
 Exit Function

 End If


exit_error:
' Return False
GetClipBoard = -1
End Function

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Vadim RappCommented:
0
katerina-pAuthor Commented:
Post contains the working code.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Access

From novice to tech pro — start learning today.