Option Explicit

Private Enum BOOL
   FALSE_BOOL
   TRUE_BOOL
End Enum

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

Private Declare Function CLSIDFromString Lib "ole32" ( _
   ByVal lpsz As Long, rguid As GUID) As Long
Private Const IIDSTR_IPictureDisp$ = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"

Private Enum PICTYPE
   PICTYPE_UNINITIALIZED = - 1 
   PICTYPE_NONE =  0 
   PICTYPE_BITMAP =  1 
   PICTYPE_METAFILE =  2 
   PICTYPE_ICON =  3 
   PICTYPE_ENHMETAFILE =  4 
End Enum

Private Type PICTDESCEMF
   cbSizeOfStruct As Long
   PictType As PICTYPE
   hEMF As Long
   Reserved1 As Long
   Reserved2 As Long
End Type

Private Declare Function OleCreatePictureIndirect Lib "olepro32" ( _
   pPictDesc As Any, riid As GUID, _
   ByVal fOwn As BOOL, ppvObj As IPictureDisp) As Long


Private Declare Function CreateIC Lib "gdi32" Alias "CreateICA" ( _
   ByVal lpDriverName As String, ByVal lpDeviceName As String, _
   ByVal lpOutput As String, lpInitData As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" ( _
   ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As BOOL

Private Declare Function SelectObject Lib "gdi32" ( _
   ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" ( _
   ByVal hObject As Long) As BOOL

Private Enum DeviceCapIndex
   HORZSIZE =  4            '  Horizontal size in millimeters
   VERTSIZE =  6            '  Vertical size in millimeters
   HORZRES =  8             '  Horizontal width in pixels
   VERTRES =  10            '  Vertical width in pixels
   LOGPIXELSX =  88         '  Logical pixels/inch in X
   LOGPIXELSY =  90         '  Logical pixels/inch in Y
End Enum
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nIndex As DeviceCapIndex) As Long

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

Private Declare Function CreateEnhMetaFile Lib "gdi32" _
   Alias "CreateEnhMetaFileA" ( _
   ByVal hdcRef As Long, ByVal lpFileName As String, lpRect As RECT, _
   ByVal lpDescription As String) As Long
Private Declare Function CloseEnhMetaFile Lib "gdi32" ( _
   ByVal hDC As Long) As Long

Private Enum MapMode
   MM_ANISOTROPIC =  8  ' Map mode anisotropic
End Enum
Private Declare Function SetMapMode Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nMapMode As MapMode) As MapMode

Private Declare Function SetWindowExtEx Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nX As Long, ByVal nY As Long, _
   lpSize As Any) As BOOL
Private Declare Function SetViewportExtEx Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nX As Long, _
   ByVal nY As Long, lpSize As Any) As BOOL


Private Type BLENDFUNCTION
   BlendOp As Byte
   BlendFlags As Byte
   SourceConstantAlpha As Byte
   AlphaFormat As Byte
End Type
Private Type BLENDFUNCTIONBYVAL
   Value As Long
End Type
Private Const AC_SRC_OVER = &H0
'Alpha format flags
Private Const AC_SRC_ALPHA = &H1
'Private Const AC_SRC_NO_PREMULT_ALPHA = &H1
'Private Const AC_SRC_NO_ALPHA = &H2
'Private Const AC_DST_NO_PREMULT_ALPHA = &H10
'Private Const AC_DST_NO_ALPHA = &H20

Private Declare Function AlphaBlend Lib "msimg32" ( _
  ByVal hdcDest As Long, _
  ByVal nXOriginDest As Long, ByVal nYOriginDest As Long, _
  ByVal nWidthDest As Long, ByVal nHeightDest As Long, _
  ByVal hdcSrc As Long, _
  ByVal nXOriginSrc As Long, ByVal nYOriginSrc As Long, _
  ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, _
  ByVal lBlendFunction As Long) As BOOL


Private Enum GpStatus 'GDI+ Status
   OK =  0 
   GenericError =  1 
   InvalidParameter =  2 
   OutOfMemory =  3 
   ObjectBusy =  4 
   InsufficientBuffer =  5 
   NotImplemented =  6 
   Win32Error =  7 
   WrongState =  8 
   Aborted =  9 
   FileNotFound =  10 
   ValueOverflow =  11 
   AccessDenied =  12 
   UnknownImageFormat =  13 
   FontFamilyNotFound =  14 
   FontStyleNotFound =  15 
   NotTrueTypeFont =  16 
   UnsupportedGdiplusVersion =  17 
   GdiplusNotInitialized =  18 
   PropertyNotFound =  19 
   PropertyNotSupported =  20 
   ProfileNotFound =  21 
End Enum

Private Enum GdiplusVersion
   Ver1 =  1 
End Enum

Private Type GdiplusStartupInput
   GdiplusVersion As GdiplusVersion
   DebugEventCallback As Long
   SuppressBackgroundThread As BOOL
   SuppressExternalCodecs As BOOL
End Type

Private Declare Function GdiplusStartup Lib "gdiplus" ( _
   lToken As Long, lpInput As GdiplusStartupInput, _
   Optional ByRef lpOutput As Any) As GpStatus
