' ----------------------------------------------------------
' Script d'affectation d'une icône à un dossier dans l'explorateur
' pour un utilisateur particulier
' Il se lance :
'   - depuis le menu contextuel dans l'explorateur de Windows
'   - depuis une fenêtre de commandes en lui passant en paramètre
'     le dossier à traiter 
'     iconfolder[.vbs] <nom-de-dossier> 
' Ce script s'installe automatiquement (modification BDR)
' en l'exécutant sans aucun paramètre
' Il fait appel à un Contrôle ActiveX d'utilitaires (jcb.ocx)
' pour combler des lacunes de VBS/WSH
'   - boite de dialogue non modale
'   - boites de dialogue avec liste de sélections 
'     à colonnes multiples 
'   - conversion de noms courts en noms longs
'
' JC BELLAMY © 2002
' Dernières modifications :
'  23/10/2002 : ajout de RECYCLER  
'               dans la liste des répertoires non analysés
' ----------------------------------------------------------

Const Normal=0
Const ReadOnly=1
Const Hidden=2
Const System=4
Const Volume=8
Const Directory=16
Const Archive=32
Const Alias=1024
Const Compressed=2048

Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8
Const quote = """"

Const vbLeftButton  = 1
Const vbRightButton = 2


Dim jcbtool,fso,shell,args,lsttool,filesDict
Dim infos,diskArray,disks(),folderobj,dskini
dim TabName,TabValue
Set args  = Wscript.Arguments
set fso     = wscript.CreateObject("Scripting.FileSystemObject")
set shell   = wscript.CreateObject("WScript.Shell")
Set FilesDict = WScript.CreateObject("Scripting.Dictionary")
FilesDict.compareMode=vbTextCompare

jcbCOM="jcb.tools"
TestCOMExists jcbCOM,"jcb.ocx"
TestCOMExists "COMCTL.ListViewCtrl","comctl32.ocx"

set jcbtool = wscript.CreateObject(jcbCOM,"event_")
If args.count=0 Then 
' Auto-installation
	Script=Wscript.ScriptFullName
	register "Folder","iconfolderADD","Icône de dossier (ajout)",script
	MsgBox "Script "& Script &" installé", vbInformation, "Icône de dossier"
	wscript.quit
	end if
curdir=args(0)
If not fso.FolderExists(curdir) Then
	MsgBox "Dossier " & curdir & " inexistant",vbExclamation
	wscript.quit
	end if
curdir=jcbtool.GetLongName(curdir)

sysdir=jcbtool.GetSysDir
If right(sysdir,1)<>"\" Then sysdir=sysdir & "\"
TestLib sysdir,"msvbvm50.dll"

iconlist = getpath() & "iconlist.txt"
dlist=""
If fso.FileExists(iconlist) Then
	set flist=fso.OpenTextFile(iconlist)
	do until flist.atEndOfStream
		line = flist.ReadLine
		pos = Instr(line, ":\")
		DriveName=ucase(mid(line, pos-1,1))
		If instr(dlist,DriveName)=0 Then
			If dlist<>"" Then dlist=dlist & ","
			dlist=dlist & DriveName
			End If
		infos = Split(line, vbTab)
		pos = InstrRev(infos(1), "\")
		FileName=lcase(mid(infos(1), pos+1))
		PathName=lcase(left(infos(1), pos-1))
		NbIcones=CLng(infos(0))
		TestDico FileName,NbIcones,PathName
		loop
	flist.close
	end if
If dlist="" Then
	JobListe=2
	Titre="Création"
	End If

NewDisks=0
Disklist=""
DisklistMAJ=""
for each drive in fso.Drives
	if drive.isReady and drive.DriveType=2 then
		Diskletter=drive.DriveLetter
		DescDisk=quote & Diskletter & quote & "," & quote & drive.VolumeName & quote
		If DiskList<>"" Then DiskList=DiskList & ","
		DiskList=DiskList & DescDisk
		If dlist="" or Instr(dlist,uCase(Diskletter))=0 Then 
			NewDisks=NewDisks+1
			If DiskListMAJ<>"" Then DiskListMAJ=DiskListMAJ & ","
			DiskListMAJ=DiskListMAJ & DescDisk
			end if
		end if
	next
If dlist<>"" Then
	Info="La liste des icônes disponibles existe déjà (" & FilesDict.count & " fichiers)" & VBCRLF 
	Info=Info & "(Disques déjà analysés : " & dlist & ")" 
	prompt="Faut-il la :" 
	If NewDisks>0 Then Label2="mettre à jour" else Label2=""
	rep=jcbtool.MsgBox3(info,prompt,"Icônes de dossiers","conserver",Label2,"remplacer")
	Select Case rep
		Case 1 
			JobListe=0
		Case 2
			JobListe=1
			Titre="Mise à jour"
			Disklist=DisklistMAJ
		Case 3
			JobListe=2
			Titre="Remplacement"
			FilesDict.RemoveAll 
		Case else
			wscript.quit
		End Select
	end if

If JobListe<>0 Then
	Titre=Titre & " de la liste des icônes disponibles sur disques"
	jcbtool.cleardialog
	jcbtool.Globalheader "Disques", 40, 0, "Noms de volume",100, 0
	execute "jcbtool.GlobalAddItem " &  DiskList
	LblInfos="Sélectionner les disques à analyser dans la liste :"
	If JobListe=1 Then LblInfos=LblInfos & VBCRLF & "(Disques déjà analysés : " & dlist & ")"
	jcbtool.SetInfo LblInfos
	jcbtool.Sort 0, 0
	jcbtool.MultiEdit = false
	jcbtool.MultiSelect = true
	jcbtool.EnableClic=false
	set result = jcbtool.Show("Recherche d'icônes")
	Ndisk=result.Count
	If Ndisk>0 Then
		redim disks(ndisk)
		For i = 1 To Ndisk
			diskArray = Split(result(i), vbCrLf)
			Disks(i-1) = diskArray(0)
			If Dlist<>"" Then Dlist=Dlist & ","
			dlist=dlist & Disks(i-1)
			Next
	else
		wscript.quit
		end if
	quit = false
	iconfilecount = 0
	icons = 0
' Affichage boite non modale de progression
	jcbtool.ShowProgressDialog("Recherche d'icônes")
	End If
If not fso.FileExists(iconlist) or Dlist="" Then
	jcbtool.CloseDialog
	wscript.quit
	end if
On error goto 0

jcbtool.cleardialog
jcbtool.GlobalHeader "Fichier",30,0,"Icônes",20,1,"Chemin",60,0

' Lecture du dictionnaire liste des icônes
TabName  = FilesDict.Keys   
TabValue = FilesDict.Items
For i = 0 To FilesDict.Count -1 
	pos=Instr(TabValue(i),",")
	CurNb=left(TabValue(i),pos-1)
	CurPath=mid(TabValue(i),pos+1)
	jcbtool.GlobalAddItem TabName(i),FormatStrR(CurNb,4),CurPath
	Next

' Tri décroissant sur le nombre d'icônes
jcbtool.Sort 1, 1
jcbtool.MultiEdit = true
jcbtool.MultiSelect = false
jcbtool.EnableClic=true
Info="Affectation d'icône au dossier " & Curdir & VBCRLF
Info=Info & "Sélectionner un fichier icône dans la liste" & VBCRLF
Info=Info & "(Cliquer sur un titre de colonne pour la trier)"
jcbtool.SetInfo Info
' boucle d'attente de sélection d'une icône (ou annulation)
done=false
do
	set result = jcbtool.Show("Icônes de dossiers")
    if result.Count>0 then
		fileinfo = Split(result(1), vbCrLf)
        iconfile = fileinfo(2) & "\" & fileinfo(0)
		selectedicon = jcbtool.PickIcon(iconfile)
		if selectedicon <> "" then done = true
     else
		done = true
     end if
loop until done

if selectedicon = "" then wscript.quit
p=instr(selectedicon,",")
iconfile=left(selectedicon,p-1)
iconnumber=mid(selectedicon,p+1)
If right(curdir,1)<>"\" Then curdir=curdir & "\"
desktopini=Curdir & "desktop.ini"

OldLines=""
OldInfoTip=""
If fso.FileExists(desktopini) Then
	Dim lines,KeepLines()
	Set f=fso.getfile(desktopini)
	f.attributes=f.attributes and not System
	f.attributes=f.attributes and not Hidden
	Set dskini=fso.OpenTextFile(desktopini, ForReading, true)
	Content=dskini.ReadAll
	dskini.close
	Lines=split(Content,VBCRLF)
	lineMin=Lbound(Lines)
	lineMax=Ubound(Lines)
	nbLines=lineMax-lineMin+1
	redim KeepLines(nblines)

	For i = lineMin To LineMax
		KeepLines(i)=true
		p=instr(Lines(i),"=")
		If p>0 Then	
			Entry=lcase(trim(left(lines(i),p-1)))
			Value=ltrim(mid(lines(i),p+1))
			Select Case Entry
				Case "iconfile","iconindex","confirmfileop"
					KeepLines(i)=false
				Case "infotip"
					KeepLines(i)=false
					OldInfoTip=Value
				End Select
		else
			Lines(i)=lcase(trim(lines(i)))
			If Lines(i)= "[.shellclassinfo]" Then KeepLines(i)=false
			end if
		If KeepLines(i) Then
			If OldLines<>"" Then OldLines=OldLines & VBCRLF
			If Lines(i)<>"" Then OldLines=OldLines & Lines(i)		
			End If
		Next
	end if
Set dskini=fso.OpenTextFile(desktopini, ForWriting, true)
dskini.WriteLine "[.ShellClassInfo]"
dskini.WriteLine "IconFile=" & iconfile
dskini.WriteLine "IconIndex=" & iconnumber
dskini.WriteLine "ConfirmFileOp=0"
If OldInfoTip="" Then OldInfoTip="Dossier " & Curdir
InfoTip=InputBox("Information complémentaire" & VBCRLF & "(facultative)","Icône du dossier " & Curdir, OldInfoTip)
dskini.WriteLine "InfoTip=" & InfoTip
If OldLines<>"" Then dskini.WriteLine OldLines
dskini.close

Set f=fso.getfile(desktopini)
f.attributes=f.attributes or System
f.attributes=f.attributes or Hidden

jcbtool.RefreshDesktop
Set f=fso.Getfolder(curdir)
f.attributes=f.attributes or System
jcbtool.RefreshDesktop

prompt="L'icône n° " & iconnumber & " du fichier" & VBCRLF
prompt=prompt & iconfile & VBCRLF
prompt=prompt & "a été affectée au dossier" & VBCRLF
prompt=prompt & Curdir
msgbox prompt,vbInformation,"Icônes de dossier" 
wscript.quit

'--------------------------------------------------------------------
sub Event_WakeUp
' Liaison avec la boite de progression non modale
For i = 0 To ndisk - 1
	if quit then 
		shell.Popup "Recherche interrompue...", 1,"Recherche d'icônes",16
        jcbtool.CloseDialog
	    exit sub
		end if
	set folderobj=fso.GetFolder(Disks(i) & ":\")	
	SearchFolder folderobj  
	next
'shell.Popup "Terminé!", 1,"Recherche d'icônes",48
set flist = fso.OpenTextFile(iconlist,ForWriting, true)
TabName  = FilesDict.Keys   
TabValue = FilesDict.Items
jcbtool.SetCaption("Ecriture de la liste d'icônes")
jcbtool.HandleEvent
For i = 0 To FilesDict.Count -1 
	if quit then 
		shell.Popup "Écriture interrompue...", 1,"Ecriture de la liste d'icônes",16
        jcbtool.CloseDialog
		flist.close
	    exit sub
		end if
	percent = Fix(i * 100/FilesDict.Count)
	pos=Instr(TabValue(i),",")
	CurNb=left(TabValue(i),pos-1)
	CurPath=mid(TabValue(i),pos+1)
	flist.writeline CurNb & VBTAB & CurPath & "\" & TabName(i)
	jcbtool.WriteDialog TabName(i)
	jcbtool.SetProgress percent
    jcbtool.HandleEvent
	Next
shell.Popup "Terminé!", 1,"Ecriture de la liste d'icônes",48	
jcbtool.CloseDialog
flist.close
end sub
'--------------------------------------------------------------------
sub event_QuitNow
' Liaison avec la boite de progression non modale
quit = true
end sub
'--------------------------------------------------------------------
sub SearchFolder(folderobj)
' On évite certains dossiers
foldername=lcase(folderobj.name)
if foldername = "recycled" then exit sub
if foldername = "dllcache" then exit sub
if foldername = "system volume information" then exit sub
if foldername = "temp" then exit sub
if foldername = "tmp" then exit sub
If left(foldername,1) = "$" then exit sub 
If instr(foldername,"temporary internet files")>0 Then exit sub 
If instr(foldername,"recycler")>0 Then exit sub 
' Recherche des icônes
counter = 0
filecount = folderobj.files.count
If err<>0 Then	exit sub
drv = folderobj.Drive.Driveletter
for each file in folderobj.files
	if quit then exit sub
	counter = counter +1
	percent = Fix(counter * 100/filecount)
	Message="Analyse du disque " & drv & VBCRLF
	Message=Message & lcase(folderobj.path) & VBCRLF & lcase(file.name) & VBCRLF
	Message=Message & "On a trouvé " & iconfilecount & " fichier" & pluriel(iconfilecount) & VBCRLF
	Message=Message & "et " & icons & " icône" & pluriel(icons)
    jcbtool.WriteDialog Message
	jcbtool.SetProgress percent
    jcbtool.HandleEvent
' Nombre d'icônes dans le fichier
	If IsIconFile(file.name) Then 
	    iconcount = jcbtool.GetIconNumber(file.path)
		if iconcount>0 then
			pos=instrRev(file.path,"\")
			PathName=left(file.path,pos-1)
			TestDico lcase(file.Name),iconcount,lcase(PathName)
			iconfilecount = iconfilecount+1
			icons = icons + iconcount
			end if
		End If
    next
for each subfolder in folderobj.subfolders
    if quit then exit sub
    SearchFolder subfolder
	next
end sub
'--------------------------------------------------------------------
Function IsIconFile(FileName)
IsIconFile=false
p=InstrRev(FileName,".")
If p>0 Then 
	Extent=lcase(mid(FileName,p+1))
	Select Case Extent
		Case "ico"
			IsIconFile=true
		Case "icl","nil","il"
			IsIconFile=true
		Case "exe","dll","drv","ocx","vbx","cpl","scr" 
			IsIconFile=true
		End Select
	End If
End Function
'--------------------------------------------------------------------
Function Pluriel(n)
If n<2 Then pluriel="" else pluriel="s"
End Function
'--------------------------------------------------------------------
Sub register(typefic,clef,item,script)
Key="HKEY_CLASSES_ROOT\" & typefic & "\shell\" & clef & "\"
shell.RegWrite Key,item
Command="wscript """ & Script & """ ""%1"""
shell.RegWrite Key & "command\",Command
End Sub
'--------------------------------------------------------------------
Sub Setattrib(f,att)
Attrib=f.Attributes
If Attrib and att=0 Then f.Attributes=Attrib+att
End Sub
'--------------------------------------------------------------------
Sub Resetattrib(f,att)
Attrib=f.Attributes
If Attrib and att<>0 Then f.Attributes=Attrib-att
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
'--------------------------------------------------------------------
Sub TestCOMExists(name,module)
' Vérification d'installation d'un objet COM
on error resume next
clef="HKCR\" & name & "\"
dummy = shell.RegRead(Clef)
if err.number<>0 then 
' contrôle ActiveX non enregistré
	pathmodule=getpath()& module
	If not fso.fileExists(pathmodule) Then
		Mess = "Le contrôle ActiveX " & name & " est requis." & VBCRLF
		Mess=Mess & "Il est contenu dans le fichier " & module & VBCRLF
		Mess=Mess & "Or ce fichier n'a pas été trouvé." & VBCRLF
		Mess=Mess & "Veuillez réinstaller le logiciel IconFolder"
		MsgBox Mess, vbOKOnly + vbExclamation
		wscript.quit
		End If
	err.clear
	shell.Run "regsvr32.exe " & quote & pathmodule & quote, SW_SHOWNORMAL,true
	dummy = shell.RegRead("HKCR\" & name & "\")
	if err.number<>0 then 
		Mess = "Le contrôle ActiveX " & name & " n'a pas pu être enregistré"
		MsgBox Mess, vbExclamation
		wscript.quit
		end if	
	end if
End Sub
'--------------------------------------------------------------------
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
'--------------------------------------------------------------------
Sub Testlib(Dir,Lib)
LibName=Dir & Lib
LibRef=getpath() & Lib
If not fso.fileExists(LibName) Then
	If not fso.fileExists(LibRef) Then
		Mess = "La librairie " & libName & " est requise." & VBCRLF
		Mess=Mess & "Or ce fichier n'a pas été trouvé" & VBCRLF
		Mess=Mess & "Veuillez réinstaller le logiciel IconFolder"
		MsgBox Mess, vbOKOnly + vbExclamation
		wscript.quit
		End If
	fso.copyfile LibRef,LibName,true	
	End If
End Sub
'--------------------------------------------------------------------
Sub TestDico(FileName,NbIcones,PathName)
CurItem=NbIcones & "," & PathName
' Test d'existence du fichier dans le dictionnaire
If FilesDict.Exists(FileName) Then
	Value=FilesDict.Item(FileName) 
	pos=Instr(Value,",")
	CurNb=left(Value,pos-1)
' On remplace si le nombre d'icônes du fichier courant est supérieur
	If CurNb<NbIcones Then FilesDict.Item(FileName)=CurItem
Else
	FilesDict.Add FileName, CurItem
	End If
End Sub
'--------------------------------------------------------------------