Cotrollo dimensioni immagini

[Anthony47]

Spero che nel frattempo la macro sia arrivata a una qualche conclusione....

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

Eh eh, secondo me hai letto male la mia proposta: sono disponibile a cancellare tutti i file che vuoi, ma prima te ne faccio sul dico, di ognuno, due copie di backup...

Se insisti io procedo, neh?

[recalcatiiti]

Guarda se il backup me lo fai tutto nella stessa cartella, per sicurezza, a me non va benissimo l'importante è che le maledette copie sparse per il disco scompaiono per sempre

Per quanto riguarda la macro precedente ti dico no, non ha prodotto nulla nel frattempo, programma bloccato per 38 ore.. Ho quittato e neppure il file rigenerato conteneva niente... Bah, non saprei.. Tu suggerisci qualcosa?

Ciao e grazie

[recalcatiiti]

Ciao Anthony, non voglio mettere fretta o pretendere qualcosa, ma non c'è nessuna nuova notizia?

Grazie e ciao.

[Anthony47]

Guarda, ti propongo una modalita' di lavoro solo perche' insisti, e spero di non vederti piangere in cinese se per errore si vanno a cancellare immagini non tue (es di applicazioni, presentazioni, raccolte) o che in ogni caso non dovrebbero essere cancellate; e comunque sappi che non parlo cinese

Cio' detto...
Ho leggermente rivisto il codice gia' in tuo possesso che crea l'elenco dei file immagine, come segue:

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, mySplit
    Dim intRow As Integer, AllPics, StrDir As String, I As Long
'
Sheets("Foglio1").Select
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 = Cells(Rows.Count, 1).End(xlUp).Row + 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)
piPP:
Resume poPP
poPP:
    End If
Next I
On Error Resume Next
Set myFso = Nothing
On Error GoTo 0
MsgBox ("Elenco completato...")
End Sub


Metti questo codice in un file nuovo, contenente almeno Foglio1 e Foglio2 vuoti, in un Modulo Standard del vba. Le istruzioni marcate <<< sono da personalizzare.

A questo punto:
1) Lancia la Sub Prova cosi' modificata facendola lavorare esclusivamente sulle directory di tua proprieta', evitando quindi percorsi che potrebbero essere comuni ad applicazioni o sistema operativo.
Puoi eseguire piu' volte la Sub Prova, dichiarando volta per volta una directory diversa, e gli elenchi saranno accodati a quanto gia' preesistente. Se vuoi ripartire da zero devi azzerare manualmente l'elenco di Foglio1

In questo modo creerai su Foglio1 un elenco di directory ed immagini presenti sul disco nelle aree di tua proprieta'.

2) Creati sempre in Foglio1, nell'area da P1 verso il basso, un elenco di Percorsi da proteggere; l'elenco serve a dichiarare i percorsi il cui contenuto, in caso di duplicati, deve essere mantenuto. In pratica in questo modo il duplicato sara' cancellato solo dalle directory non dichiarate protette.
ATTENZIONE: il nome indicato in colonna P deve essere esattamente uguale a un nome presente in colonna A; puo' essere utile controllare l'esattezza "formale" di quanto digitato usando in O1 la formula

Codice: Seleziona tutto

=CONTA.SE(A:A;P1)

Da copiare poi verso il basso.
Errori formali saranno indicati dal risultato "0"; errori sostanziali saranno indicati dal pianto cinese finale.
L'elenco di colonna P puo' essere lungo a piacere, ma deve essere lungo almeno 10 righe; eventualmente (se vuoi dichiararne meno di 10) ripeti piu' volte la stessa directory.

3) Creati su disco una directory C:\ZC_PROTEZ (puoi usare anche un altro drive, purche' sia un disco con formattazione NTFS; non un drive usb perche' non lo ritengo affidabile). Sara' usata come directory di sicurezza nella successiva fase 4

4) Infine ecco la parte che cancella i duplicati; in realta' non li cancella, ma li rimuove dalla directory di posizionamento originale e li sposta nella nuova directory di sicurezza; eventualmente i file sono rinominati per evitare conflitti di nomi duplicati, usando come "prefisso" il timer di sistema.
Contemporaneamente sara' creato in Foglio3 l'elenco di questi spostamenti; l'elenco comprendera':
-tutte le informazioni contenute su foglio1 (directory, nome file, dimensione immagine, dimensione file) e il nome con cui il file e' presente sulla directory di sicurezza (sia che il nome sia mantenuto che sia stato modificato).
-il NomeFile sara' modificato nell'elenco di Foglio1, aggiungendo il prefisso "**_", a indicare la sua rimozione
Il codice:

Codice: Seleziona tutto

Sub FileRemover()
Dim Occorr As Long, LR As Long, myProt As Range, Rispo As String, protYn, mFiles As Long
Dim Secur As String, myCK As String, I As Long, cFile As String, myTO As Single, myTO2 As Single
'
Secur = "C:\ZC_PROTEZ"                  '<<< La directory di sicurezza per i file rimossi
'
Sheets("Foglio1").Select
Set myProt = Range(Range("P1"), Range("P" & Rows.Count).End(xlUp).Offset(1, 0))
If myProt.Rows.Count < 10 Then
    MsgBox ("L'elenco dei Percorsi protetti e' troppo corto; l'operazione verra' abortita")
    Exit Sub
