Option Explicit
 
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
Private Declare Function GlobalLock Lib "Kernel32.dll" (ByVal hMem As Long) As _
Long
Private Declare Function GlobalUnlock Lib "Kernel32.dll" (ByVal hMem As Long) _
As Long
Private Declare Sub RtlMoveMemory Lib "Kernel32.dll" (ByRef Destination As Any, _
ByRef Source As Any, ByVal Length As Long)
Private Declare Sub PutDWord Lib "MSVBVM60.dll" Alias "PutMem4" (ByRef inDst As _
Any, ByVal inSrc As Long)
Private Const DIB_RGB_COLORS As Long = &H0 ' Colour table in RGBs
Private Const BI_BITFIELDS As Long = &H3
 
Public Function PackedDIBToDIBSection(ByVal inPackedDIB As Long) As Long
    Dim DataPtr As Long
    Dim BMHead As BitmapInfoHeader
    Dim HeadSize As Long, DataSize As Long
    Dim hDIB As Long, DIBDataPtr As Long
 
    ' Attempt to get access to the data
    DataPtr = GlobalLock(inPackedDIB)
    If (DataPtr) Then ' Read header size from packed DIB
        Call RtlMoveMemory(BMHead, ByVal DataPtr, Len(BMHead))
 
        ' Get header and data size
        HeadSize = GetDIBHeaderSize(BMHead)
        DataSize = GetDIBDataSize(BMHead)
 
        ' Create DIBSection based on the header
        hDIB = CreateDIBSectionPtr(0&, ByVal DataPtr, DIB_RGB_COLORS, _
          DIBDataPtr, 0&, 0&)
 
        If (hDIB) Then ' Copy Bitmap data into DIBSection
            Call RtlMoveMemory(ByVal DIBDataPtr, ByVal (DataPtr + HeadSize), _
              DataSize)
            PackedDIBToDIBSection = hDIB ' Return DIBSection handle
        End If
 
        Call GlobalUnlock(inPackedDIB)
    End If
End Function
 
 
Private Function GetDIBHeaderSize(ByRef inHeader As BitmapInfoHeader) As Long
    With inHeader ' Set palette size if undefined for a paletted image
        If ((.biBitCount <= 8) And (.biClrUsed < 1)) Then .biClrUsed = 2 ^ _
          .biBitCount
        GetDIBHeaderSize = .biSize + (.biClrUsed * 4) + _
            IIf((.biCompression = BI_BITFIELDS) And (.biSize = Len(inHeader)), _
            12, 0)
    End With
End Function
 
Private Function GetDIBDataSize(ByRef inHeader As BitmapInfoHeader) As Long
    Select Case inHeader.biCompression
        Case BI_RGB, BI_BITFIELDS
            With inHeader ' Calculate the DWord aligned scan-line width and 
            ' multiply by height
                GetDIBDataSize = AlignScan(.biWidth, .biBitCount) * Abs( _
                  .biHeight)
                .biSizeImage = GetDIBDataSize ' Set the property in the header
            End With
        Case Else ' Compressed images have the size already set
            GetDIBDataSize = inHeader.biSizeImage
    End Select
End Function
 
Private Function AlignScan(ByVal inWidth As Long, ByVal inDepth As Integer) As _
  Long
    AlignScan = (((inWidth * inDepth) + &H1F) And Not &H1F&) \ &H8
End Function