hambakahle
Programmer
My apologies to the VB guys on the forum since I am doing this on an Access/VBA platform, but it does seem to be primarily an API issue.
I want to be able to pass an image to the clipboard based on the image file path and do so based on a variety of image types. Converting the image file to an OLE stdPicture seemed a feasible first step and I thought about the LoadPicture function. But LoadPicture wont work with tiff images, so I cast about and found graciously posted GDI+ based functions (LoadPicturePlus) billed as being a more versatile method. As an interim test I used the LoadPicturePlus function to load a picture into an ActiveX image control and this worked satisfactorily.
The next step was to pass a stdPicture to the clipboard and I turned up another function I slightly amended to pfCopyStdPicture. However doing this I get a blank rectangle pasted from the clipboard rather than an image. Any thoughts as to what sort of graphics API abuse I am committing?
If I pass a stdPicture to pfCopyStdPicture using LoadPicture (rather than LoadPicturePlus) I do get an image from the clipboard. Not sure if it is relevant, but LoadPicture and LoadPicturePlus result in different values for BitmapInfo.bitcount.
Thanks much. Code is posted below.
Function calls
LoadPicturePlus
stdPicture > Clipboard functions
I want to be able to pass an image to the clipboard based on the image file path and do so based on a variety of image types. Converting the image file to an OLE stdPicture seemed a feasible first step and I thought about the LoadPicture function. But LoadPicture wont work with tiff images, so I cast about and found graciously posted GDI+ based functions (LoadPicturePlus) billed as being a more versatile method. As an interim test I used the LoadPicturePlus function to load a picture into an ActiveX image control and this worked satisfactorily.
The next step was to pass a stdPicture to the clipboard and I turned up another function I slightly amended to pfCopyStdPicture. However doing this I get a blank rectangle pasted from the clipboard rather than an image. Any thoughts as to what sort of graphics API abuse I am committing?
If I pass a stdPicture to pfCopyStdPicture using LoadPicture (rather than LoadPicturePlus) I do get an image from the clipboard. Not sure if it is relevant, but LoadPicture and LoadPicturePlus result in different values for BitmapInfo.bitcount.
Thanks much. Code is posted below.
Function calls
Code:
Private Sub Command5_Click()
Dim stdPic As New stdole.StdPicture
Dim strFilePath As String
Dim blnUseDIB As Boolean
blnUseDIB = True
'strFilePath = "C:\Users\ploceus\All Users\H1.tif" '185547
'strFilePath = "C:\Users\ploceus\All Users\H1SunriseTN_t.jpg"
strFilePath = "C:\Users\ploceus\All Users\PhotoDB.gif"
'Set stdPic = LoadPicture(strFilePath) 'will not load tif images
Set stdPic = LoadPicturePlus(strFilePath) 'will load tif
' Debug.Print stdPic.type 'returns 1 vbPicTypeBitmap
' Debug.Print GetObjectType(stdPic.handle) 'returns 7 OBJ_BITMAP
' Me.Image7.Picture = stdPic 'both stdPic methods work here
Call pfCopyStdPicture(stdPic, blnUseDIB) 'only LoadPicture works
End Sub
LoadPicturePlus
Code:
'Using GDI+ you can load BMP, GIF, TIFF, JPEG and PNG files. This code loads the image and
'then converts it to a StdPicture object to use it in Visual Basic controls.
'FROM: [URL unfurl="true"]http://www.mvps.org/emorcillo/en/code/vb6/loadimagegdip.shtml[/URL]
Private Const vbPicTypeNone As Long = 0
Private Const vbPicTypeBitmap As Long = 1
Private Const vbPicTypeMetafile As Long = 2
Private Const vbPicTypeIcon As Long = 3
Private Const vbPicTypeEMetafile As Long = 4
' ----==== API Declarations ====----
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, _
inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus" ( _
ByVal FileName As Long, BITMAP As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" ( _
ByVal BITMAP As Long, hbmReturn As Long, ByVal background As Long) As Long
Private Type PICTDESC
cbSizeOfStruct As Long
PicType As Long
hgdiObj As Long
hPalOrXYExt As Long
End Type
Private Type IID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Declare Sub OleCreatePictureIndirect Lib "oleaut32.dll" (lpPictDesc As PICTDESC, _
riid As IID, ByVal fOwn As Boolean, lplpvObj As Object)
'------------------------------------------------------
' Procedure : LoadPicturePlus
' Purpose : Loads an image using GDI+
' Returns : The image loaded in a StdPicture object
' Author : Eduardo A. Morcillo
'------------------------------------------------------
Public Function LoadPicturePlus(ByVal FileName As String) As stdole.StdPicture
Dim tSI As GdiplusStartupInput
Dim lGDIP As Long
Dim lRes As Long
Dim lBitmap As Long
Dim hBitmap As Long
' Initialize GDI+
tSI.GdiplusVersion = 1
lRes = GdiplusStartup(lGDIP, tSI)
If lRes = 0 Then
' Open the image file
lRes = GdipCreateBitmapFromFile(StrPtr(FileName), lBitmap)
If lRes = 0 Then
' Create a GDI bitmap
lRes = GdipCreateHBITMAPFromBitmap(lBitmap, hBitmap, 0)
' Create the StdPicture object
Set LoadPicturePlus = HandleToPicture(hBitmap, vbPicTypeBitmap)
' Dispose the image
GdipDisposeImage lBitmap
End If
' Shutdown GDI+
GdiplusShutdown lGDIP
End If
If lRes Then Err.Raise 5, , "Cannot load file"
End Function
'------------------------------------------------------
' Procedure : HandleToPicture
' Purpose : Creates a StdPicture object to wrap a GDI
' image handle
'------------------------------------------------------
Private Function HandleToPicture(ByVal hGDIHandle As Long, ByVal lngObjectType As Long, Optional ByVal hpal As Long = 0) As stdole.StdPicture
Dim tPictDesc As PICTDESC
Dim IID_IPicture As IID
Dim oPicture As IPicture
' Initialize the PICTDESC structure
With tPictDesc
.cbSizeOfStruct = Len(tPictDesc)
.PicType = lngObjectType
.hgdiObj = hGDIHandle
.hPalOrXYExt = hpal
End With
' Initialize the IPicture interface ID
With IID_IPicture
.Data1 = &H7BF80981
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(3) = &HAA
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
' Create the object
OleCreatePictureIndirect tPictDesc, IID_IPicture, True, oPicture
' Return the picture object
Set HandleToPicture = oPicture
End Function
stdPicture > Clipboard functions
Code:
'slightly amended FROM: [URL unfurl="true"]https://groups.google.com/forum/#!topic/microsoft.public.vb.winapi.graphics/5kyV97FiqQw[/URL]
'posted by: Mike Sutton
Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, _
ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function BitBlt Lib "gdi32" ( _
ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hSrcDC As Long, ByVal xSrc As Long, _
ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, _
ByVal nStartScan As Long, ByVal nNumScans As Long, _
ByRef lpBits As Any, ByRef lpBI As BitmapInfo8, _
ByVal wUsage As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Type BitmapInfoHeader ' 40 bytes
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type BitmapInfo8
bmiHeader As BitmapInfoHeader
bmiColors(255) As Long
End Type
Private Const LOGPIXELSX As Long = 88 ' Logical pixels/inch in X
Private Const LOGPIXELSY As Long = 90 ' Logical pixels/inch in Y
Private Const GMEM_MOVEABLE As Long = &H2
' ClipBoard Formats
Private Const CF_BITMAP = 2
Private Const CF_DIB = 8
Private Const CF_ENHMETAFILE = 14
Private Const CF_METAFILEPICT = 3
'Copies the source bitmap directly to the destination bitmap.
Private Const SRCCOPY As Long = &HCC0020
Public Function pfCopyStdPicture(ByRef inPic As StdPicture, Optional ByVal inAsDIB As Boolean = True, Optional frm As Form) As Long
Dim CopyDC As Long, CopyBmp As Long, CopyOldBmp As Long
Dim hMemDC As Long, SrcOldBmp As Long
Dim SrcW As Long, SrcH As Long
Dim hDIB As Long
Dim hDIBPtr As Long
Dim BMInfo As BitmapInfo8
Dim lngHeadSize As Long
Dim lngDataSize As Long
Dim OldUsed As Long
' Try to open the clipboard
' If (OpenClipboard(frm.hWnd)) Then
If OpenClipboard(0) Then
' Clear the clipboard of any current data
' and to assign us clipboard ownership
Call EmptyClipboard
' Select the original bitmap into a temp DC
hMemDC = CreateCompatibleDC(0)
SrcOldBmp = SelectObject(hMemDC, inPic.handle)
If (inAsDIB) Then ' DIB
BMInfo.bmiHeader.biSize = Len(BMInfo.bmiHeader)
' Get some information about the current Bitmap
If (GetDIBits(hMemDC, inPic.handle, 0, 0, ByVal 0&, BMInfo, 0)) Then
With BMInfo.bmiHeader ' Make sure we've got a valid colour count
If (.biBitCount <= 8) Then _
If (.biClrUsed = 0) Then .biClrUsed = 2 ^ .biBitCount
Debug.Print .biBitCount
' Calculate the header and data sizes
lngHeadSize = Len(BMInfo.bmiHeader) + (.biClrUsed * Len(BMInfo.bmiColors(0)))
lngDataSize = ((((.biWidth * .biBitCount) + &H1F) And &HFFFFFFE0) \ &H8) * .biHeight
OldUsed = .biClrUsed
End With
' Allocate a chunk of memory for the DIB
hDIB = GlobalAlloc(GMEM_MOVEABLE, lngHeadSize + lngDataSize)
hDIBPtr = GlobalLock(hDIB) ' Get a pointer to the data
' Copy the bitmap data and header into the object
Call GetDIBits(hMemDC, inPic.handle, 0, BMInfo.bmiHeader.biHeight, _
ByVal (hDIBPtr + lngHeadSize), BMInfo, 0)
' For some reason the API knocks this out on consecutive
' calls to GetDIBits() with a paletted image..
BMInfo.bmiHeader.biClrUsed = OldUsed
Call RtlMoveMemory(ByVal hDIBPtr, BMInfo, lngHeadSize)
Call GlobalUnlock(hDIB) ' Release the memory pointer
pfCopyStdPicture = SetClipboardData(CF_DIB, hDIB)
If (Not pfCopyStdPicture) Then Call GlobalFree(hDIB)
End If
Else ' DDB
' Convert the picture size from OLE's high resolution metrics to twips
SrcW = (inPic.Width * GetDeviceCaps(hMemDC, LOGPIXELSX)) / 2540
SrcH = (inPic.Height * GetDeviceCaps(hMemDC, LOGPIXELSY)) / 2540
' Create a new Bitmap in compatibility with the original
CopyBmp = CreateCompatibleBitmap(hMemDC, SrcW, SrcH)
CopyDC = CreateCompatibleDC(0) ' Create new DC and select Bitmap
CopyOldBmp = SelectObject(CopyDC, CopyBmp)
' Copy original Bitmap to the new buffer
Call BitBlt(CopyDC, 0, 0, SrcW, SrcH, hMemDC, 0, 0, SRCCOPY)
' De-select copied Bitmap and destroy DC
Call SelectObject(CopyDC, CopyOldBmp)
Call DeleteDC(CopyDC)
' Assign the copied Bitmap to the clipboard
pfCopyStdPicture = SetClipboardData(CF_BITMAP, CopyBmp)
If (Not pfCopyStdPicture) Then Call DeleteObject(CopyBmp)
End If
' De-select original bitmap and destroy DC
Call SelectObject(hMemDC, SrcOldBmp)
Call DeleteDC(hMemDC)
' We're done with the clipboard, so release it
Call CloseClipboard
End If
End Function