Daten einlesen 03.02.2007 09:24:00 Franka Hallo zusammen, Wie kann ich per VBA Höhe und Breite von jpg.-Bildern eines Ordners in eine Excelliste einlesen, ohne die Bilder zu öffnen. Vielen Dank aus Bremen Franka
AW: Daten einlesen 03.02.2007 09:40:51 Josef Hallo Franka, probier mal. ' **********************************************************************' Modul: Modul1 Typ: Allgemeines Modul' **********************************************************************Option Explicit'Code aus "Online Excel Forum" - http://www.online-excel.de/'Postet by Nepumuk, 20/06/05'Geändert von J.Ehrensberger 08/02/06Private 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 LongPrivate Declare Function DeleteDC Lib "GDI32.dll" ( _ ByVal hDC As Long) As LongPrivate Declare Function GetDeviceCaps Lib "GDI32.dll" ( _ ByVal hDC As Long, _ ByVal nIndex As Long) As LongPrivate Declare Function MulDiv Lib "Kernel32.dll" ( _ ByVal nNumber As Long, _ ByVal nNumerator As Long, _ ByVal nDenominator As Long) As LongPrivate Const LOGPIXELSX = 88&Private Const LOGPIXELSY = 90&Private Const HimetricInch = 2540&Public Function GetImageSize(ByVal strPicturePath As String, ByRef dblWidth As Double, ByRef dblHeight As Double) As Long Dim MyPicture As StdPicture On Error GoTo ErrExit Set MyPicture = LoadPicture(strPicturePath) If Not MyPicture Is Nothing Then GetImageSize = -1 dblWidth = HimetricToPixelsX(MyPicture.Width) dblHeight = HimetricToPixelsY(MyPicture.Height) End If ErrExit: Err.Clear On Error GoTo 0 Set MyPicture = NothingEnd FunctionPrivate Function HimetricToPixelsX(ByVal inHimetric As Long) As Long HimetricToPixelsX = ConvertPixelHimetric(inHimetric, True, True)End FunctionPrivate Function HimetricToPixelsY(ByVal inHimetric As Long) As Long HimetricToPixelsY = ConvertPixelHimetric(inHimetric, True, False)End FunctionPrivate 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 IfEnd Function'#Public Sub Test() Dim w As Double, h As Double Dim objFS As FileSearch Dim strPath As String Dim intIndex As Integer strPath = "C:\Dokumente und Einstellungen\Admin\Eigene Dateien\Eigene Bilder\Misc" 'Pfadanpassen! Set objFS = Application.FileSearch With objFS .NewSearch .LookIn = strPath .Filename = "*.jpg" .SearchSubFolders = False If .Execute > 0 Then For intIndex = 1 To .FoundFiles.Count GetImageSize .FoundFiles(intIndex), w, h Cells(intIndex + 1, 1) = .FoundFiles(intIndex) Cells(intIndex + 1, 2) = w Cells(intIndex + 1, 3) = h Next End If End With Set objFS = Nothing End Sub Gruß Sepp Anzeige
AW: Daten einlesen 03.02.2007 14:22:45 Franka Hallo Sepp, Super, genau das ist es. Vielen Dank. Franka