experchange > access.* > access.modulesdaovba

Matt Kisasonak (10-22-04, 07:39 PM)
Hi, Y'all! Hay, I'm trying to create bitmap images from
data in the windows clipboard by using VBA from MS
Access. It was working when I had it in VB because I
could just use the SAVEPICTURE command but VBA doesn't
have this. The data that was coppied to the clipboard is
a drawing view from a Solid Edge drawing. Not that it
matters. If I paste the clipboard to MS Paint it pastes
it as an image. I want to paste it or save it to a .bmp
file from the clipboard or from VBA. How do I do this
using VBA in Access?
Stephen Lebans (10-27-04, 01:10 AM)
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: Stephen
'Web Site:
'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:
'
' 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: Stephen
'* WEB SITE:

' 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
stevebme12 (10-28-19, 06:52 PM)
Well, I'm not sure if anyone is still watching this or not... it's 15 years later, but I'm interested in doing something like this for Excel's clipboard.

I'm also interested in saving it as a png file.

1- do I need to modify anything to achieve this?
2- the functions I'm used to are to be posted in a cell, akin to
=personal.xlsb!functionname(....)"
Granted, my use of excel professionally began in 2006, so your discussion is earlier still.
Do I need to post it like that?
My goal is to ultimately place this in an iterative macro to copy/save over 6500 clipboard images.
Similar Threads