[vba] Window API 를 이용한 Clipboard 의 Bitmap 저장하기 > vb6.0/vba

본문 바로가기

vb6.0/vba

[vba] [vba] Window API 를 이용한 Clipboard 의 Bitmap 저장하기

회원사진
하나를하더라도최선을
2019-09-29 19:31 6,584 0

본문



 
Option Explicit
 
 
'Here's the code behind the code module
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(7As 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
 
 
'''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 StringAs 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:     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:
    '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, 00, 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
 

댓글목록0

등록된 댓글이 없습니다.
게시판 전체검색