Attribute VB_Name = "modOLEPicture"
Option Explicit

'   OLE Picture helper library 1.1
'  Written by Mike D Sutton of EDais
'
' E-Mail: EDais@mvps.org
' WWW: Http://www.mvps.org/EDais/
'
' Written: 01/05/2004
' Last edited: 07/04/2006

'Version history:
'----------------

' Version 1.1 (07/04/2006):
'   PtrToPicture() - Creates an IPicture from a data pointer
'   IPictureGUID() - Returns the GUID for an IPicture interface

' Version 1.02 (11/09/2004):
'   Added destroy-on-fail option to GDIToPicture() to automatically clean up input object
'   if the routine fails - This is set to false by default for backwards compatibility

' Version 1.01 (11/07/2004):
'   HimetricToPixelsX()    - Converts hi-metric to pixels in the X-axis
'   HimetricToPixelsY()    - Converts hi-metric to pixels in the Y-axis
'   PixelsToHimetricX()    - Converts pixels to hi-metric in the X-axis
'   PixelsToHimetricY()    - Converts pixels to hi-metric in the Y-axis
'   ConvertPixelHimetric() - [Private] Converts between hi-metric and pixel scale modes
'
' Version 1.0 (01/05/2004):
'   GDIToPicture() - Takes an HBITMAP, HCURSOR, HICON, HMETAFILE or HENHMETAFILE
'                    and wraps it in a StdPicture object for use in VB.
'   WMFToEMF()     - Converts a Windows format metafile to an enhanced metafile
'------------

Private Declare Function OleCreatePictureIndirect Lib "OLEPro32.dll" (ByRef PicDesc As Any, ByRef RefIID As GUID, ByVal fPictureOwnsHandle As Long, ByRef IPic As IPicture) As Long
Private Declare Function GetObjectType Lib "GDI32.dll" (ByVal hGDIObj As Long) As Long
Private Declare Function GetIconInfo Lib "User32.dll" (ByVal hIcon As Long, ByRef piconinfo As ICONINFO) As Long
Private Declare Function DeleteObject Lib "GDI32.dll" (ByVal hObject As Long) As Long
Private Declare Function GetMetaFileBitsEx Lib "GDI32.dll" (ByVal hMF As Long, ByVal nSize As Long, ByRef lpvData As Any) As Long
Private Declare Function SetWinMetaFileBits Lib "GDI32.dll" (ByVal cbBuffer As Long, ByRef lpbBuffer As Byte, ByVal hDCRef As Long, lpMFP As MetaFilePict) As Long
Private Declare Function GetEnhMetaFileHeader Lib "GDI32.dll" (ByVal hEMF As Long, ByVal cbBuffer As Long, ByRef lpEMH As EnhMetaHeader) As Long
Private Declare Function DeleteEnhMetaFile Lib "GDI32.dll" (ByVal hEMF As Long) As Long
Private Declare Function DeleteMetaFile Lib "GDI32.dll" (ByVal hMF As Long) As Long
Private Declare Function DestroyIcon Lib "User32.dll" (ByVal hIcon As Long) As Long

Private Declare Function CreateEnhMetaFile Lib "GDI32.dll" Alias "CreateEnhMetaFileA" (ByVal hDCRef As Long, ByVal lpFileName As String, ByRef lpRect As Any, ByVal lpDescription As String) As Long
Private Declare Function CloseEnhMetaFile Lib "GDI32.dll" (ByVal hDC As Long) As Long
Private Declare Function PlayMetaFile Lib "GDI32.dll" (ByVal hDC As Long, ByVal hMF As Long) As Long
Private Declare Function GetDeviceCaps Lib "GDI32.dll" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function CreateIC Lib "GDI32.dll" Alias "CreateICA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByRef lpInitData As Any) As Long
Private Declare Function DeleteDC Lib "GDI32.dll" (ByVal hDC As Long) As Long
Private Declare Function MulDiv Lib "Kernel32.dll" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long

Private Declare Function CreateStreamOnHGlobal Lib "OLE32.dll" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ByRef ppStm As Any) As Long
Private Declare Function OleLoadPicture Lib "OLEPro32.dll" (ByRef pStream As Any, ByVal lSize As Long, ByVal fRunMode As Long, ByRef riid As GUID, ByRef ppvObj As Any) As Long
Private Declare Function GlobalAlloc Lib "Kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "Kernel32.dll" (ByVal hMem 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 Const LOGPIXELSX As Long = 88 ' Logical pixels/inch in X
Private Const LOGPIXELSY As Long = 90 ' Logical pixels/inch in Y

