image path > stdPic > clipboard issue 1

[hambakahle]

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

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

'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

'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

 

[strongm]

What OS? If Vista or later then the OS ships with a really useful library, WIA 2.0 (Windows Image Acquisition), essentially Microsoft's wrapping of certain parts of GDI+ to replace some of the functionality lost whn the Wang/Kodak imaging controls were unbundled. If yiu have got XP, then that only ships with WIA 1.0, which has much less functionality, and all the old Microsoft download links for version 2 are long gone. However you can still find a copy here:

http://vbnet.mvps.org/files/updates/wiaautsdk.zip

(simple installation instructions included).

In either case all your code can be reduced to something like:

[blue]Option Explicit

Private Sub Command1_Click()
    Clipboard.Clear
    Clipboard.SetData NewLoadPicture("C:\Users\ploceus\All Users\H1.tif")
End Sub

[green]' More flexible version of VB's LoadPicture method, supporting additional formats including TIF and PNG[/green]
Public Function NewLoadPicture(strPath As String) As StdPicture
    With CreateObject("WIA.ImageFile")
        .LoadFile strPath
        Set NewLoadPicture = .FileData.Picture
    End With
End Function[/blue]

And not an API call in sight

(you'll find my original version of the function in thread222-1651299. Pretty much the same as here, just a tiny bit more commentary)

 

[hambakahle]

Thank you, strongm, for the WIA heads up. I fondly remember the Kodak control and wasn't familiar with the WIA library. It will be useful. So tif > stdPicture is fine. However, exchanging a couple of pages of code for a mere few lines did seem a wee bit too good. I'm using VBA 7.0 and I don't believe there is a VB clipboard class available.

Absent the nice clipboard objrct, I passed the stdPic back through the clipboard function and pasted a blank rectangle again. aaargh! There is a bitmap on the clipboard with all the more or less relevant formats. Based on MS documentation, the BitmapHeaderInfo structure seems to have all the right info. Maybe the color info is buggered, but now I'm flailing.

Anyway, thanks again. If there are any further thoughts, keep them coming

 

[strongm]

> I don't believe there is a VB clipboard class available

Good point. Keep forgetting that inexcusable omission from VBA. There's a DLL that duplicates (pretty much) the VB clipboard object for VBA:

http://www.vbforums.com/attachment.php?attachmentid=73721&d=1255487458

original author is westconn1, and you should find additional info here:

http://www.vbforums.com/showthread.php?585616-clipboard-activex-for-vba-vbs-etc

Once the dll is registered you only have to make very minor alterations to my code:

[blue]Option Explicit
Public myClipboard As New clipbrd.ClipBoard

Private Sub Command1_Click()
    myClipboard.Clear
    myClipboard.setdata NewLoadPicture("C:\Users\ploceus\All Users\H1.tif")
End Sub

[green]' More flexible version of VB's LoadPicture method, supporting additional formats including TIF and PNG[/green]
Public Function NewLoadPicture(strPath As String) As StdPicture
 Dim fred As New WIA.ImageFile
    With CreateObject("WIA.ImageFile")
        .LoadFile strPath
        Set NewLoadPicture = .FileData.Picture
    End With
End Function[/blue]

 

[hambakahle]

The dll isn't the preferred route, but it would have been interesting for a test. Unfortunately it won't register on Win7 32 bit. Binary and/or dependency issues. I pulled up Dependency Walker and it refused to find clipboard.dll in the Open dialog. So a bit of a rabbithole at the moment.

 

[strongm]

As I recall you have to register it using elevated rights

 

[strongm]

>The dll isn't the preferred route

The author used to happily dole out the (VB) source code.

 

[hambakahle]

Strongm,

Thank you for staying with this thread. You've been very helpful. I did get the clipboard.dll registered. With Windows 7 it meant placing copies of the dll in BOTH SysWow64 and System32 folders and then following the normal admin regsvr32 procedure. Otherwise, plopping the dll just in System32 and registering with admin privileges carried no weight.

The clipboard class now works as advertised and will facilitate a bit of tinkering.

I see that the vbforums site already has a queue of people asking and waiting for the source code.