Private Declare Function GdiplusShutdown Lib "gdiplus" ( _
   ByVal lToken As Long) As GpStatus

Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus" ( _
   ByVal wszFileName As Long, nBitmap As Long) As GpStatus
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" ( _
   ByVal nBitmap As Long, hbmReturn As Long, _
   ByVal argbBackground As Long) As GpStatus
Private Declare Function GdipDisposeImage Lib "gdiplus" ( _
   ByVal nImage As Long) As GpStatus

Public Enum PixelFormat
   PixelFormatUndefined = &H0&
   PixelFormatDontCare = PixelFormatUndefined
   PixelFormatMax = &HF&
   PixelFormat1_8 = &H100&
   PixelFormat4_8 = &H400&
   PixelFormat8_8 = &H800&
   PixelFormat16_8 = &H1000&
   PixelFormat24_8 = &H1800&
   PixelFormat32_8 = &H2000&
   PixelFormat48_8 = &H3000&
   PixelFormat64_8 = &H4000&
   PixelFormat16bppRGB555 = &H21005
   PixelFormat16bppRGB565 = &H21006
   PixelFormat16bppGrayScale = &H101004
   PixelFormat16bppARGB1555 = &H61007
   PixelFormat24bppRGB = &H21808
   PixelFormat32bppRGB = &H22009
   PixelFormat32bppARGB = &H26200A
   PixelFormat32bppPARGB = &HD200B
   PixelFormat48bppRGB = &H10300C
   PixelFormat64bppARGB = &H34400D
   PixelFormat64bppPARGB = &H1C400E
   PixelFormatGDI = &H20000
   PixelFormat1bppIndexed = &H30101
   PixelFormat4bppIndexed = &H30402
   PixelFormat8bppIndexed = &H30803
   PixelFormatAlpha = &H40000
   PixelFormatIndexed = &H10000
   PixelFormatPAlpha = &H80000
   PixelFormatExtended = &H100000
   PixelFormatCanonical = &H200000
End Enum
Private Declare Function GdipGetImagePixelFormat Lib "gdiplus" ( _
   ByVal nImage As Long, ImagePixFmt As PixelFormat) As GpStatus
Private Declare Function GdipGetImageWidth Lib "gdiplus" ( _
   ByVal nImage As Long, Width As Long) As GpStatus
Private Declare Function GdipGetImageHeight Lib "gdiplus" ( _
   ByVal nImage As Long, Height As Long) As GpStatus

Private Function GdiErrorString(ByVal lError As GpStatus) As String
 Select Case lError
 Case GenericError:              GdiErrorString = "Generic error"
 Case InvalidParameter:          GdiErrorString = "Invalid parameter"
 Case OutOfMemory:               GdiErrorString = "Out of memory"
 Case ObjectBusy:                GdiErrorString = "Object busy"
 Case InsufficientBuffer:        GdiErrorString = "Insufficient buffer"
 Case NotImplemented:            GdiErrorString = "Not implemented"
 Case Win32Error:                GdiErrorString = "Win32 error"
 Case WrongState:                GdiErrorString = "Wrong state"
 Case Aborted:                   GdiErrorString = "Aborted"
 Case FileNotFound:              GdiErrorString = "File not found"
 Case ValueOverflow:             GdiErrorString = "Value overflow"
 Case AccessDenied:              GdiErrorString = "Access denied"
 Case UnknownImageFormat:        GdiErrorString = "Unknown image format"
 Case FontFamilyNotFound:        GdiErrorString = "Font family not found"
 Case FontStyleNotFound:         GdiErrorString = "Font style not found"
 Case NotTrueTypeFont:           GdiErrorString = "Not TrueType font"
 Case UnsupportedGdiplusVersion: GdiErrorString = "Unsupported GDI+ version"
 Case GdiplusNotInitialized:     GdiErrorString = "GDI+ not initialized"
 Case PropertyNotFound:          GdiErrorString = "Property not found"
 Case PropertyNotSupported:      GdiErrorString = "Property not supported"
 Case Else:                      GdiErrorString = "Unknown GDI+ error"
 End Select
End Function

Private Function GdipExec(ByVal lStatus As GpStatus) As GpStatus
 If lStatus <> OK Then MsgBox GdiErrorString(lStatus), vbExclamation, _
                              "GDI+ Error"
 GdipExec = lStatus
End Function


