Moderatori: Anthony47, Flash30005
' 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
ricky53 ha scritto:E' complesso adattare questo codice per un utilizzo con excel: riuscirà il nostro eroe ad uscirne fuori ???
nome dirpath descrizione
DirJPG D:\Immagini\20090815\ direttorio dove cercare i file immagini
Open DirJpg & "lista.cfg" For Input As #1
Do Until EOF(1)
Line Input #1, riga
'etc etc
Torna a Applicazioni Office Windows
Inserire dati filtrati da 2 file ad un terzo file Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 14 |
Perchè l'importazione dati con Selenium non fuziona? Autore: aggittoriu |
Forum: Applicazioni Office Windows Risposte: 7 |
copia di dati da un file chiuso e elaborazione Autore: luca62 |
Forum: Applicazioni Office Windows Risposte: 2 |
Visitano il forum: Nessuno e 26 ospiti