Copy Internet Favorites To Workbook
 

Would anyone have a VBA procedure that would copy your
favorite URLs on your internet toolbar to an Excel
worksheet? I would like to be able to have an Excel
worksheet that I can update frequently that contains a
list of my favorite URLs.

Copy Internet Favorites To Workbook
 

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 ****EMID
cb As Long
abID As Byte
End Type
Private Type ITEMIDLIST
mkid As ****EMID
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


--
Regards

Juan Pablo González

"John Mansfield" wrote in message
...
Would anyone have a VBA procedure that would copy your
favorite URLs on your internet toolbar to an Excel
worksheet? I would like to be able to have an Excel
worksheet that I can update frequently that contains a
list of my favorite URLs.

Copy Internet Favorites To Workbook
 

Juan, thank you very much for your help with this.

John Mansfield

-----Original Message-----
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 ****EMID
cb As Long
abID As Byte
End Type
Private Type ITEMIDLIST
mkid As ****EMID
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


--
Regards

Juan Pablo González

"John Mansfield"
wrote in message
...
Would anyone have a VBA procedure that would copy your
favorite URLs on your internet toolbar to an Excel
worksheet? I would like to be able to have an Excel
worksheet that I can update frequently that contains a
list of my favorite URLs.


.