|
Если возникла задача перебрать все изображения в указанной папке,
то можно воспользоваться предыдущей
заметкой и перебрать все файлы
в папке и сравнивать расширение файла с заранее составленным списком
расширений файлов-изображений. Можно также сразу явно указать в
макросе все интересующие нас расширения файлов и перебирать только
перечисленные. А если в папке наличествует только один тип файлов, то и
перечислять ничего не нужно, т.к. достаточно будет указать необходимый.
Но если типов много, причём могут встречаться "экзотические"
и редко используемые типы, например, .emf, .wmf, .tiff и т.д., то
можно, по незнанию, что-то пропустить и остаться без отчёта.
Поэтому, имеет смысл ориентироваться не на разрешение файла,
а на его свойства.
И если Вы являетесь обладателем руссифицированной
версии Windows, то можете выполнить нижеопубликованный макрос
и получить результат в байтах.
| Private Sub SizeAllImageFiles() 'Только для руссиф. версии Windows
Dim iPath, iSize, iFolder As Object, iFolderItem As Object
iPath = "C:\Users\Public\Pictures": iSize = 0
Set iFolder = CreateObject("Shell.Application").Namespace(iPath)
If Not iFolder Is Nothing Then
For Each iFolderItem In iFolder.Items
If iFolder.GetDetailsOf(iFolderItem, 11) = "Изображение" Then
iSize = iSize + iFolderItem.Size
'iSize = iSize + FileLen(iFolderItem.Path)
End If
Next
MsgBox iSize & " байт", , ""
End If
End Sub |
А если возникнет необходимость в создании списка таких
файлов-изображений, то :
| Private Sub Create_ListSizeAllImages() 'Только для руссиф. версии Windows
Dim iPath, iSize, iRow&: iSize = 0: iRow = 2
Dim iFolder As Object, iFolderItem As Object
iPath = "C:\Users\Public\Pictures"
Set iFolder = CreateObject("Shell.Application").Namespace(iPath)
If Not iFolder Is Nothing Then
Workbooks.Add xlWBATWorksheet
Range("A1:B1").Font.Bold = True
Range("A1:B1") = Array("Имя файла", "Размер (байт)")
For Each iFolderItem In iFolder.Items
If iFolder.GetDetailsOf(iFolderItem, 11) = "Изображение" Then
Cells(iRow, 1) = iFolderItem.Name
Cells(iRow, 2) = iFolderItem.Size
iSize = iSize + iFolderItem.Size
'iSize = iSize + FileLen(iFile.Path)
iRow = iRow + 1
End If
Next
Columns("A:B").AutoFit 'Range("A:B").Columns.AutoFit
Cells(1, 3) = iSize 'Range("C1").Formula = "=SUM(B:B)"
End If
End Sub |
или
| Private Sub Create_ListSizeAllImages2() 'Только для руссиф. версии Windows
Dim iPath$, iRow&, iSize: iSize = 0
Dim iFolder As Object, iFolderItem As Object
iPath = "C:\Users\Public\Pictures"
Set iFolder = CreateObject("Shell.Application").Namespace((iPath))
If Not iFolder Is Nothing Then
ReDim iArr(1 To iFolder.Items.Count, 1 To 2)
For Each iFolderItem In iFolder.Items
If iFolder.GetDetailsOf(iFolderItem, 11) = "Изображение" Then
iRow = iRow + 1
iArr(iRow, 1) = iFolderItem.Name
iArr(iRow, 2) = iFolderItem.Size
iSize = iSize + iFolderItem.Size
'iSize = iSize + FileLen(iFile.Path)
End If
Next
End If
If iRow > 0 Then
Workbooks.Add xlWBATWorksheet
Range("A1:B1").Font.Bold = True
Range("A1:B1") = Array("Имя файла", "Размер (байт)")
Range("A2:B2").Resize(iRow) = iArr
Range("A:B").Columns.AutoFit 'Columns("A:B").AutoFit
Range("C1").Formula = "=SUM(B:B)" 'Range("C1") = iSize
End If
End Sub |
И, наконец, если Вы решите узнать какие именно типы файлов
занимают место в указанной папке, то для этого можно выполнить
другой макрос.
| Private Sub Create_ListSizeAllTypes3()
Dim iArchive As Object, iRow&, iType$, iPath
Dim iFolder As Object, iFolderItem As Object
iPath = Application.Path '"C:\Users\Администратор\Downloads"
If Dir(iPath, vbDirectory) = "" Then Exit Sub
Set iFolder = CreateObject("Shell.Application").Namespace(iPath)
Set iArchive = CreateObject("Scripting.Dictionary")
For Each iFolderItem In iFolder.Items
If Not iFolderItem.IsFolder Then
iType = iFolderItem.Type
iArchive(iType) = iArchive(iType) + iFolderItem.Size
End If
Next
iRow = iArchive.Count: If iRow = 0 Then Exit Sub
Workbooks.Add xlWBATWorksheet
Range("A1:B1").Font.Bold = True
Range("A1:B1") = Array("Тип файла", "Общий размер (байт)")
Range("A2").Resize(iRow) = Application.Transpose(iArchive.Keys)
Range("B2").Resize(iRow) = Application.Transpose(iArchive.Items)
Range("A:B").Sort Cells(1, 2), xlDescending, Header:=xlYes
Range("A:B").Columns.AutoFit 'Columns("A:B").AutoFit
End Sub |
Автор : Климов Павел Юрьевич
|
|
© 2004-2020 Климов П.Ю. Все права защищены. |
WebDesign & Error's
Klimoff
|