' ----------------------------------------------------------
' Script d'exportation des favoris (noms et URL)
' y compris dans les sous-répertoires
' dans un fichier HTML
'
' Jean-Claude BELLAMY - © 2006
' ----------------------------------------------------------
Dim prec
ForReading=1
Const SW_HIDE=0
Const SW_SHOWNORMAL=1
Dim shell, fldrs, fso, ts
Set shell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
FileResult=GetPath() & "listfav.html"
Set ts=fso.CreateTextFile(FileResult, true,true)
' Récupération du chemin du dossier "Favoris"
Set fldrs = Shell.SpecialFolders
fav=fldrs("Favorites")
ColorBack="""#FFFFD8"""
ts.Writeline "
" & "Favoris" & ""
ts.Writeline "" & Titre & ""
ts.Writeline ""
ts.WriteLine "Dossier des favoris : " & fav & "
"
indfav=InstrRev(fav,"\")+1
prec=""
ts.writeline ""
call explorefolder(fav,"Favoris")
ts.WriteLine "
"
ts.close
prompt="La liste des favoris a été stockée dans" & VBCRLF & _
"le fichier " & FileResult & VBCRLF & _
"Appuyer sur :" & VBCRLF & _
" OUI pour l'ouvrir avec le navigateur" & VBCRLF & _
" NON pour l'ouvrir avec le bloc-notes"
rep=MsgBox(prompt, vbYesNo + vbQuestion, "Liste des favoris")
If rep=vbYes Then
commande=chr(34) & FileResult & chr(34)
else
commande=shell.ExpandEnvironmentStrings("%windir%\notepad.exe " & chr(34) & FileResult & chr(34))
end if
shell.Run commande, SW_SHOWNORMAL, false
wscript.quit
'----------------------------------------------------
' Sous-programme récursif d'exploration des dossiers
sub explorefolder(namefolder,curfolder)
dim f,collfolders,collfiles
Set f = fso.GetFolder(namefolder)
' Collection des fichiers et sous-dossiers du dossier courant
Set collfolders= f.SubFolders
Set collfiles = f.Files
subname=mid(namefolder,indfav)
ts.writeline "" & curfolder & ""
' Exploration des fichiers contenus
nf=0
For each fic in collfiles
ext=LCase(right(fic.Name, 4))
' On ne retient que les fichiers *.url
If ext=".url" Then
nf=nf+1
titre=left(fic.Name,Len(fic.Name)-4)
set curf=fic.OpenAsTextStream(ForReading, TristateUseDefault)
' On lit le fichier et recherche l'item "URL=..."
Do While (curf.AtEndOfStream <>true)
ligne=curf.readline
If lcase(left(ligne,4))="url=" Then
URL=right(ligne,len(ligne)-4)
lenURL=len(URL)
URL2=""
i=1
lmax=80
Do while i<=lenURL
If URL2<>"" Then URL2=URL2 & VBCRLF
URL2=URL2 & " " & mid(URL,i,lmax)
i=i+lmax
Loop
exit Do
End If
Loop
curf.close
ts.writeline "- " & titre & "
"
End If
Next
' Exploration récursive des sous-dossiers
For each folder in collfolders
newfolder=namefolder & "\" & folder.Name
call explorefolder(newfolder,folder.Name)
Next
ts.writeline "
"
end sub
'--------------------------------------------------------------------
' Fonction de récupération du répertoire courant
Function GetPath()
Dim path
path = WScript.ScriptFullName
GetPath = Left(path, InStrRev(path, "\"))
End Function