Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
840to844
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
840to844
840to844
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Daten einlesen

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

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
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/06
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&

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 = Nothing
End Function

Private Function HimetricToPixelsX(ByVal inHimetric As Long) As Long
    HimetricToPixelsX = ConvertPixelHimetric(inHimetric, True, True)
End Function

Private Function HimetricToPixelsY(ByVal inHimetric As Long) As Long
    HimetricToPixelsY = ConvertPixelHimetric(inHimetric, True, False)
End Function

Private 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
'#

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

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige