AW: Bildgrößen über Bildpfad
10.03.2015 06:48:12
Hajo_Zi
Hallo Stefan,
mit VBA geht das schon.
Option Explicit ' Variablendefinition erforderlich
'* erstellt von Nepumuk *
'* http:// _
www.online-excel.de/fom/fo_read.php?f=1&bzh=1259&h=1256&ao=1#a123x
Public DoHohe As Double ' Bildhöhe Original
Public DoBreite As Double ' Bildbreite Original
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 GetDeviceCaps Lib "GDI32.dll" ( _
ByVal hDC As Long, _
ByVal nIndex 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 Const LOGPIXELSX = 88&
Private Const LOGPIXELSY = 90&
Private Const HimetricInch = 2540&
Sub Auslesen()
Bildgroesse_auslesen "C:\Test.jpg"
End Sub
Sub Bildgroesse_auslesen(strPicturePath As String)
Dim MyPicture As StdPicture
' Dim dblPixelX As Long, dblPixelY As Long
Set MyPicture = LoadPicture(strPicturePath)
' es wird nur die Höhe benötigt für Faktor
' dblPixelX = HimetricToPixelsX(MyPicture.Width)
' dblPixelY = HimetricToPixelsY(MyPicture.Height)
DoBreite = HimetricToPixelsX(MyPicture.Width)
DoHohe = HimetricToPixelsY(MyPicture.Height)
' MsgBox "Breite in Pixel " & CStr(dblPixelX) & vbLf & _
' "Höhe in Pixel " & CStr(dblPixelY)
' MsgBox "Breite in Zoll " & CStr(dblPixelX / 72) & vbLf & _
' "Höhe in Zoll " & CStr(dblPixelY / 72)
' MsgBox "Breite in mm " & CStr(dblPixelX * 0.352777777777778) & vbLf & _
' "Höhe in mm " & CStr(dblPixelY * 0.352777777777778)
Set MyPicture = Nothing
End Sub
Function HimetricToPixelsX(ByVal inHimetric As Long) As Long
HimetricToPixelsX = ConvertPixelHimetric(inHimetric, True, True)
End Function
Function HimetricToPixelsY(ByVal inHimetric As Long) As Long
HimetricToPixelsY = ConvertPixelHimetric(inHimetric, True, False)
End Function
Function ConvertPixelHimetric(ByVal inValue As Long, _
ByVal ToPix As Boolean, inXAxis As Boolean) As Long
Dim TempIC As Long, GDCFlag As Long
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