Доброго времени суток! Помогите дополнить код, в котором уже есть возможность вывести в Эксель высоту и ширину каждой картинки, которая находится в папке. Теперь необходимо также вывести информацию о размере самих файлов
Код выглядит следующим образом:
Код
Function GetPictureSize(sPath As String, sFileName As String)
Dim objFile As Object, sPictureSize As String, sFS As String, sLS As String
Dim lWidth As Long, lHeight As Long
Set objFile = CreateObject("Shell.Application").Namespace(CVar(sPath)).ParseName(sFileName)
sPictureSize = objFile.ExtendedProperty("Dimensions")
sFS = Left$(sPictureSize, 1)
sLS = Right$(sPictureSize, 1)
sPictureSize = Mid$(sPictureSize, 2, Len(sPictureSize) - 2)
lWidth = Val(sPictureSize)
lHeight = Val(Mid$(sPictureSize, InStr(sPictureSize, "x") + 1))
GetPictureSize = Array(lWidth, lHeight)
End Function
Sub DateiInfos()
Dim objFSO As Object
Dim objOrdner As Object
Dim objDatei As Object
Dim i As Integer
Dim pic As Picture
Dim aPicSize
'Hier Pfad anpassen
Const Pfad = "C:\Users\Computer\Desktop\DONT TOUCH\sit_bilder\"
i = 2
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objOrdner = objFSO.GetFolder(Pfad)
With ThisWorkbook.Worksheets("Tabelle1")
.Range("A1:C1") = Array("Name", "Breite", "Hohe")
On Error Resume Next
For Each objDatei In objOrdner.Files
.Cells(i, 1) = objDatei.Name
aPicSize = GetPictureSize(Pfad, objDatei.Name)
.Cells(i, 2) = aPicSize(0)
.Cells(i, 3) = aPicSize(1)
i = i + 1
Next
.Columns("A:C").AutoFit
End With
End Sub
Function GetPictureSize(sPath As String, sFileName As String)
Dim objFile As Object, sPictureSize As String, sFS As String, sLS As String
Dim lWidth As Long, lHeight As Long, lSize As Long
Set objFile = CreateObject("Shell.Application").Namespace(CVar(sPath)).ParseName(sFileName)
sPictureSize = objFile.ExtendedProperty("Dimensions")
sFS = Left$(sPictureSize, 1)
sLS = Right$(sPictureSize, 1)
sPictureSize = Mid$(sPictureSize, 2, Len(sPictureSize) - 2)
lWidth = Val(sPictureSize)
lHeight = Val(Mid$(sPictureSize, InStr(sPictureSize, "x") + 1))
lSize = Val(objFile.Size) ' получаем размер
GetPictureSize = Array(lWidth, lHeight, lSize)
End Function
Sub DateiInfos()
Dim objFSO As Object
Dim objOrdner As Object
Dim objDatei As Object
Dim i As Integer
Dim pic As Picture
Dim aPicSize
'Hier Pfad anpassen
Const Pfad = "C:\Users\Computer\Desktop\DONT TOUCH\sit_bilder\"
i = 2
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objOrdner = objFSO.GetFolder(Pfad)
With ThisWorkbook.Worksheets("Tabelle3")
.Range("A1:D1") = Array("Name", "Breite", "Hohe", "Size")
On Error Resume Next
For Each objDatei In objOrdner.Files
.Cells(i, 1) = objDatei.Name
aPicSize = GetPictureSize(Pfad, objDatei.Name)
.Cells(i, 2) = aPicSize(0)
.Cells(i, 3) = aPicSize(1)
.Cells(i, 4) = aPicSize(2)
i = i + 1
Next
.Columns("A:C").AutoFit
End With
End Sub