This seems to work ok. Just put it in a standard module and run the
"ExtractFavorites" sub
Option Explicit
Const CSIDL_FAVORITES = &H6
Const NOERROR = 0
Private Declare Function SHGetSpecialFolderLocation Lib _
"shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, _
pidl As ITEMIDLIST) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long
Private Type SHITEMID
cb As Long
abID As Byte
End Type
Private Type ITEMIDLIST
mkid As SHITEMID
End Type
Sub ExtractFavorites()
Dim Pth As String
Dim i As Long
Dim Rng As Range
Pth = GetSpecialfolder(CSIDL_FAVORITES)
If Len(Pth) > 0 Then
Application.ScreenUpdating = False
With Workbooks.Add(xlWorksheet).Worksheets(1)
.Name = "Favorites"
With .Range("A1").Resize(1, 3)
.Value = Array("Folder", "Name", "URL")
.Font.Bold = True
End With
End With
With Application.FileSearch
.NewSearch
.FileType = msoFileTypeAllFiles
.LookIn = Pth
.SearchSubFolders = True
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
If .FoundFiles(i) Like "*.url" Then
Set Rng = Cells(Rows.Count, 1).End(xlUp).Offset(1)
Rng.Value = GetPath(.FoundFiles(i))
Rng.Offset(, 1).Value = GetName(.FoundFiles(i))
Rng.Offset(, 2).Value = GetURL(.FoundFiles(i))
Rng.Offset(, 2).Hyperlinks.Add Rng.Offset(, 2),
Rng.Offset(, 2).Value
End If
Next i
End If
End With
Range("A1").CurrentRegion.Sort Range("A1"), xlAscending,
Header:=xlYes
Application.ScreenUpdating = True
End If
End Sub
Private Function GetSpecialfolder(CSIDL As Long) As String
Dim r As Long
Dim Path$
Dim IDL As ITEMIDLIST
'Get the special folder
r = SHGetSpecialFolderLocation(100, CSIDL, IDL)
If r = NOERROR Then
'Create a buffer
Path$ = Space$(512)
'Get the path from the IDList
r = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal Path$)
'Remove the unnecessary chr$(0)'s
GetSpecialfolder = Left$(Path, InStr(Path, Chr$(0)) - 1)
Exit Function
End If
GetSpecialfolder = ""
End Function
Private Function GetPath(FileName As String) As String
On Error Resume Next
GetPath = Left$(FileName, Len(FileName) - Len(GetName(FileName)) - _
Len(Application.PathSeparator))
End Function
Private Function GetName(FileName As String) As String
#If VBA6 Then
Dim Ar As Variant
Ar = Split(FileName, Application.PathSeparator)
GetName = Ar(UBound(Ar))
#Else
Dim St As String, Ctr As Long, i As Long
St = FileName
Ctr = (Len(St) - Len(Application.Substitute(St, _
Application.PathSeparator, ""))) /
Len(Application.PathSeparator)
St = Application.Substitute(St, Application.PathSeparator,
Chr$(127), Ctr)
GetName = Mid$(St, InStr(1, St, Chr$(127), 1) + 1)
#End If
End Function
Private Function GetURL(FileName As String) As String
Dim Fl As Long
Fl = FreeFile()
Open FileName For Input Access Read As #Fl
Do While Not EOF(1)
Line Input #1, GetURL
If GetURL Like "URL=*" Then
GetURL = Mid$(GetURL, 5)
GoTo exiting
End If
Loop
exiting:
Close #Fl
End Function