Private Type PictDescGeneirc
    pdgSize As Long
    pdcPicType As Long
    pdcHandle As Long
    pdcExtraA As Long ' xExt for metafile, hPal for Bitmap
    pdcExtraB As Long ' yExt for metafile
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type ICONINFO
    fIcon As Long
    xHotspot As Long
    yHotspot As Long
    hbmMask As Long
    hbmColor As Long
End Type

Private Type MetaFilePict
    mm As Long
    xExt As Long
    yExt As Long
    hMF As Long
End Type

Private Type RectL
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type SizeL
    cx As Long
    cy As Long
End Type

Private Type EnhMetaHeader
    iType As Long
    nSize As Long
    rclBounds As RectL
    rclFrame As RectL
    dSignature As Long
    nVersion As Long
    nBytes As Long
    nRecords As Long
    nHandles As Integer
    sReserved As Integer
    nDescription As Long
    offDescription As Long
    nPalEntries As Long
    szlDevice As SizeL
    szlMillimeters As SizeL
End Type

Private Const OBJ_BITMAP As Long = &H7
Private Const OBJ_METAFILE As Long = &H9
Private Const OBJ_ENHMETAFILE As Long = &HD

Private Const PICTYPE_BITMAP As Long = &H1
Private Const PICTYPE_METAFILE As Long = &H2
Private Const PICTYPE_ICON As Long = &H3
Private Const PICTYPE_ENHMETAFILE As Long = &H4
Private Const GMEM_MOVEABLE As Long = &H2

Private Const S_OK As Long = &H0

Public Function GDIToPicture(ByVal inGDIObj As Long, _
    Optional ByVal inOwnObj As Boolean = True, _
    Optional ByVal inPal As Long = &H0, _
    Optional ByVal inDestroyOnFail As Boolean = False) As IPicture
    Dim IconInf As ICONINFO
    Dim PicDesc As PictDescGeneirc
    Dim RetPic As IPicture
    Dim TempEMF As Long
    Dim MetaHead As EnhMetaHeader
    Dim ObjType As Long
    
    ObjType = GetObjectType(inGDIObj)
    Select Case ObjType
        Case OBJ_BITMAP
            PicDesc.pdgSize = 16
            PicDesc.pdcPicType = PICTYPE_BITMAP
            PicDesc.pdcExtraA = inPal
        Case OBJ_METAFILE ' UNTESTED!
            PicDesc.pdgSize = 20
            PicDesc.pdcPicType = PICTYPE_METAFILE
            
            ' WMF objects don't store bounds information so perform
            ' temporary conversion to EMF and read header structure
            TempEMF = WMFToEMF(inGDIObj)
            If (TempEMF) Then
                Call GetEnhMetaFileHeader(TempEMF, Len(MetaHead), MetaHead)
                PicDesc.pdcExtraA = MetaHead.rclBounds.Right
                PicDesc.pdcExtraB = MetaHead.rclBounds.Bottom
                Call DeleteEnhMetaFile(TempEMF)
            End If
        Case OBJ_ENHMETAFILE
            PicDesc.pdgSize = 12
            PicDesc.pdcPicType = PICTYPE_ENHMETAFILE
        Case Else ' Test for icon/cursor
            If (GetIconInfo(inGDIObj, IconInf)) Then
                PicDesc.pdgSize = 12
                PicDesc.pdcPicType = PICTYPE_ICON
                
                ' Clean up Bitmap copies
                Call DeleteObject(IconInf.hbmColor)
                Call DeleteObject(IconInf.hbmMask)
            End If
    End Select
    
    ' Couldn't match this object against known types
    If (PicDesc.pdgSize = 0) Then Exit Function
    
    ' Set object handle
    PicDesc.pdcHandle = inGDIObj
    
    If (OleCreatePictureIndirect(PicDesc, IPictureGUID(), _
        inOwnObj, RetPic) = S_OK) Then Set GDIToPicture = RetPic
    Set RetPic = Nothing
    
    If ((GDIToPicture Is Nothing) And inDestroyOnFail) Then
        Select Case ObjType ' Call appropriate cleanup routine
            Case OBJ_BITMAP:      Call DeleteObject(inGDIObj)
            Case OBJ_METAFILE:    Call DeleteMetaFile(inGDIObj)
            Case OBJ_ENHMETAFILE: Call DeleteEnhMetaFile(inGDIObj)
            Case Else:            Call DestroyIcon(inGDIObj)
        End Select
    End If
