ESTRARRE la DATA dalla PROPRIETA' DEL FILE

[scanacc]

In pratica devo inserire nel "FILE A" la data del giorno in cui è stato fatto il download del "FILE B"
Purtroppo nel FILE B non ci sono riferimenti in merito e non so come fare se non prenderli nelle proprietà del documento dalla voce "Creazione contenuto". Dato che dovrò ripetere l'operazione per molte volte, un piccolo aiuto sarebbe gradito.
Grazie

[Anthony47]

Si puo' lavorare sulle informazioni prelevabili tramite il FileSystemObject.
Ad esempio, partiamo da quanto pubblicato (codice e informazioni) in questa documentazione Microsoft: https://docs.microsoft.com/en-us/office ... ile-object

Possiamo cosi' arrivare alla seguente "Funzione Utente":

Codice: Seleziona tutto

Function ShowFileInfo(ByVal myFile As String, Optional ByVal myOpt As Long = 1) As Variant
    Dim fs, f, s
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFile(myFile)
    If myOpt = 1 Then
        ShowFileInfo = f.DateCreated
    ElseIf myOpt = 2 Then
        ShowFileInfo = f.DateLastAccessed
    ElseIf myOpt = 3 Then
        ShowFileInfo = f.DateLastModified
    End If
End Function

La funzione ShowFileInfo così creata va richiamata passandole come "argomenti" il nome file e il Numero di info che si vuole ottenere; al momento ho previsto:
1=DateCreated
2=DateLastAccessed
3=DateLastModified

Ad esempio potrai usare una formula tipo

Codice: Seleziona tutto

=ShowFileInfo("D:\DDownloads\Dieta.xlsx";1)

Per ottenere la data di creazione di quel file

Ovviamente puoi usare una cella per contenere gli argomenti della formula:

Codice: Seleziona tutto

=ShowFileInfo(A2;B2)

(se NomeFile e' in A2 e tipo di informazione voluta e' in B2)

Altre combinazioni di informazioni, oltre alle 3 ora inserite, si possono prevedere esaminando quali sono le Proprieta' del File Object (il link Microsoft)

Ciao

[scanacc]

Grazie Antony, avevo trovato anche questo che funzionava bene

Codice: Seleziona tutto

Public Sub Test()
    Dim wk As Workbook
    Dim sh As Worksheet
    Dim fso As Object
    Dim strFile As String
   
    strFile = "C:\FOCUS\DETTAGLIO\INFO.xlsx"
   
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set wk = ThisWorkbook
    Set sh = wk.Sheets("Foglio1")
   
    With sh
        .Range("A2").Value2 = fso.GetFile(strFile).DateLastAccessed
        .Range("B2").Value2 = fso.GetFile(strFile).DateCreated
        .Range("C2").Value2 = fso.GetFile(strFile).DateLastModified
        .Range("D2").Value2 = fso.GetFile(strFile).Type
        .Range("E2").Value2 = fso.GetFile(strFile).Size
        .Range("F2").Value2 = fso.GetFile(strFile).Name
        .Range("G2").Value2 = fso.GetFile(strFile).Path

    End With
   
End Sub


Ma da il problema che me ne fa vedere solo 1. Come posso fare in modo che questa macro continui la ricerca di tutti i FILE nella cartella che vorrei indicargli senza indicargli la path esatta del file?

[Anthony47]

Come posso fare in modo che questa macro continui la ricerca di tutti i FILE nella cartella che vorrei indicargli senza indicargli la path esatta del file?

La interpreto così:
-data la directory, come posso ottenere le informazioni di tutti i file presenti nella directory?

In questo caso devi estrarre i nomi file e lavorare su quelli. Ad esempio:

Codice: Seleziona tutto

Sub GetFileInfo()
Dim sh As Worksheet
Dim fSo As Object
Dim lFile As Object, iPath As String
'
iPath = "D:\DDownloads\Amazon_Imag"                     '<<< La directory in cui cercare
Set sh = ThisWorkbook.Sheets("Foglio6")     '<<< Il foglio in cui scaricare i risultati
'
Set fSo = CreateObject("Scripting.FileSystemObject")
I = 1
For Each lFile In fSo.GetFolder(iPath).Files
    I = I + 1
    sh.Cells(I, 1).Value2 = fSo.GetFile(lFile).DateLastAccessed
    sh.Cells(I, 2).Value2 = fSo.GetFile(lFile).DateCreated
    sh.Cells(I, 3).Value2 = fSo.GetFile(lFile).DateLastModified
    sh.Cells(I, 4).Value2 = fSo.GetFile(lFile).Type
    sh.Cells(I, 5).Value2 = fSo.GetFile(lFile).Size
    sh.Cells(I, 6).Value2 = fSo.GetFile(lFile).Name
    sh.Cells(I, 7).Value2 = fSo.GetFile(lFile).Path
    DoEvents
