1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
| ' ----------------------------------------------------------
' 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() & "Mes Sites Favoris .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 "<HTML><head><title>" & "Favoris" & "</title>"
ts.Writeline "<html><head><title>" & Titre & "</title>"
ts.Writeline "<STYLE TYPE=""text/css"">"
ts.Writeline "body {"
ts.Writeline " font-family: Verdana;"
ts.Writeline " font-size: 8 pt }"
ts.Writeline " h1, h2, h3, h4, h5 { font-family: Verdana }"
ts.Writeline "</STYLE></head><body bgcolor=" & ColorBack &">"
ts.WriteLine "<h3>Dossier des favoris : " & fav & "</h3>"
indfav=InstrRev(fav,"\")+1
prec=""
ts.writeline "<ul>"
call explorefolder(fav,"Favoris")
ts.WriteLine "</ul></body></html>"
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 "<li><b>" & curfolder & "</b><ul>"
' 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 "<li><a href=" & chr(34) & URL2 & chr(34) & ">" & titre & "</a></li>"
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 "</ul></li>"
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 |
