Avec les fonctions DIR, GetAttr, disponibles dans les macro d'Excel
j'explore régulièrement l'arborescence des fichiers.
Les propriétés DateCreated, LastUpdated donnent les dates de création
et de dernière modification.
La propriété BuiltinDocumentProperties donne aussi d'autres
informations utiles.
Avec ces éléments j'en tire des statistiques et des synthèses avec des
liens directs sur les fichiers.
Par contre j'ai une difficulté si le fichier analysé est un raccourci,
car je souhaite récupérer les informations du fichier cible et pas
celles du raccourci.
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire
Veuillez sélectionner un problème
Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
PMO
Bonjour,
Une piste avec le code suivant qui affiche les infos des fichiers Cibles des raccourcis contenus dans le dossier C:
Adaptez la constante MON_DOSSIER et le code à votre usage
***************** Const MON_DOSSIER As String = "c:" 'à adapter
Sub InfoCibleRaccourci() Dim fichier$ Dim CheminCible$ Dim FSO As Object Dim FsoFile As Object Dim Msg$ Dim nAttr& Dim A$ Set FSO = CreateObject("Scripting.FileSystemObject") fichier$ = Dir(MON_DOSSIER) Do Until fichier$ = "" '--- Cibles des raccourcis --- If LCase(Right(fichier$, 4)) = ".lnk" Then CheminCible$ = CiblePath(MON_DOSSIER & fichier$) If CheminCible$ <> "" Then Set FsoFile = FSO.GetFile(CheminCible$) With FsoFile Msg$ = "" A$ = "" nAttr = .Attributes If nAttr And 1 Then A$ = A$ & "Lecture seule " If nAttr And 2 Then A$ = A$ & "Masqué " If nAttr And 4 Then A$ = A$ & "Système " If nAttr And 8 Then A$ = A$ & "Volume " If nAttr And 16 Then A$ = A$ & "Dossier " If nAttr And 32 Then A$ = A$ & "Archive " If nAttr And 64 Then A$ = A$ & "Alias " If nAttr And 128 Then A$ = A$ & "Compressé " Msg$ = Msg$ & "Attributs : " & A$ & vbCrLf Msg$ = Msg$ & "Disque : " & .Drive & "" & vbCrLf Msg$ = Msg$ & "Nom de fichier : " & .Name & vbCrLf Msg$ = Msg$ & "Chemin : " & .Path & vbCrLf Msg$ = Msg$ & "Nom MS-DOS (court): " & .ShortName & vbCrLf Msg$ = Msg$ & "Chemin MS-DOS (court): " & .ShortPath & vbCrLf Msg$ = Msg$ & "Taille : " & .Size & vbCrLf Msg$ = Msg$ & "Type de fichier : " & .Type & vbCrLf Msg$ = Msg$ & "Date de création : " & .DateCreated & vbCrLf Msg$ = Msg$ & "Date de dernier accès : " & .DateLastAccessed & vbCrLf Msg$ = Msg$ & "Dernière modification : " & .DateLastModified & vbCrLf Msg$ = Msg$ & "Nom de dossier parent : " & .ParentFolder.Name & vbCrLf '---affichage infos --- MsgBox Msg$, Title:="Cible du raccourci " & Left(fichier$, Len(fichier$) - 4) End With End If End If '----------------------------- fichier$ = Dir Loop End Sub
Private Function CiblePath(File_lnk As String) As String Dim TailleFichier& Dim Target$ Dim i& Dim Canal& Dim B As Byte Dim num% Dim Compare$ Dim pos& Dim Valide As Boolean Dim Depart& Dim A$ Target$ = ChrW(&H5B) & ChrW(&HFD) & ChrW(&H15) & _ ChrW(&H1C) & ChrW(&H10) & ChrW(&H0) & _ ChrW(&H0) & ChrW(&H0) & ChrW(&H0) TailleFichier& = FileLen(File_lnk) Canal& = FreeFile Open File_lnk For Binary As #Canal& For i& = 0 To TailleFichier& Get #Canal&, , B If Len(Compare$) = num% Then If Chr(B) = Mid(Target$, num% + 1, 1) Then If pos& = 0 Or pos& + 1 = i& Then pos& = i& Compare$ = Compare$ & Chr(B) num% = num% + 1 Else Compare$ = "" num% = 0 pos& = 0 End If If Compare$ = Target$ Then Valide = True Depart& = i& - Len(Target$) + 2 Exit For End If End If End If Next i& If Not Valide Then Exit Function For i& = Depart& + Len(Target$) To TailleFichier& Get #Canal&, i&, B A$ = A$ & Chr$(B) If Len(A$) > 4 Then If Right(A$, 2) = ChrW(&H0) & ChrW(&H0) Then A$ = Mid(A$, 1, Len(A$) - 2) Exit For End If End If Next i& Close #Canal& Canal& = FreeFile CiblePath = A$ End Function *****************
Cordialement.
-- PMO Patrick Morange
Bonjour,
Une piste avec le code suivant qui affiche les infos des fichiers Cibles
des raccourcis contenus dans le dossier C:
Adaptez la constante MON_DOSSIER et le code à votre usage
*****************
Const MON_DOSSIER As String = "c:" 'à adapter
Sub InfoCibleRaccourci()
Dim fichier$
Dim CheminCible$
Dim FSO As Object
Dim FsoFile As Object
Dim Msg$
Dim nAttr&
Dim A$
Set FSO = CreateObject("Scripting.FileSystemObject")
fichier$ = Dir(MON_DOSSIER)
Do Until fichier$ = ""
'--- Cibles des raccourcis ---
If LCase(Right(fichier$, 4)) = ".lnk" Then
CheminCible$ = CiblePath(MON_DOSSIER & fichier$)
If CheminCible$ <> "" Then
Set FsoFile = FSO.GetFile(CheminCible$)
With FsoFile
Msg$ = ""
A$ = ""
nAttr = .Attributes
If nAttr And 1 Then A$ = A$ & "Lecture seule "
If nAttr And 2 Then A$ = A$ & "Masqué "
If nAttr And 4 Then A$ = A$ & "Système "
If nAttr And 8 Then A$ = A$ & "Volume "
If nAttr And 16 Then A$ = A$ & "Dossier "
If nAttr And 32 Then A$ = A$ & "Archive "
If nAttr And 64 Then A$ = A$ & "Alias "
If nAttr And 128 Then A$ = A$ & "Compressé "
Msg$ = Msg$ & "Attributs : " & A$ & vbCrLf
Msg$ = Msg$ & "Disque : " & .Drive & "" & vbCrLf
Msg$ = Msg$ & "Nom de fichier : " & .Name & vbCrLf
Msg$ = Msg$ & "Chemin : " & .Path & vbCrLf
Msg$ = Msg$ & "Nom MS-DOS (court): " & .ShortName & vbCrLf
Msg$ = Msg$ & "Chemin MS-DOS (court): " & .ShortPath & vbCrLf
Msg$ = Msg$ & "Taille : " & .Size & vbCrLf
Msg$ = Msg$ & "Type de fichier : " & .Type & vbCrLf
Msg$ = Msg$ & "Date de création : " & .DateCreated & vbCrLf
Msg$ = Msg$ & "Date de dernier accès : " & .DateLastAccessed &
vbCrLf
Msg$ = Msg$ & "Dernière modification : " & .DateLastModified &
vbCrLf
Msg$ = Msg$ & "Nom de dossier parent : " & .ParentFolder.Name &
vbCrLf
'---affichage infos ---
MsgBox Msg$, Title:="Cible du raccourci " & Left(fichier$,
Len(fichier$) - 4)
End With
End If
End If
'-----------------------------
fichier$ = Dir
Loop
End Sub
Private Function CiblePath(File_lnk As String) As String
Dim TailleFichier&
Dim Target$
Dim i&
Dim Canal&
Dim B As Byte
Dim num%
Dim Compare$
Dim pos&
Dim Valide As Boolean
Dim Depart&
Dim A$
Target$ = ChrW(&H5B) & ChrW(&HFD) & ChrW(&H15) & _
ChrW(&H1C) & ChrW(&H10) & ChrW(&H0) & _
ChrW(&H0) & ChrW(&H0) & ChrW(&H0)
TailleFichier& = FileLen(File_lnk)
Canal& = FreeFile
Open File_lnk For Binary As #Canal&
For i& = 0 To TailleFichier&
Get #Canal&, , B
If Len(Compare$) = num% Then
If Chr(B) = Mid(Target$, num% + 1, 1) Then
If pos& = 0 Or pos& + 1 = i& Then
pos& = i&
Compare$ = Compare$ & Chr(B)
num% = num% + 1
Else
Compare$ = ""
num% = 0
pos& = 0
End If
If Compare$ = Target$ Then
Valide = True
Depart& = i& - Len(Target$) + 2
Exit For
End If
End If
End If
Next i&
If Not Valide Then Exit Function
For i& = Depart& + Len(Target$) To TailleFichier&
Get #Canal&, i&, B
A$ = A$ & Chr$(B)
If Len(A$) > 4 Then
If Right(A$, 2) = ChrW(&H0) & ChrW(&H0) Then
A$ = Mid(A$, 1, Len(A$) - 2)
Exit For
End If
End If
Next i&
Close #Canal&
Canal& = FreeFile
CiblePath = A$
End Function
*****************
Une piste avec le code suivant qui affiche les infos des fichiers Cibles des raccourcis contenus dans le dossier C:
Adaptez la constante MON_DOSSIER et le code à votre usage
***************** Const MON_DOSSIER As String = "c:" 'à adapter
Sub InfoCibleRaccourci() Dim fichier$ Dim CheminCible$ Dim FSO As Object Dim FsoFile As Object Dim Msg$ Dim nAttr& Dim A$ Set FSO = CreateObject("Scripting.FileSystemObject") fichier$ = Dir(MON_DOSSIER) Do Until fichier$ = "" '--- Cibles des raccourcis --- If LCase(Right(fichier$, 4)) = ".lnk" Then CheminCible$ = CiblePath(MON_DOSSIER & fichier$) If CheminCible$ <> "" Then Set FsoFile = FSO.GetFile(CheminCible$) With FsoFile Msg$ = "" A$ = "" nAttr = .Attributes If nAttr And 1 Then A$ = A$ & "Lecture seule " If nAttr And 2 Then A$ = A$ & "Masqué " If nAttr And 4 Then A$ = A$ & "Système " If nAttr And 8 Then A$ = A$ & "Volume " If nAttr And 16 Then A$ = A$ & "Dossier " If nAttr And 32 Then A$ = A$ & "Archive " If nAttr And 64 Then A$ = A$ & "Alias " If nAttr And 128 Then A$ = A$ & "Compressé " Msg$ = Msg$ & "Attributs : " & A$ & vbCrLf Msg$ = Msg$ & "Disque : " & .Drive & "" & vbCrLf Msg$ = Msg$ & "Nom de fichier : " & .Name & vbCrLf Msg$ = Msg$ & "Chemin : " & .Path & vbCrLf Msg$ = Msg$ & "Nom MS-DOS (court): " & .ShortName & vbCrLf Msg$ = Msg$ & "Chemin MS-DOS (court): " & .ShortPath & vbCrLf Msg$ = Msg$ & "Taille : " & .Size & vbCrLf Msg$ = Msg$ & "Type de fichier : " & .Type & vbCrLf Msg$ = Msg$ & "Date de création : " & .DateCreated & vbCrLf Msg$ = Msg$ & "Date de dernier accès : " & .DateLastAccessed & vbCrLf Msg$ = Msg$ & "Dernière modification : " & .DateLastModified & vbCrLf Msg$ = Msg$ & "Nom de dossier parent : " & .ParentFolder.Name & vbCrLf '---affichage infos --- MsgBox Msg$, Title:="Cible du raccourci " & Left(fichier$, Len(fichier$) - 4) End With End If End If '----------------------------- fichier$ = Dir Loop End Sub
Private Function CiblePath(File_lnk As String) As String Dim TailleFichier& Dim Target$ Dim i& Dim Canal& Dim B As Byte Dim num% Dim Compare$ Dim pos& Dim Valide As Boolean Dim Depart& Dim A$ Target$ = ChrW(&H5B) & ChrW(&HFD) & ChrW(&H15) & _ ChrW(&H1C) & ChrW(&H10) & ChrW(&H0) & _ ChrW(&H0) & ChrW(&H0) & ChrW(&H0) TailleFichier& = FileLen(File_lnk) Canal& = FreeFile Open File_lnk For Binary As #Canal& For i& = 0 To TailleFichier& Get #Canal&, , B If Len(Compare$) = num% Then If Chr(B) = Mid(Target$, num% + 1, 1) Then If pos& = 0 Or pos& + 1 = i& Then pos& = i& Compare$ = Compare$ & Chr(B) num% = num% + 1 Else Compare$ = "" num% = 0 pos& = 0 End If If Compare$ = Target$ Then Valide = True Depart& = i& - Len(Target$) + 2 Exit For End If End If End If Next i& If Not Valide Then Exit Function For i& = Depart& + Len(Target$) To TailleFichier& Get #Canal&, i&, B A$ = A$ & Chr$(B) If Len(A$) > 4 Then If Right(A$, 2) = ChrW(&H0) & ChrW(&H0) Then A$ = Mid(A$, 1, Len(A$) - 2) Exit For End If End If Next i& Close #Canal& Canal& = FreeFile CiblePath = A$ End Function *****************