Saving Clipboard data as picture

[Tommy]

I found this at this location. I have not tested and don't have access to test it with.

http://groups.google.ca/group/micros...rnum=2&safe=on

Option Compare Database 
Option Explicit 

Private Declare Function apiDeleteObject Lib "gdi32" _ 
          Alias "DeleteObject" (ByVal hObject As Long) As Long 

Private Sub cmdCreateIPicture_Click() 
' ********************* 
' You must set a Reference to: 
' "OLE Automation" 
' for this function to work. 
' Goto the Menu and select 
' Tools->References 
' Scroll down to: 
' Ole Automation 
' and click in the check box to select 
' this reference. 

Dim lngRet As Long 
Dim lngBytes As Long 
Dim hPix As IPicture 
Dim hBitmap As Long 
'Dim hPicBox As StdPicture 

Me.OLEBound19.SetFocus 
'Me.OLEbound19.SizeMode = acOLESizeZoom 
DoCmd.RunCommand acCmdCopy 
hBitmap = GetClipBoard 
Set hPix = BitmapToPicture(hBitmap) 
SavePicture hPix, "C:\ole.bmp" 
apiDeleteObject (hBitmap) 
Me.Image0.Picture = "C:\ole.bmp" 

Set hPix = Nothing 
End Sub 

' Here's the code behind the code module 

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 by 
subsequent 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 by 
subsequent 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 

        '******************************************* 
        '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:     Step...@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 of 
16 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/bitma...screenole.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:         Step...@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 the 
appropriate 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