Next lFile
MsgBox ("Elenco completato, n° files: " & I)
End Sub


Le istruzioni marcate <<< vanno personalizzate

Le informazioni saranno riportate nel foglio dichiarato a partire dalla riga 2; non ho inserito una pulizia iniziale del foglio, ed eventuali dati presenti vengono sovrascritti.

Ciao

[scanacc]

Perfetto grazie!

[scanacc]

Strano però ... mi indica 1 FILE in più. Mi dice che ha estratto i dati di 19 FILE ma in realtà ne elenca, a partire dalla 2a riga, 18 (che è il numero giusto).

[Anthony47]

Speravo non te ne saresti accorto

Devi modificare in

Codice: Seleziona tutto

MsgBox ("Elenco completato, n° files: " & I-1)

Ciao

[scanacc]

Grazie! E pensare che ho provato più volte a vedere se riuscivo a cambiarlo!!!!
Un saluto

[wallace&gromit]

Ciao,
nei ritagli di tempo (che attualmente sono pochi) stavo cercando di aggiungere a questa macro un passaggio in cui si vadano a cercare anche le sottocartelle, qualcosa così, prima della riga in cui si cercano i file:

Codice: Seleziona tutto

For Each mySubFolder In fSo.iPath.SubFolders
    iPath = mySubFolder.Path


... niente! non ci riesco.

[Anthony47]

Potresti partire dalla Function RecurDir che avevamo usato qui: viewtopic.php?p=632550#p632405

La function i restituira’ un array con l’elenco di tutti i file presenti in un percorso e tutte le sue subdir, filtrandoli con un elenco di extension lungo a piacere.

Ottenuto l’elenco ti bastera’ scorrere l’elenco dei file e leggerne le proprieta’.
In pratica, supponendo che (come nella discussione linkata) l’elenco viene restituito nell’array Farr dovrai usare per il ciclo di estrazione NON For Each lFile In fSo.GetFolder(iPath).Files /Next lFile ma qualcosa come

Codice: Seleziona tutto

For J=1 to ubound(Farr)
    lFile=Farr(J)
    I = I + 1
    sh.Cells(I, 1).Value2 = fSo.GetFile(lFile).DateLastAccessed
    'etc etc

Next J


Mi fermo a questo macro livello, sono sicuro che sara' sufficiente; ma se dovessi arenarti siamo qui…

Ciao

[wallace&gromit]

Ok, dopo avere pestato un po' la testa su un paio di bug ho capito che:
- c'era uno spazio di troppo in " D:\..."
- lFile non andava più dimensionato come object ma string
- se inserisco proprio solo "D:\" la function RecurDir va in loop quando trova il cestino

Quest'ultimo punto non ho ancora saputo risolverlo, a parte inserire già qualche directory in più, però mi piacerebbe potere partire proprio dalla base.

Ecco cosa ho fatto:

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 GetFileInfo()
Dim sh As Worksheet
Dim fSo As Object
Dim lFile, iPath As String
'
Set sh = ThisWorkbook.Sheets("Foglio1")     '<<< Il foglio in cui scaricare i risultati
'
Set fSo = CreateObject("Scripting.FileSystemObject")

Dim FArr() As String
ReDim FArr(1 To 1)
allpics = Array("jpg", "png", "gif")    '<<< Altri formati?       '***
StrDir = "D:\"       '<<< Il Percorso iniziale !!!! attenzione, non funziona con solo D
Call RecurDir(StrDir, allpics, FArr)

I = 1

For J = 1 To UBound(FArr)
    lFile = FArr(J)
    I = I + 1
    sh.Cells(I, 1).Value2 = fSo.GetFile(lFile).DateLastAccessed
    sh.Cells(I, 2).Value2 = fSo.GetFile(lFile).DateCreated
    sh.Cells(I, 3).Value2 = fSo.GetFile(lFile).DateLastModified
    sh.Cells(I, 4).Value2 = fSo.GetFile(lFile).Type
    sh.Cells(I, 5).Value2 = fSo.GetFile(lFile).Size
    sh.Cells(I, 6).Value2 = fSo.GetFile(lFile).Name
    sh.Cells(I, 7).Value2 = fSo.GetFile(lFile).Path
    DoEvents