End If
Rispo = Application.InputBox("Se sei cosciente di quel che fai digita esattamente ZcUcpH", "Verifica coscienza On")
If Rispo <> "ZcUcpH" Then
    MsgBox ("Non sei abbastanza cosciente, cancella i file indesiderati a mano; operazione abortita")
    Exit Sub
End If
'
'Good luck:
LR = Cells(Rows.Count, 1).End(xlUp).Row
For I = 2 To LR
DoEvents
    Occorr = Evaluate("=sumproduct(--(B1:B" & LR & "=B" & I & "),--(C1:C" & LR & "=C" & I & _
      "),--(D1:D" & LR & "=D" & I & "),--(E1:E" & LR & "=E" & I & "))")
    If Occorr > 1 Then
    'Duplicato!
    'Check se dir protetta:
        protYn = Application.WorksheetFunction.CountIf(myProt, Cells(I, 1))
        If protYn = 0 Then
        'No, spostabile:
            cFile = Cells(I, 2)
            'Check se file gia' presente in "sicurezza"
            myTO = Timer + 20: If myTO > 86400 Then myTO = 30
reCK:
            Do
                myCK = Dir(Secur & Application.PathSeparator & cFile)
                If myCK = cFile Then
                'se Presente, si modifica il nome:
                    cFile = Replace(Timer & "_", ",", "_", , , vbTextCompare) & Cells(I, 2)
                Else
                    Exit Do
                End If
                If Timer > myTO Then
                    MsgBox ("Errore inatteso su Rinomina del file " & Cells(I, 2) & vbCrLf _
                       & "La macro viene sospesa, l'anomalia va debuggata e la macro FileRemover ripetuta daccapo")
                       Stop: Stop           '<<< Se arriviamo qui non
                End If
            Loop
            'Pronti per spostare:
            On Error GoTo puPP
            Name Cells(I, 1) & Cells(I, 2) As Secur & Application.PathSeparator & cFile
            'Attesa 0.2 sec
            DoEvents
            If Timer > (86400 - 10) Then
                Do While Timer > 10: DoEvents: Loop
            End If
            myTO2 = Timer + 0.2
            Do While Timer < myTO2:  DoEvents: Loop
            GoTo myLog
puPP:
            Sheets("Foglio2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = "***** ERRORE VERIFICATO SU FILE SEGUENTE: *******"
            Resume myLog
myLog:
            'Log transazione:
            Cells(I, 1).Resize(1, 5).Copy Sheets("Foglio2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
            Sheets("Foglio2").Cells(Rows.Count, 1).End(xlUp).Offset(0, 7).Value = cFile
            'Mark file originale
            Cells(I, 2).Value = "**_" & Cells(I, 2).Value
            mFiles = mFiles + 1
        End If
    End If
Next I
MsgBox ("Spostamento completato" & vbCrLf & "Totale file spostati: " & mFiles)
End Sub

La riga marcata <<< va compilata con il corretto nome della directory di sicurezza.
La macro da avviare e' la FileRemover

Attendere pazientemente il completamento del processo, che sara' indicato tramite un Msgbox riepilogativo.

Disclaimer: la macro sposta file e ne manipola il NomeFile; il codice e' rilasciato cosi' come e', le prestazioni non e' detto che siano quelle descritte; l'uso e' a proprio rischio e pericolo; non e' garantita la correzione degli errori; non e' garantito il buon esito delle operazioni; e' garantita la suspence.

Ciao!

[recalcatiiti]

Ciao Anthony, grazie per l'esauriente risposta e per la simpatia che trasmetti sempre.

In questi giorni, per variegati impegni, non ho potuto attuare il metodo da te esposto, lo farò (spero) nei prossimi giorni.

Nel frattempo ti ringrazio molto,

Ciao e a presto .

[Anthony47]

Ti aspetto ti aspetto...
Aggiungo una norma precauzionale importante: dopo che la macro FileRemover avra' fatto il suo lavoro (spostamento in C:\ZC_PROTEZ, log in Foglio3), e' opportuno che Foglio3 venga immediatamente salvato, perche' il suo contenuto potrebbe essere necessario per ripristinare (manualmente o automaticamente, tramite macro non ancora sviluppata) le immagini al loro posto originale.

Ciao

[recalcatiiti]

Ciao Anthony, davvero complimenti.

dopo questo abominevole e difficilmente giustificabile ritardo, sono riuscito a testare la macro.
Mi sono ciecamente fidato del tuo lavoro seguendo dettagliatamente i tuoi consigli, e tutto ha funzionato alla perfezione. Mi sono risparmiato ore di lavoro (decine), ho scandagliato i 3 TB (procedendo a scaglioni, per evitare attese troppo lunghe) di dischi malamente organizzati rimuovendo tutte le copie inutili (31 GB ). Avrei potuto utilizzare qualche software appositamente dedicato, ma sinceramente mi fido più di te che di qualsiasi altro programmatore eheheheh. Scherzi a parte, grazie mille per il tuo lavoro.

Grazie, a presto.