' ----------------------------------------------------------
' Script d'affichage des favoris (noms et URL)
' y compris dans les sous-répertoires
'
' Jean-Claude BELLAMY - © 2002
' ----------------------------------------------------------
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.txt"
Set ts=fso.CreateTextFile(FileResult, true,true)
' Récupération du chemin du dossier "Favoris"
Set fldrs = Shell.SpecialFolders
fav=fldrs("Favorites")
ts.WriteLine "Dossier des favoris : " & fav 
indfav=InstrRev(fav,"\")+1
explorefolder(fav)
ts.close

prompt="La liste des favoris a été stockée dans" & VBCRLF & _
"le fichier " & FileResult & VBCRLF & _
"Appuyer sur :" & VBCRLF & _
"  OUI pour l'imprimer" & VBCRLF & _
"  NON pour l'ouvrir avec le bloc-notes"
rep=MsgBox(prompt, vbYesNo + vbQuestion, "Liste des favoris")

If rep=vbYes Then 
	commutateur=" /p " 
	show=SW_HIDE
else 
	commutateur=" "
	show=SW_SHOWNORMAL
	end if
' Impression ou affichage du fichier à l'aide du bloc-notes
commande=shell.ExpandEnvironmentStrings("%windir%\notepad.exe" &  commutateur & chr(34) & FileResult & chr(34)) 
shell.Run commande, show, true
wscript.quit

'----------------------------------------------------
' Sous-programme récursif d'exploration des dossiers
sub	explorefolder(namefolder)
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 VBCRLF & subname
ts.writeline String(len(subname), "-")

' 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 FormatStrR(nf,4) & " " & titre
		ts.writeline URL2
	   End If
	 Next

' Exploration récursive des sous-dossiers
For each folder in collfolders 
	newfolder=namefolder & "\" & folder.Name
	explorefolder(newfolder)
	Next
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
'--------------------------------------------------------------------
Function FormatStrR(ch,lmax)
l=len(ch)
If l<lmax Then 
	For k = l+1 To lmax
		ch=" " & ch
		Next
	End If
FormatStrR=ch
End Function
'--------------------------------------------------------------------