Cotrollo dimensioni immagini

[nicola_na78]

Salve a tutti, mi dite se è possibile fare con una macro excel la seguente cosa: vorrei che controllando tutte le immagini presenti nella cartella "Immagini" nella colonna "A" mi restituisca il nome dell'immagine e nella colonna "B" la dimensione.
Es. rigo 1: immagine1.jpg 800x800pixel


Grazie, buona domenica

[alfrimpa]

Codice: Seleziona tutto

Ciao Nicola

Inserisci questa macro in un modulo standard

Codice: Seleziona tutto

Sub prova()
Dim strFile As String
    Dim stdPic As StdPicture
    Dim lngWidth As Long
    Dim lngHeight As Long
    Dim strPath As String
    Dim intRow As Integer
    strPath = "c:\prova" '<==== Modifica con tua directoy
    strFile = Dir$(strPath & "\*.jpg") '
    Do While Len(strFile)
        Set stdPic = LoadPicture(strPath & "\" & strFile)
        intRow = intRow + 1
        Range("A" & intRow).Value = strFile
        Range("B" & intRow).Value = Round(stdPic.Width / 26.4583)
        Range("C" & intRow).Value = Round(stdPic.Height / 26.4583)
        strFile = Dir$
    Loop
End Sub

[alfrimpa]

Io ho supposto che tutte le immagini abbiano estensione ".jpg".

Se così non è la macro va modificata.

[recalcatiiti]

Ciao Alfredo,

siccome interessa anche a me, mi potresti dire come modificheresti la macro se volessi controllare tutti i formati?

Grazie

[alfrimpa]

Credo sia sufficiente modificare questa istruzione

Codice: Seleziona tutto

strFile = Dir$(strPath & "\*.jpg")

in

Codice: Seleziona tutto

strFile = Dir$(strPath & "\*.*")

Ovviamente nella directory ci devono essere solo file immagine.

[nicola_na78]

Grazie Alfredo... Provo subito la macro.... Buona serata

[recalcatiiti]

Ciao, grazie molte, e se ci fossero anche altri files? C'è modo semplice per estrarre solo il nome delle immagini nei formati "più comuni"?

Grazie a chiunque darà risposta

Ciao a tutti

[Anthony47]

Modifica come segue:

Codice: Seleziona tutto

strPath = "c:\prova" '<==== Modifica con tua directoy
allpics = Array("*.jpg", "*.png", "*.gif")   '<<< Altri formati?       '***
For Each itm In allpics                                                '***
    strFile = Dir$(strPath & "\" & itm) '                              '***
    Do While Len(strFile)
        Set stdPic = LoadPicture(strPath & "\" & strFile)
        intRow = intRow + 1
        Range("A" & intRow).Value = strFile
        Range("B" & intRow).Value = Round(stdPic.Width / 26.4583)
        Range("C" & intRow).Value = Round(stdPic.Height / 26.4583)
        strFile = Dir$
    Loop
Next itm                                                              '***


Le parti aggiunte o modificate sono marcate ***

Ciao

[recalcatiiti]

Grazie Anthony!

a presto, ciao.

[recalcatiiti]

Ciao a tutti, provo ad alzare un po' (tanto) la posta.

se non volessi limitarmi alla sola cartella, ma anche a tutte le sotto cartelle e ad eventuali sotto-...-sotto-cartelle?

In sostanza: è possibile elencare tutte le immagini del mio hard disk (con relative dimensioni e peso in kb) in un colpo solo senza modificare il percorso? Mi sembra infattibile ma sarebbe fantastico.

Grazie e ciao.

[cromagno]

Ciao a tutti, provo ad alzare un po' (tanto) la posta.

se non volessi limitarmi alla sola cartella, ma anche a tutte le sotto cartelle e ad eventuali sotto-...-sotto-cartelle?

In sostanza: è possibile elencare tutte le immagini del mio hard disk (con relative dimensioni e peso in kb) in un colpo solo senza modificare il percorso? Mi sembra infattibile ma sarebbe fantastico.

Grazie e ciao.

Ciao a tutti,
@recaltiiti
tu hai provato qualcosa?

Dopo la tua ultima domanda su Eulero mi aspetto qualche tua iniziativa

[recalcatiiti]

Ciao cromagno,

francamente non ne ho la più pallida idea.
Tu invece? Che sei un vero asso con il linguaggio, ne hai qualcuna?

Ciao e a presto

[Anthony47]

Scusate se mi intrometto
Non ho tempo per elaborare una "soluzione", pero' vi lascio il componente che dovrebbe risolvere, e cioe' questa Funzione che dovrebbe popolare la matrice di tutti i file "immagine" presente nella directory di partenza e tutte le sue subdir. Il codice, da inserire in testa al modulo vba che contiene la Sub prova:

Codice: Seleziona tutto

Dim myFso As Object, ccAll As Long    'RIGOROSAMENTE IN TESTA AL MODULO
Function RecurDir(ByVal ccDir As String, myExt As Variant, ByRef cStore As Variant) As String
Dim myItm
'
If myFso Is Nothing Then Set myFso = CreateObject("Scripting.FileSystemObject")
If myFso Is Nothing Then Beep
DoEvents
On Error GoTo Mahh
For Each myItm In myFso.GetFolder(ccDir).Files
ccAll = ccAll + 1
    mysplit = Split(" " & myItm, ".", , vbTextCompare)
    If Not IsError(Application.Match(mysplit(UBound(mysplit)), myExt, 0)) Then
        myind = UBound(cStore)
        ReDim Preserve cStore(1 To myind + 1)
        cStore(myind) = myItm
    End If
Mahh:
Resume Bohh
Bohh:
Next myItm
For Each myItm In myFso.GetFolder(ccDir).SubFolders
    Call RecurDir(myItm, myExt, cStore)
Next myItm
End Function


La function va richiamata all'inizio della Sub prova, con queste istruzioni:

Codice: Seleziona tutto

Dim FArr() As String
ReDim FArr(1 To 1)
allpics = Array("jpg", "png", "gif")    '<<< Altri formati?       '***
StrDir=" C:\PERCORSO\Documents"         '<<< Il Percorso iniziale
Call RecurDir(StrDir, allpics, FArr)


La RecurDir compilera' la matrice FArr con tutti i files che hanno una extension pari a quelle dichiarate in "allpics".
Il restante codice della Sub prova dovra' lavorare uno per uno sui file contenuti in FArr; dovrebbe essere sufficiente qualcosa come

Codice: Seleziona tutto

For I=1 to ubound(FArr)
    If len(fArr(i)>0 then
'qui le istruzioni prima inserite nel Do While /Loop
    End If
Next I


Attenzione, che scandire tutto il disco potrebbe richiedere "il suo tempo", quindi meglio partire con una directory dal contenuto modesto

Provate, e se vi arenate spiegate dove e come...

[recalcatiiti]

Tu non ti intrometti mai e grazie per la risposta.

Bah... Io ci provo, sicuramente c'è qualche errore banale che non vedo date le mie scarse conoscenze.

Seguendo le tue indicazioni ( e abbandonandomi all'interpretazione spregiudicata ) è uscita questa cosa:

Codice: Seleziona tutto

Dim myFso As Object, ccAll As Long    'RIGOROSAMENTE IN TESTA AL MODULO
Function RecurDir(ByVal ccDir As String, myExt As Variant, ByRef cStore As Variant) As String
Dim myItm
'
If myFso Is Nothing Then Set myFso = CreateObject("Scripting.FileSystemObject")
If myFso Is Nothing Then Beep
DoEvents
On Error GoTo Mahh
For Each myItm In myFso.GetFolder(ccDir).Files
ccAll = ccAll + 1
    mysplit = Split(" " & myItm, ".", , vbTextCompare)
    If Not IsError(Application.Match(mysplit(UBound(mysplit)), myExt, 0)) Then
        myind = UBound(cStore)
        ReDim Preserve cStore(1 To myind + 1)
        cStore(myind) = myItm
    End If
Mahh:
Resume Bohh
Bohh:
Next myItm
For Each myItm In myFso.GetFolder(ccDir).SubFolders
    Call RecurDir(myItm, myExt, cStore)
Next myItm
End Function
Sub prova()
Dim strFile As String
    Dim stdPic As StdPicture
    Dim lngWidth As Long
    Dim lngHeight As Long
    Dim strPath As String
    Dim intRow As Integer
Dim FArr() As String
ReDim FArr(1 To 1)
allpics = Array("jpg", "png", "gif")    '<<< Altri formati?       '***
StrDir = "c:\prova"       '<<< Il Percorso iniziale
Call RecurDir(StrDir, allpics, FArr)
For Each itm In allpics                                                '***
    strFile = Dir$(strPath & "\" & itm) '                              '***
   For i = 1 To UBound(FArr)
    If Len(FArr(i)) > 0 Then
Set stdPic = LoadPicture(strPath & "\" & strFile) '<--------------------
        intRow = intRow + 1
        Range("A" & intRow).Value = strFile
        Range("B" & intRow).Value = Round(stdPic.Width / 26.4583)
        Range("C" & intRow).Value = Round(stdPic.Height / 26.4583)
        strFile = Dir$
    End If
Next i
Next itm
End Sub

che va in debug alla riga contrassegnata con '<-------------------- riportando l'errore: run-time 76 impossibile trovare il percorso.

Chiaramente in fase di test ho inserito un percorso valido ed esistente.

Aspetto cromagno con la sua interpretazione e aspetto trepidante la tua Anthony

Ciao, grazie e a presto.

[Anthony47]

Eh, tutto bene fino a "End Function", poi....

Ecco una versione piu' canonica e con in piu' una fase di gestione di eventuali errori in fase di LoadPicture; nelle mie prove infatti mi son trovato con delle immagini che davano errore

Codice: Seleziona tutto

Sub prova()
Dim strFile As String
    Dim stdPic As StdPicture
    Dim lngWidth As Long
    Dim lngHeight As Long
    Dim strPath As String
    Dim intRow As Integer
Dim FArr() As String
ReDim FArr(1 To 1)
allpics = Array("jpg", "png", "gif")    '<<< Altri formati?       '***
StrDir = "c:\prova"       '<<< Il Percorso iniziale
Call RecurDir(StrDir, allpics, FArr)
For i = 1 To UBound(FArr)
    If Len(FArr(i)) > 0 Then
        intRow = intRow + 1
        Range("A" & intRow).Value = FArr(i)
On Error GoTo piPP
        Set stdPic = LoadPicture(FArr(i)) '<--------------------
        Range("B" & intRow).Value = Round(stdPic.Width / 26.4583)
        Range("C" & intRow).Value = Round(stdPic.Height / 26.4583)
'        strFile = Dir$
piPP:
Resume poPP
poPP:
    End If
Next i
End Sub


Pero' se si tratta di immagini prodotte da camere prodotte negli ultimi 10 anni le stesse informazioni dovrebbero essere leggibili nelle proprieta' del file, ma oggi non avro' altro tempo per indagare.

Ciao

[recalcatiiti]

Eh, tutto bene fino a "End Function", poi....

Ormai è scontato dire che funzioni alla perfezione.

Se volessi ottenere il percorso in una cella e il nome dell'immagine in un altra, come posso fare? ho smanettato un po' ma non ne vengo a capo... Vorrei anche visualizzare la dimensione del file, ho appreso che si può usare

Codice: Seleziona tutto

FileLen( file_path )

ma non riesco ad integrarlo...

Grazie e ciao.

[Anthony47]

Sarebbe stato meglio farlo sentro la RecurDir, ma non ho tempo per cmbiare la sua struttura dati. Prova con

Codice: Seleziona tutto

Sub prova()
Dim strFile As String
    Dim stdPic As StdPicture
    Dim lngWidth As Long
    Dim lngHeight As Long
    Dim strPath As String
    Dim intRow As Integer
Dim FArr() As String
ReDim FArr(1 To 1)
allpics = Array("jpg", "png", "gif")    '<<< Altri formati?       '***
StrDir = "c:\prova"       '<<< Il Percorso iniziale
Call RecurDir(StrDir, allpics, FArr)
For i = 1 To UBound(FArr)
    If Len(FArr(i)) > 0 Then
        intRow = intRow + 1
        mysplit = Split(FArr(i), "\", , vbTextCompare)
        If UBound(mysplit) > 0 Then Range("B" & intRow).Value = mysplit(UBound(mysplit))
        Range("A" & intRow).Value = Replace(FArr(i), "\" & mysplit(UBound(mysplit)), "\", , , vbTextCompare)
        Range("E" & intRow).Value = myFso.getfile(FArr(i)).Size
On Error GoTo piPP
        Set stdPic = LoadPicture(FArr(i)) '<--------------------
        Range("C" & intRow).Value = Round(stdPic.Width / 26.4583)
        Range("D" & intRow).Value = Round(stdPic.Height / 26.4583)
       
'        strFile = Dir$
piPP:
Resume poPP
poPP:
    End If
Next i
On Error Resume Next
Set myFso = Nothing
On Error GoTo 0
End Sub


[recalcatiiti]

Grazie Anthony, funziona alla perfezione.

Ultima speculazione, prometto. E' possibile eliminare dei file tramite vba? ad esempio, è possibile eliminare le immagini che negli anni, per diversi motivi, ho duplicato e che ora compaiono anche in diverse copie nel mio disco?

Grazie e ciao.

[Anthony47]

Se vuoi ti faccio una macro che cancella un file se nell'elenco ne compare un altro avente stesso nome e stesse dimensioni di file; pero' prima della cancellazione di ogni file, per sicurezza, ne farei due copie di backup su due directory diverse

Ti sembra valido??

[recalcatiiti]

Ciao Anthony, la validità del messaggio precedente non si può neanche quantificare.

Quindi se non è di grande disturbo, e hai tempo e voglia, mi piacerebbe molto.

C'è una piccola questione però... La macro precedente elenca perfettamente tutte le immagini di directory (anche abbastanza grandi), ma se estendo la "ricerca" a tutto il disco C, neanche dopo 38 h, riesce a creare l'elenco... Come mai?

Grazie mille e a presto, ciao!