Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11

Trouver la cible d'un raccourci (bis)

1 réponse
Avatar
PPz
Trouver la cible d'un raccourci

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.

Merci de vos idées.

PPz

1 réponse

Avatar
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