Next J
MsgBox ("Elenco completato, n° files: " & I)
End Sub



[Anthony47]

Effettivamente il codice rischia di schiantarsi in diverse occasioni, probabilmente anche complici nuove prestazioni di sicurezza introdotte sui S.O. piu' recenti...

Ho quindi preparato una versione che mi pare piu' robusta:

Codice: Seleziona tutto

Dim myFso As FileSystemObject, ccAll As Long    'RIGOROSAMENTE IN TESTA AL MODULO
Dim noDirs

Function RecurDir(ByVal ccDir As String, myExt As Variant, ByRef cStore As Variant) As String
Dim myItm, Dbg As Boolean
'
If myFso Is Nothing Then Set myFso = CreateObject("Scripting.FileSystemObject")
If myFso Is Nothing Then Beep
DoEvents
'
Dbg = False             '<<< Se True allora abilita Debug.Print
'
If Dbg Then Debug.Print ccDir
If myFso.FolderExists(ccDir) Then
    On Error Resume Next
    For Each myItm In myFso.GetFolder(ccDir).Files
        If Err.Number = 92 Then
            If Dbg Then Debug.Print "# 92", ccDir
            Err.Clear
            GoTo eFor
        ElseIf Err.Number > 0 Then
            If Dbg Then Debug.Print "# " & Err.Number, ccDir
            Err.Clear
            GoTo Bohh
        End If
        On Error GoTo 0
        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
Bohh:
        On Error GoTo 0
        DoEvents
        If IsEmpty(myItm) Then GoTo eFor
        Next myItm
eFor:
        On Error GoTo 0
End If
On Error Resume Next
For Each myItm In myFso.GetFolder(ccDir).SubFolders
    If Err.Number > 0 Then GoTo eFun
    On Error GoTo 0
    nobb = False
    For I = 0 To UBound(noDirs)
        If InStr(1, myItm & "  ", noDirs(I), vbTextCompare) > 0 Then
            nobb = True
            Exit For
        End If
    Next I
    If nobb = False Then Call RecurDir(myItm, myExt, cStore)
Next myItm
eFun:
Err.Clear
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
'
Dim FArr() As String
Sheets("Foglio1").Select                                    '<<< Il foglio dei risultati
ReDim FArr(1 To 1)
'
AllPics = Array("jpg", "png", "gif")                        '<<< Altri formati?       '***
StrDir = "C:\"                                              '<<< Il Percorso iniziale
noDirs = Array("\$", "\Program", "\Windows", "\AppData")    '<<< Path da escludere
'
Call RecurDir(StrDir, AllPics, FArr)
Range("A1").Resize(UBound(FArr), 1).Value = FArr            'Finalmente scrive da A1 l'elenco

Stop

GoTo eSub           'Termina la sub, se basta l'elenco dei file

'Da qui in poi estrae prorprieta' delle immagini elencate
Application.ScreenUpdating = False
For I = 1 To UBound(FArr)
    DoEvents
    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
eSub:
On Error Resume Next
Application.ScreenUpdating = True
Set myFso = Nothing
On Error GoTo 0
MsgBox ("Elenco completato...")
End Sub


Le modifiche riguardano soprattutto la prima parte, compresa la Function RecurDir.

Tra l'altro ho introdotto la possibilita' di dichiarare un elenco di percorsi da skippare, vedi noDirs = Array("\$", "\Program", etc etc
Attenzione che di quelle chiavi ne viene controllata la presenza in qualsiasi posizione del percorso che viene scandagliato.

Da lanciare e' la Sub Prova, che (col codice pubblicato) scrivera' sul foglio selezionato l'elenco dei file rilevati; poi si ferma sullo Stop e, riavviandola, esce.
Vedo che a te interessa raccogliere informazioni diverse da quelle che raccoglievo io, ma puoi benissimo sostituire la seconda parte di Sub Prova con quello che ti interessa.

Ciao

[wallace&gromit]

La prima parte mi fa un comportamento un po' strano: ripete il nome del primo file trovato per tante volte quanti sono i file, ma non fa niente, a me non interessa quella parte, io voglio i dettagli, quindi faccio scrivere solo la seconda parte.
Lavorando sul vecchio catorcio di casa ogni operazione richiede il suo tempo. Ho visto in particolare che la ricerca delle dimensioni delle foto impiega parecchio, ma anche questo è un dato che mi interessa relativamente, quindi ho tolto anche quello.
Ora va che è una meraviglia!
Il mio progetto prosegue, magari (senz'altro) mi ripresenterò per i prossimi dubbi.