TopPicLogo TopPicText

Изображения - Размеры в пикселах

По материалам: http://www.sql.ru/forum/586161/pikselnyy-razmer-picture#6072686
"Бенедикт" - E -Mail: sgorbunkov@yandex.ru

Проверил на JPG = Работает!

'modPictureSizeInPixels
'Размеры изобржения в ПИКСЕЛАХ
'--------------------------------------------------------------------
'http://www.sql.ru/forum/actualthread.aspx?tid=586161#6072686
'"Бенедикт" - E -Mail: sgorbunkov@yandex.ru
'--------------------------------------------------------------------
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Const LOGPIXELSX = 88        '  Logical pixels/inch in X
Private Const LOGPIXELSY = 90        '  Logical pixels/inch in Y

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 DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long

Private Const HimetricPerInch = 2540

Private Sub Test()
    Dim hicRef As Long
    Dim Pic As StdPicture
    Dim W As Long, H As Long
    Set Pic = LoadPicture("C:\Test.jpg")
 
    hicRef = CreateIC("DISPLAY", vbNullString, vbNullString, ByVal 0&)
    W = Pic.Width * GetDeviceCaps(hicRef, LOGPIXELSX) / HimetricPerInch
    H = Pic.Height * GetDeviceCaps(hicRef, LOGPIXELSY) / HimetricPerInch
    DeleteDC hicRef
    Debug.Print W, H
End Sub

Public Function esPicSizeInPixelsX(ByRef Pic As StdPicture) As Long
    Dim hicRef As Long
    hicRef = CreateIC("DISPLAY", vbNullString, vbNullString, ByVal 0&)
    esPicSizeInPixelsX = Pic.Width * GetDeviceCaps(hicRef, LOGPIXELSX) / HimetricPerInch
    DeleteDC hicRef
   
End Function
Public Function esPicSizeInPixelsY(ByRef Pic As StdPicture) As Long
    Dim hicRef As Long
    hicRef = CreateIC("DISPLAY", vbNullString, vbNullString, ByVal 0&)
    esPicSizeInPixelsY = Pic.Height * GetDeviceCaps(hicRef, LOGPIXELSY) / HimetricPerInch
    DeleteDC hicRef
End Function


Achtung!
Требуется ссылка на библиотеку: OLE Automation

Назад ToTop
L.E. 26.08.2017
Рейтинг@Mail.ru