Sub informationsRaccourcisBureau_V02()
'michelxld le 17.04.2005
'
'activer reference Microsoft Shell Controls and Automation
'activer reference Microsoft Scripting Runtime
'
'testé avec excel2002 & WinXp
'
Const Cible = &H10 'Desktop
'
Dim objShell As Shell32.Shell
Dim objFolder As Shell32.Folder
Dim colItems As Shell32.FolderItems
Dim objItem As Shell32.FolderItem
Dim i As Integer
Dim Fso As Scripting.FileSystemObject
Dim FileItem As Scripting.File
Dim Longueur As Integer, j As Integer
Set objShell = CreateObject('Shell.Application')
Set objFolder = objShell.NameSpace(Cible)
Set colItems = objFolder.Items
Set Fso = CreateObject('Scripting.FileSystemObject')
For Each objItem In colItems
If objItem.IsLink Then
i = i + 1
Cells(i, 1) = objItem.Path
'µµµµµµµµµµµµµµµµµµµµµµµµµ
Longueur = Len(objItem.Path)
j = Longueur
While Mid(objItem.Path, j, 1) <> '\\'
j = j - 1
Wend
Cells(i, 2) = Mid(objItem.Path, j + 1, Longueur - j)
'µµµµµµµµµµµµµµµµµµµµµµµµµ
Cells(i, 3) = objItem.GetLink.Path
Cells(i, 4) = objFolder.GetDetailsOf(objItem, 14)
If Fso.FileExists(objItem.GetLink.Path) Then
Set FileItem = Fso.GetFile(objItem.GetLink.Path)
Cells(i, 5) = FileItem.Type
Cells(i, 6) = objItem.Name
End If
End If
Next
End Sub