Public Function LoadARGBBmpAsEmfPicture( _
   ByVal FileName As String, _
   Optional ByVal bAlpha As Byte =  255 , _
   Optional ByVal EMFFileName As String = vbNullString) As IPictureDisp
 Dim GdipToken As Long
 Dim si As GdiplusStartupInput
 Dim nBitmap As Long
 Dim hBitmap As Long
 Dim pfPixFmt As PixelFormat
 Dim cxWidth As Long, cyHeight As Long
 Dim hicRef As Long
 Dim iWidthMM As Long
 Dim iHeightMM As Long
 Dim iWidthPels As Long
 Dim iHeightPels As Long
 Dim iDPIX As Long
 Dim iDPIY As Long
 Dim rc As RECT
 Dim hdcMeta As Long
 Dim iWEX As Long, iWEY As Long
 Dim iVEX As Long, iVEY As Long
 Dim iGCD As Long
 Dim hdcMem As Long
 Dim hbmpOld As Long
 Dim hEMF As Long
 Dim bfBlend As BLENDFUNCTION
 Dim bfvBlend As BLENDFUNCTIONBYVAL

 si.GdiplusVersion = Ver1
 GdipExec GdiplusStartup(GdipToken, si, ByVal  0 &)
 If GdipToken =  0  Then Exit Function
 GdipExec GdipCreateBitmapFromFile(StrPtr(FileName), nBitmap)
 If nBitmap Then
    GdipExec GdipGetImagePixelFormat(nBitmap, pfPixFmt)
    If pfPixFmt = PixelFormat32bppARGB Then
       GdipExec GdipGetImageWidth(nBitmap, cxWidth)
       GdipExec GdipGetImageHeight(nBitmap, cyHeight)
       GdipExec GdipCreateHBITMAPFromBitmap(nBitmap, hBitmap, &H0)
    Else
       MsgBox "Wrong image format!", vbExclamation
    End If
    GdipExec GdipDisposeImage(nBitmap): nBitmap =  0 
 End If
 GdipExec GdiplusShutdown(GdipToken): GdipToken =  0 
 If hBitmap =  0  Then Exit Function
 
 hicRef = CreateIC("DISPLAY", vbNullString, vbNullString, ByVal  0 &)
 iWidthMM = GetDeviceCaps(hicRef, HORZSIZE)
 iHeightMM = GetDeviceCaps(hicRef, VERTSIZE)
 iWidthPels = GetDeviceCaps(hicRef, HORZRES)
 iHeightPels = GetDeviceCaps(hicRef, VERTRES)
 iDPIX = GetDeviceCaps(hicRef, LOGPIXELSX)
 iDPIY = GetDeviceCaps(hicRef, LOGPIXELSY)
 
 'Размеры в сотых долях миллиметра
 rc.Right = Int(cxWidth *  2540  / iDPIX +  0 . 5 )
 rc.Bottom = Int(cyHeight *  2540  / iDPIY +  0 . 5 )
 
 'Создаём "усовершенствованный" метафайл в памяти и на диске, если дано имя
 hdcMeta = CreateEnhMetaFile(hicRef, EMFFileName, rc, vbNullString)
 
 iWEX = cxWidth * iWidthMM * iDPIX *  10 
 iWEY = cyHeight * iHeightMM * iDPIY *  10 
 iVEX = cxWidth * iWidthPels *  254 
 iVEY = cyHeight * iHeightPels *  254 
 iGCD = GCD(GCD(GCD(iWEX, iWEY), iVEX), iVEY)
 SetMapMode hdcMeta, MM_ANISOTROPIC
 SetWindowExtEx hdcMeta, iWEX \ iGCD, iWEY \ iGCD, ByVal  0 &
 SetViewportExtEx hdcMeta, iVEX \ iGCD, iVEY \ iGCD, ByVal  0 &
 
 hdcMem = CreateCompatibleDC(hicRef)
 DeleteDC hicRef: hicRef =  0 
 hbmpOld = SelectObject(hdcMem, hBitmap)

 bfBlend.BlendOp = AC_SRC_OVER
 bfBlend.BlendFlags =  0 
 bfBlend.SourceConstantAlpha = bAlpha
 bfBlend.AlphaFormat = AC_SRC_ALPHA
 LSet bfvBlend = bfBlend
 AlphaBlend hdcMeta,  0 ,  0 , cxWidth, cyHeight, _
            hdcMem,  0 ,  0 , cxWidth, cyHeight, bfvBlend.Value

 SelectObject hdcMem, hbmpOld: hbmpOld =  0 
 DeleteDC hdcMem: hdcMem =  0 
 DeleteObject hBitmap: hBitmap =  0 
    
 hEMF = CloseEnhMetaFile(hdcMeta): hdcMeta =  0 
 Set LoadARGBBmpAsEmfPicture = CreateIPictureDispFromHENHMETAFILE(hEMF)
End Function


Public Function CreateIPictureDispFromHENHMETAFILE( _
   ByVal hEMF As Long, _
   Optional ByVal bPictureOwnsHandle As Boolean = True) As IPictureDisp
 Dim IID_IPictureDisp As GUID
 Dim PictDesc As PICTDESCEMF
 With PictDesc
    .cbSizeOfStruct = Len(PictDesc)
    .PictType = PICTYPE_ENHMETAFILE
    .hEMF = hEMF
 End With
 CLSIDFromString StrPtr(IIDSTR_IPictureDisp), IID_IPictureDisp
 OleCreatePictureIndirect PictDesc, IID_IPictureDisp, -bPictureOwnsHandle, _
                          CreateIPictureDispFromHENHMETAFILE
End Function


Public Function GCD(ByVal a As Long, ByVal b As Long) As Long
 Do While (a <>  0 ) And (b <>  0 )
    If a >= b Then a = a Mod b Else b = b Mod a
 Loop
 GCD = a + b
End Function