Packed DIB to StdPicture?

[dilettante]

There is a form of GDI bitmap called a "packed DIB."

These are like any other GDI bitmaps, DIBs, MetaFiles, etc. except that the pixel bits immediately follow the header structures in memory and a few rules are simplified which guarantee a few specific things about some header field values.


Supposedly they get used a lot in Windows because they're the only safe way to pass images between processes: they can be persisted as a BLOB in memory and aren't a GDI object. For example this is how bitmaps and such get passed via the Clipboard.

VB6 can handle these with the Clipboard because it has specific Clipboard methods for dealing with them.


But now I have a case where a Windows object returns to me a packed DIB in a Long array. I don't want to play games with the Clipboard because I don't want to mess with the Clipboard contents, which might well have other stuff there the user is copying/pasting.

So since Windows loves these so much, I'd think there should be some easy support to either get them into a GDI HBITMAP, or preferably even directly into an OLE IPicture/StdPicture object.


I have some working code but I feel like I'm doing too much work. Does anyone have a better idea for converting these using less code?

See the first post in DirectShow WebCam Minimal Code to look at what i have (it is in Module1.bas of the ZIP archive).

The code I have works, but (a.) as I said it feels like too much work for this, and (b.) the resulting StdPicture doesn't have a "real" Device Context. This limits what can be done with it without more work to tie it to a screen DC or something.

This second point is minor since I can always adapt my code to have the calling Form, UserControl, etc. pass in its own hDC - and you can PaintPicture, etc. with it as it is.

[Jonney]

Extract from my old project:

Private Declare Function CreateDIBSectionPtr Lib "gdi32.dll" Alias "CreateDIBSection" (ByVal hDC As Long, ByRef pBMI As Any, ByVal iUsage As Long, ByRef ppvBits As Long, ByVal hSection As Long, ByVal dwOffset As Long) As Long


Public Function CaptureCurrentImage() As Boolean

Dim BufferPointer As Long, BufferLength As Long
Dim lheap As Long
Dim oBasicVideo As IAMBasicVideo
Dim bResult As Boolean

    On Error Resume Next

        Set oBasicVideo = m_objManager
        Call oBasicVideo.GetCurrentImage(BufferLength, ByVal 0&)
        If BufferLength > 0& Then
            lheap = GetProcessHeap()
            'BufferPointer is a packed DIB
            BufferPointer = HeapAlloc(lheap, HEAP_GENERATE_EXCEPTIONS Or HEAP_ZERO_MEMORY, BufferLength)
            If BufferPointer <> 0 Then
                Call oBasicVideo.GetCurrentImage(BufferLength, ByVal BufferPointer)
                Set oBasicVideo = Nothing
                If (Err.Number = 0&) Then
                    Select Case m_eDSVideoOutputMode
                    Case eSaveAsFile
                        If Len(m_sOutputFileName) Then
                            CaptureCurrentImage = SaveToBitmap(m_uBIH, BufferPointer, BufferLength, m_sOutputFileName)
                        End If
                        HeapFree lheap, 0, BufferPointer
                        m_bCaptureInProgress = False
                        Exit Function
                    Case eCopytoClipboard
                        If (CopyPackedDIBtoClipboard(BufferPointer)) Then
                            bResult = HeapFree(lheap, 0&, BufferPointer)
                            If Not bResult Then
                               'MsgBox "Call to HeapFree has failed", vbCritical, "HeapFree Failed"
                            End If
                            CaptureCurrentImage = True
                            m_bCaptureInProgress = False
                            Exit Function
                        End If
                    Case eCopytoDIBSection
    Dim DIBDataPtr As Long, hDC As Long, hOldDIB As Long, dDC As Long, hDIB As Long
                        dDC = GetDC(GetDesktopWindow())
                        hDC = CreateCompatibleDC(dDC)
                        ReleaseDC GetDesktopWindow(), dDC
                        If (hDC <> 0) Then
                            hDIB = CreateDIBSectionPtr(hDC, ByVal BufferPointer, DIB_RGB_COLORS, DIBDataPtr, 0&, 0&)
                            If (hDIB <> 0) Then
                                hOldDIB = SelectObject(hDC, hDIB)
                            Else
                                Call DeleteDC(hDC)
                            End If
                            If (hDIB) Then ' Copy Bitmap data into DIBSection
                                'BufferPointer is a packed DIB,we need to retrieve raw DIB bits (DIBSection)
                                Call RtlMoveMemory(ByVal DIBDataPtr, ByVal (BufferPointer + 40), BufferLength - 40)
                                ' Return DIBSection handle
                                RaiseEvent DSCopyFrametoDIB(hDIB)
                                CaptureCurrentImage = True
                                m_bCaptureInProgress = False
                            End If
                        End If

                        If (hDC <> 0) Then
                            If (hDIB <> 0) Then
                                Call SelectObject(hDC, hOldDIB)
                                Call DeleteObject(hDIB)
                            End If
                            Call DeleteDC(hDC)
                        End If

                        '-- Reset DIB vars.
                        hDC = 0
                        hDIB = 0
                        hOldDIB = 0
                    End Select
                End If
            End If
            HeapFree lheap, 0, BufferPointer
            Call Err.Clear
        End If
        Set oBasicVideo = Nothing

End Function

Private Function SaveToBitmap(tBIH As BITMAPINFOHEADER, ByVal lPtrBits As Long, ByVal PtrBitsSize As Long, ByVal sFileName As String) As Boolean

Dim uBFH As BITMAPFILEHEADER
Dim hFile As Long
Dim lBytesWritten As Long
Dim lSize As Long
Dim lRet As Long
Dim bErr As Boolean
Dim lheap As Long, lPtr As Long
Dim lErr As Long
Dim lColors As Long
Dim bOk As Boolean

