Here's the code behind a form containing a CommandButton
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: (e-mail address removed)
'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/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: (e-mail address removed)
'* 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
--
HTH
Stephen Lebans
http://www.lebans.com
Access Code, Tips and Tricks
Please respond only to the newsgroups so everyone can benefit.
