Option Explicit

'============================== GDI+ declarations ==============================
Private Type GdiplusStartupInput
   GdiplusVersion As Long
   DebugEventCallback As Long
   SuppressBackgroundThread As Long
   SuppressExternalCodecs As Long
End Type

' GDI+ Status
Private Enum GpStatus
   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 Declare Function GdiplusStartup Lib "gdiplus" ( _
   Token As Long, gpsi As GdiplusStartupInput, pvOutput As Any) As GpStatus
Private Declare Sub GdiplusShutdown Lib "gdiplus" ( _
   ByVal Token As Long)

Private Declare Function GdipLoadImageFromFile Lib "gdiplus" ( _
   ByVal pFileName As Long, pImage As Long) As GpStatus
Private Declare Function GdipDisposeImage Lib "gdiplus" ( _
   ByVal pImage As Long) As GpStatus

Private Declare Function GdipGetImageWidth Lib "gdiplus" ( _
   ByVal pImage As Long, nWidth As Long) As GpStatus
Private Declare Function GdipGetImageHeight Lib "gdiplus" ( _
   ByVal pImage As Long, nHeight As Long) As GpStatus
Private Declare Function GdipGetImageHorizontalResolution Lib "gdiplus" ( _
   ByVal pImage As Long, fResolution As Single) As GpStatus
Private Declare Function GdipGetImageVerticalResolution Lib "gdiplus" ( _
   ByVal pImage As Long, fResolution As Single) As GpStatus


Private Function GetPicDimPt(ByVal sFileName As String, _
                             fWidth As Single, fHeight As Single) As GpStatus
 Dim gpsRes As GpStatus
 Dim GdipSession As Long
 Dim gpsi As GdiplusStartupInput
 Dim gpiSrc As Long
 Dim nWidth As Long
 Dim nHeight As Long
 Dim fHorzRes As Single
 Dim fVertRes As Single
 Const PointsPerInch =  72 
 
 fWidth =  0 
 fHeight =  0 
 
 With gpsi
    .GdiplusVersion =  1 
    .DebugEventCallback =  0 
    .SuppressBackgroundThread =  0 
    .SuppressExternalCodecs =  1 
 End With
 
 gpsRes = GdiplusStartup(GdipSession, gpsi, ByVal  0 &)
 If gpsRes <> GpStatus.OK Then
    GetPicDimPt = gpsRes
    MsgBox "GDI+ Initialization Failed", vbCritical
    Exit Function
 End If
 
 gpsRes = GdipLoadImageFromFile(StrPtr(sFileName), gpiSrc)
 If gpsRes <> GpStatus.OK Then
    GetPicDimPt = gpsRes
    MsgBox "Image load failed. Error code " & gpsRes, vbCritical
    GdiplusShutdown GdipSession
    Exit Function
 End If
 
 gpsRes = GdipGetImageWidth(gpiSrc, nWidth)
 If gpsRes = GpStatus.OK Then
    gpsRes = GdipGetImageHeight(gpiSrc, nHeight)
    gpsRes = GdipGetImageHorizontalResolution(gpiSrc, fHorzRes)
    gpsRes = GdipGetImageVerticalResolution(gpiSrc, fVertRes)
    fWidth = nWidth * PointsPerInch / fHorzRes
    fHeight = nHeight * PointsPerInch / fVertRes
 Else
    MsgBox "GdipGetImageDimension() failed. Error code " & gpsRes, vbInformation
 End If
 GetPicDimPt = gpsRes
 
 gpsRes = GdipDisposeImage(gpiSrc)
 GdiplusShutdown GdipSession
End Function


Public Sub Test()
 Dim fn As String
 Dim h As Double
 Dim v As Double
 Dim fWidth As Single
 Dim fHeight As Single

 fn = "F:\DBases\SQL.ru\WordInAccess.png"
 If GetPicDimPt(fn, fWidth, fHeight) = GpStatus.OK Then
 
    h = ActiveCell.Left
    v = ActiveCell.Top
    
    ActiveWorkbook.ActiveSheet.Shapes.AddPicture fn, False, True, _
                                                 h, v, fWidth, fHeight
 End If
End Sub