' Questa è la macro da cui partire per individuare le proprietà dei vari file immagine
Sub Dati_File_Scelto()
    MsgBox "Autore David Crowell. Adattamenti e implementazioni di Ricky53"
    
    Percorso = ActiveWorkbook.Path
    Percorso = InputBox("Inserire il nome di un percorso per visualizzare le proprietà delle immagini presenti", "Visualizzazione File", Percorso)
    Tipo = "*.JPG"
    Tipo = InputBox("Inserire il Tipo di file che si vuole visualizzare", "Scelta Tipo File", Tipo)
    Range("A2:h2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("A1").Select
    
    nome = Percorso & "" & Tipo
    f = Dir(nome)
    i = 2
    Cells(i, 1) = f
    Nome_File = f
    nome = Percorso & "" & Nome_File 'f
        If UCase(Mid(Nome_File, Len(Nome_File) - 2, 3)) = "JPG" Or _
             UCase(Mid(Nome_File, Len(Nome_File) - 2, 3)) = "BMP" Or _
             UCase(Mid(Nome_File, Len(Nome_File) - 2, 3)) = "GIF" Or _
             UCase(Mid(Nome_File, Len(Nome_File) - 2, 3)) = "PNG" Then
             
             ReadImageInfo (nome)
             Scrivi_Proprietà
        End If
    Cells(i, 2) = FileDateTime(nome)
    Cells(i, 3) = FileLen(nome)
    Cells(1, 4) = "Tipo Immagine"
    Cells(1, 5) = "Altezza"
    Cells(1, 6) = "Larghezza"
    Cells(1, 7) = "Profondità in bit"
    For i = 3 To 20000
        On Error GoTo continua:
        Cells(i, 1) = Dir
        Nome_File = Cells(i, 1)
        nome = Percorso & "" & Nome_File
        Cells(i, 2) = FileDateTime(nome)
        Cells(i, 3) = FileLen(nome)
        If UCase(Mid(Nome_File, Len(Nome_File) - 2, 3)) = "JPG" Or _
             UCase(Mid(Nome_File, Len(Nome_File) - 2, 3)) = "BMP" Or _
             UCase(Mid(Nome_File, Len(Nome_File) - 2, 3)) = "GIF" Or _
             UCase(Mid(Nome_File, Len(Nome_File) - 2, 3)) = "PNG" Then
             
             ReadImageInfo (nome)
             Scrivi_Proprietà
        End If
    Next i
continua:
End Sub
'..................................
Sub Scrivi_Proprietà()
    Select Case m_ImageType
        Case 1
             Tipo = "GIF"
        Case 2
             Tipo = "JPG"
        Case 3
             Tipo = "PNG"
        Case 4
             Tipo = "BMP"
        Case Else
             Tipo = "N/D"
    End Select
    Cells(i, 4) = Tipo
    Cells(i, 5) = m_Height
    Cells(i, 6) = m_Width
    Cells(i, 7) = m_Depth
End Sub
'..................................
Option Explicit
Private Const BUFFERSIZE As Long = 65535
Public Enum eImageType
    itUNKNOWN = 0
    itGIF = 1
    itJPEG = 2
    itPNG = 3
    itBMP = 4
End Enum
Public m_Width As Long, m_Height As Long, m_Depth As Byte, m_ImageType As eImageType
Public Nome_File As String, Percorso As String, Tipo As String, f As String, nome As String, i As Integer
Public Property Get Width() As Long
    Width = m_Width
End Property
Public Property Get Height() As Long
    Height = m_Height
End Property
Public Property Get Depth() As Byte
    Depth = m_Depth
End Property
Public Property Get ImageType() As eImageType
    ImageType = m_ImageType
End Property

' Autore di questa macro : David Crowell
' Adattamenti effettuati successivamente da: Ricky53
Public Sub ReadImageInfo(sFileName As String)
    Dim bBuf(BUFFERSIZE) As Byte
    Dim iFN As Integer
    
    m_Width = 0
    m_Height = 0
    m_Depth = 0
    m_ImageType = itUNKNOWN
    
    iFN = FreeFile
    Open sFileName For Binary As iFN
    Get #iFN, 1, bBuf()
    Close iFN
    
'PNG ------------------------------------------------------------ -----
    If bBuf(0) = 137 And bBuf(1) = 80 And bBuf(2) = 78 Then
        m_ImageType = itPNG
        Select Case bBuf(25)
             Case 0
                 m_Depth = bBuf(24)
             Case 2
                 m_Depth = bBuf(24) * 3
             Case 3
                 m_Depth = 8
             Case 4
                 m_Depth = bBuf(24) * 2
             Case 6
                 m_Depth = bBuf(24) * 4
             Case Else
                 m_ImageType = itUNKNOWN
        End Select
        If m_ImageType Then
             m_Width = Mult(bBuf(19), bBuf(18))
             m_Height = Mult(bBuf(23), bBuf(22))
        End If
    End If
'GIF ------------------------------------------------------------ -----
    If bBuf(0) = 71 And bBuf(1) = 73 And bBuf(2) = 70 Then
        m_ImageType = itGIF
        m_Width = Mult(bBuf(6), bBuf(7))
        m_Height = Mult(bBuf(8), bBuf(9))
        m_Depth = (bBuf(10) And 7) + 1
    End If
'BMP ------------------------------------------------------------ -----
    If bBuf(0) = 66 And bBuf(1) = 77 Then
        m_ImageType = itBMP
        m_Width = Mult(bBuf(18), bBuf(19))
        m_Height = Mult(bBuf(22), bBuf(23))
        m_Depth = bBuf(28)
    End If
'JPG ------------------------------------------------------------ -----
    If m_ImageType = itUNKNOWN Then
        Dim lPos As Long
        Do
             If (bBuf(lPos) = &HFF And bBuf(lPos + 1) = &HD8 _
                  And bBuf(lPos + 2) = &HFF) _
                  Or (lPos >= BUFFERSIZE - 10) Then Exit Do
             lPos = lPos + 1
        Loop
        lPos = lPos + 2
        If lPos >= BUFFERSIZE - 10 Then Exit Sub
        Do
             Do
                 If bBuf(lPos) = &HFF And bBuf(lPos + 1) _
                <> &HFF Then Exit Do
                 lPos = lPos + 1
                 If lPos >= BUFFERSIZE - 10 Then Exit Sub
             Loop
             lPos = lPos + 1
             Select Case bBuf(lPos)
                 Case &HC0 To &HC3, &HC5 To &HC7, &HC9 To &HCB, _
                 &HCD To &HCF
                     Exit Do
             End Select
             lPos = lPos + Mult(bBuf(lPos + 2), bBuf(lPos + 1))
             If lPos >= BUFFERSIZE - 10 Then Exit Sub
        Loop
        m_ImageType = itJPEG
        m_Height = Mult(bBuf(lPos + 5), bBuf(lPos + 4))
        m_Width = Mult(bBuf(lPos + 7), bBuf(lPos + 6))
        m_Depth = bBuf(lPos + 8) * 8
    End If
End Sub
Private Function Mult(lsb As Byte, msb As Byte) As Long
    Mult = lsb + (msb * CLng(256))
End Function