Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Размеры изображений в пикселях
 
#1
21.04.2021 14:56:15
Всем привет!

Прошу помощи разобраться с кодом.

В папке находятся изображения, с которых мне необходимо достать информацию об их размерах "100х100". Всё работает, но только информация неправдоподобная. Если, например, размер изображения 1575 на 1181, то эксель пишет 612 на 459
Код
Sub DateiInfos()
Dim objFSO         As Object
Dim objOrdner      As Object
Dim objDatei       As Object
Dim i              As Integer
Dim pic            As Picture

'Hier Pfad anpassen

Const Pfad = "C:\Users\alexa\Desktop\files\BK\Hauptbilder\"

i = 2
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objOrdner = objFSO.GetFolder(Pfad)

With ThisWorkbook.Worksheets("Tabelle3")
    .Range("A1:E3000").ClearContents
    .Range("A1:C1") = Array("Name", "Breite", "Hцhe")
     
On Error Resume Next
   
    For Each objDatei In objOrdner.Files
    Set pic = .Pictures.Insert(Pfad & objDatei.Name)
        .Cells(i, 1) = objDatei.Name
        .Cells(i, 2) = pic.Width
        .Cells(i, 3) = pic.Height
        i = i + 1
    Next
    .Pictures.Delete
    .Columns("A:C").AutoFit
End With
End Sub
Благодарю!
 
 
 
#2
21.04.2021 15:17:45
Попробуйте что-то вроде этого:
Код
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 = "Ширина :" & lWidth & "; " & "Высота :" & lHeight
End Function
вызывать функцию из Вашего кода так:
Код
s = GetPictureSize(Pfad, objDatei.Name)
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#3
21.04.2021 15:41:33
Дмитрий(The_Prist) Щербаков,

а как вызвать функцию из моего кода?
Код
s = GetPictureSize(Pfad, objDatei.Name)
Куда его вставить?
 
 
 
#4
21.04.2021 16:57:32
Я думал, что минимальные переделки кода Вы сможете сделать :)
По сути Вам тогда надо делать так:
Код
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\alexa\Desktop\files\BK\Hauptbilder\"
 
i = 2
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objOrdner = objFSO.GetFolder(Pfad)
 
With ThisWorkbook.Worksheets("Tabelle3")
    .Range("A1:E3000").ClearContents
    .Range("A1:C1") = Array("Name", "Breite", "Höhe")
      
    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
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#5
21.04.2021 17:12:13
Дмитрий(The_Prist) Щербаков,

Большущее спасибо!
 
 
 
Страницы: 1
Наверх