Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, IPic As IPicture) As Long 'Convert the handle into an OLE IPicture interface. Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long 'Declare a UDT to store the bitmap information 'Declare a UDT to store a GUID for the IPicture OLE Interface '* fnOLEError Get the error text for an OLE error code '* CreatePicture Private function to convert a bitmap or metafile handle to an OLE reference '* PastePicture The entry point for the routine '* to paste a picture of whatever is on the clipboard into a standard image control. '* Set Image1.Picture = PastePicture(xlPicture) '* To use it, just copy this module into your project, then you can use: '* The code in this module has been derived from a number of sources '* The code requires a reference to the "OLE Automation" type library '* the picture type - xlBitmap or xlPicture. The PastePicture function takes an optional argument of '* This object can then be assigned to (for example) and Image control '* DESCRIPTION: Creates a standard Picture object from whatever is on the clipboard. '* AUTHOR & DATE: STEPHEN BULLEN, Office Automation Ltd I do not have 64bit installed to test, but I believe it should convert as follows: Stephen's code will not work in 64bit Office as it is. ' hBitmap2 = CopyEnhMetaFile(hBitmap, vbNullString) HBitmap2 = CopyImage(hBitmap, IMAGE_BITMAP, 0, 0, ' Create our own copy of the image on the clipboard, in the 'hPicAvail = IsClipboardFormatAvailable(lPicType) 'Check if the clipboard contains the required format '* AUTHOR & DATE: STEPHEN BULLEN, Business Modelling Solutions Ltd. '' Result will be valid Picture or Nothing-either way set it LngRet = OleCreatePictureIndirect(picdes, iidIPicture, True, IPic) 'hBmptemp = apiSelectObject(hDCtemp, hBmpOrig) ' lngRet = apiBitBlt(hDCtemp, 0&, 0&,, _ 'hBmpOrig = apiSelectObject(hDCtemp, hBmptemp) ' We need to create a regular bitmap from our CreateDibSectionĭim IPic As IPicture, picdes As PictDesc, iidIPicture As IID ' that get's passed to OleCreatePictureIndirect. ' cannot be passed directly as the PICTDESC.Bitmap element ' The handle to the Bitmap created by CreateDibSection ' Bruce McKinney's "Hardcore Visual Basic" Public Function BitmapToPicture(ByVal hBmp As Long, _ 'Please report any bugs to my email address. 'No serious bugs notices at this point in time. 'code to allow any depth bitmaps and add support for 'To keep it simple this version only works with Bitmap files of ' This must be a 24 bit bitmap for this release. ' This version only handles BITMAP files. ' Bound or Unbound OLE Control to a Disk file. 'Purpose: Provides a method to save the contents of a ' if you use this function in your own code. ' Please include the one line Copyright notice ' own application without cost or obligation. ' free to use any/all of this code within your 'DEVELOPED AND TESTED UNDER MICROSOFT ACCESS 97 VBA ONLY 'The API format types we're interested in 'Create our own copy of the bitmap, so it doesn't get wiped out byĭeclare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1Īs Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long 'Create our own copy of the metafile, so it doesn't get wiped out byĭeclare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" Private Declare Function CloseClipboard Lib "user32" () As Long Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal 'Does the clipboard contain a bitmap/metafile? Private Declare Function OleCreatePictureIndirect Lib _ Private Declare Function apiDeleteObject Lib "gdi32" _Īlias "DeleteObject" (ByVal hObject As Long) As Long I have not tested and don't have access to test it with.
0 Comments
Leave a Reply. |
AuthorWrite something about yourself. No need to be fancy, just an overview. ArchivesCategories |