' Prepare the BITMAPFILEHEADER

    bOk = DeleteTheFile(sFileName, m_bUseUnicode)
    'If Not bOK Then Exit Function
    hFile = CreateTheFile(sFileName, False, m_bUseUnicode)
    lErr = Err.LastDllError
    If (hFile = INVALID_HANDLE_VALUE) Then
        ' error
        Exit Function
    Else
        '-- Get palette entries count
        lColors = IIf(tBIH.biBitCount <= 8, 2 ^ tBIH.biBitCount, 0)

        With uBFH
            .bfType = BITMAPTYPE
            .bfSize = Len(tBIH) + 4 * lColors + tBIH.biSizeImage
            .bfOffBits = Len(uBFH) + Len(tBIH) + 4 * lColors
        End With
        ' Writing the BITMAPFILEINFOHEADER is somewhat painful
        ' due to non-byte alignment of structure...
        lheap = GetProcessHeap()
        lPtr = HeapAlloc(lheap, HEAP_GENERATE_EXCEPTIONS Or HEAP_ZERO_MEMORY, Len(uBFH))
        CopyMemory ByVal lPtr, uBFH.bfType, 2
        CopyMemory ByVal lPtr + 2, uBFH.bfSize, 4
        CopyMemory ByVal lPtr + 6, 0&, 4
        CopyMemory ByVal lPtr + 10, uBFH.bfOffBits, 4
        lSize = Len(uBFH)
        lRet = WriteFile(hFile, ByVal lPtr, lSize, lBytesWritten, ByVal 0&)
        HeapFree lheap, 0, lPtr

        ' Add the BITMAPINFOHEADER and colour palette:
        bErr = FileErrHandler(lRet, lSize, lBytesWritten)
        If Not bErr Then
            lSize = Len(tBIH)
            lRet = WriteFile(hFile, tBIH, lSize, lBytesWritten, ByVal 0&)
            bErr = FileErrHandler(lRet, lSize, lBytesWritten)
        Else
            CloseHandle hFile
        End If

        If Not bErr Then
            ' Its easy to write the bitmap data, though...
            lSize = PtrBitsSize 'tBIH.biSizeImage
            lRet = WriteFile(hFile, ByVal (lPtrBits + Len(tBIH)), lSize, lBytesWritten, ByVal 0&)
            bErr = FileErrHandler(lRet, lSize, lBytesWritten)
        Else
            CloseHandle hFile
        End If

        bErr = FileErrHandler(lRet, lSize, lBytesWritten)

        CloseHandle hFile
        SaveToBitmap = Not (bErr)
    End If

End Function

Private Function FileErrHandler(ByVal lR As Long, ByVal lSize As Long, ByVal lBytes As Long) As Boolean

    If (lR = 0) Or Not (lSize = lBytes) Then
        'Err.Raise
        FileErrHandler = True
    End If

End Function

Private Function pvByteAlignOnWord(ByVal BitDepth As Byte, ByVal Width As Long) As Long

' function to align any bit depth on dWord boundaries

    pvByteAlignOnWord = (((Width * BitDepth) + &H1F&) And Not &H1F&) \ &H8&

End Function

Private Function CopyPackedDIBtoClipboard(ByVal hGlobal As OLE_HANDLE) As Boolean

    If hGlobal = 0& Then Exit Function
    If (0& <> OpenClipboard(0&)) Then
        If (0& <> EmptyClipboard()) Then
            CopyPackedDIBtoClipboard = CBool(SetClipboardData(vbCFDIB, hGlobal) <> 0)
        End If
        Call CloseClipboard
    End If

End Function

[dilettante]

I appreciate the assistance.


But the only thing that code does is to create the hBitmap, and it accomplishes that exactly as my example already does. Well with the tiny differnce of selecting it into the Desktop's (screen's) context but I knew that part already.

And it does nothing about going from there to a StdPicture object.


I was hoping there was a more direct way to get from the packed DIB to a StdPicture, something like an OleCreatePictureIndirect() call that accepts a packed DIB pointer instead of a PICTDESC structure.


On a side note, I'm curious what DirectShow wrapper you are using. Is there a DLL or maybe just a TLB involved here? Or do you have a way to get these objects and work with them in pure VB code?

[Jonney]

タイトル DirectShowを用いて静止画をキャプチャーする
ファイル名 MdaCpt09.lzh
サイズ 84,247 bytes
更新日 2004/12/05
今後の予定 アナログTVチューナに対応させる予定です。
分類 VB6で作成したサンプル
機能 DirectShowで動画を再生し、希望した位置での画像(静止画)をクリップボードにコピーします。
特徴 IBasicVideo.GetCurrentImageメソッドを用いて静止画を取得します。
IVMRWindowlessControl9.GetCurrentImageメソッドを用いて静止画を取得します。
ISampleGrabberを用いて静止画を取得します。
主な内容 IBasicVideo.GetCurrentImageメソッドの利用方法。
IVMRWindowlessControl9.GetCurrentImageメソッドの利用方法。
ISampleGrabberインターフェースの利用方法。
注意 専用のタイプライブラリ(KTLDShw2.tlb)を同梱しています。
デザイン／コンパイル時に必要です。実行時には不要です。
VB5で使用するには、一部修正する必要があります。

I used this tlb for many years.
IBasicVideo.GetCurrentImage will cause video pause for a while.
IAMSampleGrabberCB_BufferCB capture pictures without still.

[dilettante]

Thanks, I was looking at that just a little while ago.