Option Explicit

 

 

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

 

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

 

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

 

 

 

Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long

 

Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long

 

Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long

 

Private Declare Function CloseClipboard Lib "user32" () As Long

 

Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long

 

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

 

Const CF_BITMAP = 2

Const CF_PALETTE = 9

Const CF_ENHMETAFILE = 14

Const IMAGE_BITMAP = 0

Const LR_COPYRETURNORG = &H4

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:     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 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:         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 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

 

 

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

    

    hBitmap = GetClipBoard

    Set hPix = BitmapToPicture(hBitmap)

    SavePicture hPix, "C:\ole.bmp"

    apiDeleteObject (hBitmap)

    

    

    Set hPix = Nothing

End Sub