Klasörde bulunan .jpg dosyaların adlarının yanındaki hücrelere en ve boylarının yazdırılması

[Tevfik_Kursun]

Merhaba Arkadaşlar,
Bir klasörde bulunan .jpg dosyaların adları A1 den itibaren A sütununda iken boyutlarını pixel olarak enini B1 e boyunu C1 ye yazdırmak istiyorum.
Saygılarımla

 

[Haluk]

Aşağıdaki kod, bilgisayarda C:\TestFolder klasörünün içindeki "jpg" uzantili dosyaların adlarını A sütununa, pixel cinsinden en ve boylarını B ve C sütunlarındaki hücrelere yazar....

Sub Test()
'   Haluk - 12/06/2021
'   sa4truss@gmail.com
'   https://excelhaluk.blogspot.com/
    Dim FSO As Object, strFolder As Object, strFile As Object, wia As Object
    Dim i As Long
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set strFolder = FSO.GetFolder("C:\TestFolder")

    On Error Resume Next
        Set wia = CreateObject("WIA.ImageFile")
        If wia Is Nothing Then
            MsgBox "Windows Image Acquisition bulunamadı....."
            Exit Sub
        End If
    On Error GoTo 0
    
    Range("A2:C" & Rows.Count) = ""
    i = 1
    
    For Each strFile In strFolder.Files
        If UCase(FSO.GetExtensionName(strFile)) = "JPG" Then
            i = i + 1
            Range("A" & i) = FSO.GetBaseName(strFile.Name)
            wia.LoadFile strFile
            Range("B" & i) = wia.Width
            Range("C" & i) = wia.Height
        End If
    Next
    
    Set wia = Nothing
    Set strFolder = Nothing
    Set FSO = Nothing
End Sub

.

 

[Tevfik_Kursun]

Sayın Haluk Hocam,
Çok teşekkür ederim.
Saygılarımla