End Function

Public Function PtrToPicture(ByVal inPtr As Long, ByVal inSize As Long) As IPicture
    Dim hGlobal As Long, DataPtr As Long
    Dim hStream As IUnknown
    
    If (inSize > 0) Then ' Create global memory object
        hGlobal = GlobalAlloc(GMEM_MOVEABLE, inSize)
        
        If (hGlobal) Then ' Get pointer to data
            DataPtr = GlobalLock(hGlobal)
            
            If (DataPtr) Then ' Copy picture data into object
                Call RtlMoveMemory(ByVal DataPtr, ByVal inPtr, inSize)
                Call GlobalUnlock(hGlobal)
                
                ' Create new IPicture object from global memory object's data
                If (CreateStreamOnHGlobal(hGlobal, 1&, hStream) = S_OK) Then _
                    Call OleLoadPicture(ByVal ObjPtr(hStream), inSize, 0&, IPictureGUID(), PtrToPicture)
            End If
            
            ' Clean up on failure
            If (PtrToPicture Is Nothing) Then _
                Call GlobalFree(hGlobal)
        End If
    End If
End Function

Private Function WMFToEMF(ByVal inWMF As Long) As Long
    Dim EMetaDC As Long
    
    ' Create a new Enhanced metafile device context
    EMetaDC = CreateEnhMetaFile(0, vbNullString, ByVal 0&, vbNullString)
    Call PlayMetaFile(EMetaDC, inWMF)
    WMFToEMF = CloseEnhMetaFile(EMetaDC)
    
    If (WMFToEMF = 0) Then ' If first method fails, try copy method
        Dim WMFSize As Long, WMFData() As Byte
        Dim MetaInf As MetaFilePict
        
        ' Query WMF data size
        WMFSize = GetMetaFileBitsEx(inWMF, 0, ByVal 0&)
        If (WMFSize) Then ' Allocate data buffer and extract WMF data
            ReDim WMFData(WMFSize - 1) As Byte
            Call GetMetaFileBitsEx(inWMF, WMFSize, WMFData(0))
            
            MetaInf.hMF = inWMF ' Convert WMF data to EMF
            WMFToEMF = SetWinMetaFileBits(WMFSize, WMFData(0), 0, MetaInf)
        End If
    End If
End Function

Public Function HimetricToPixelsX(ByVal inHimetric As Long) As Long
    HimetricToPixelsX = ConvertPixelHimetric(inHimetric, True, True)
End Function

Public Function HimetricToPixelsY(ByVal inHimetric As Long) As Long
    HimetricToPixelsY = ConvertPixelHimetric(inHimetric, True, False)
End Function

Public Function PixelsToHimetricX(ByVal inPixels As Long) As Long
    PixelsToHimetricX = ConvertPixelHimetric(inPixels, False, True)
End Function

Public Function PixelsToHimetricY(ByVal inPixels As Long) As Long
    PixelsToHimetricY = ConvertPixelHimetric(inPixels, False, False)
End Function

Private Function ConvertPixelHimetric(ByVal inValue As Long, _
    ByVal ToPix As Boolean, inXAxis As Boolean) As Long
    Dim TempIC As Long, GDCFlag As Long
    
    Const HimetricInch As Long = 2540
    
    TempIC = CreateIC("DISPLAY", vbNullString, vbNullString, ByVal 0&)
    
    If (TempIC) Then
        If (inXAxis) Then GDCFlag = LOGPIXELSX Else GDCFlag = LOGPIXELSY
        
        If (ToPix) Then _
            ConvertPixelHimetric = MulDiv(inValue, GetDeviceCaps(TempIC, GDCFlag), HimetricInch) _
        Else _
            ConvertPixelHimetric = MulDiv(inValue, HimetricInch, GetDeviceCaps(TempIC, GDCFlag))
        
        Call DeleteDC(TempIC)
    End If
End Function

Private Function IPictureGUID() As GUID
    ' IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
    With IPictureGUID
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With
End Function