LNKUPDATER

'-----------------------------------------------------
'Titre : lnkUpdater
'Fonction : Parcours récursif d'un répertoire pour mettre à jour les raccourcis qu'il contient (en cas de déplacement de la cible)
'Auteur : Vladislav IV
'Date : 14/04/2007

'+-----Sources-----+
'http://www.vbfrance.com
'http://vb.developpez.com
'http://www.bellamyjc.org
'-----------------------------------------------------


'-----Fonctions et procédures-----
sub updateLink(cheminLnk, ancienneChaine, nouvelleChaine)
	'remplace toutes les occurences de ancienneChaine par nouvelleChaine dans la cible et le répertoire de travail du raccourcis
	set lnk = WshShell.CreateShortcut(cheminLnk)
	lnk.TargetPath = replace(lnk.TargetPath, ancienneChaine, nouvelleChaine)
	lnk.WorkingDirectory = replace(lnk.WorkingDirectory, ancienneChaine, nouvelleChaine)
	lnk.Save
end sub


sub updateDir(rep, ancienneChaine, nouvelleChaine)
	'traite les raccourcis contenus dans le répertoire, puis récursivement tous les sous-répertoires
	Dim FSO, ssrep, racc
	Set FSO = CreateObject("Scripting.FileSystemObject")
	If FSO.FolderExists(rep) Then
		'traite les raccourcis
		For each racc in FSO.GetFolder(rep).Files
			if right(racc, len(racc) -InstrRev(racc, ".")) = "lnk" then	'vérifie si le fichier porte bien l'extension d'un raccourci
				call updateLink(racc, ancienneChaine, nouvelleChaine)
			end if
		Next
		
		'traite les sous-répertoires
		For each ssrep in  FSO.GetFolder(rep).SubFolders
			call updateDir(ssrep, ancienneChaine, nouvelleChaine)
		Next
	End If
end sub

' ----------------------------------------------------------
' Script VBS de boite de dialogue de sélection de dossier
' JC BELLAMY © 2001
' ----------------------------------------------------------
'ce code a été modifié par mes soins, allez voir www.bellamyjc.org pour l'original.
function BrowseForDir()
	BIF_returnonlyfsdirs   = &H0001
	BIF_dontgobelowdomain  = &H0002
	BIF_editbox            = &H0010
	BIF_validate           = &H0020
	BIF_browseforcomputer  = &H1000

	Dim shell, item
	Set shell = WScript.CreateObject("Shell.Application")
	flag = BIF_returnonlyfsdirs 
	titre = "Choisir un répertoire"
	Set Item = shell.BrowseForFolder(0,titre,flag, dirinit)
	If IsValue(Item) Then
		Result = Item.Title
		' Test si on a sélectionné la racine d'une partition 
		recherche = InStr(1, Result, ":")
		If recherche = 0 Then
			'pas racine
			Result = Item.ParentFolder.ParseName(Item.Title).Path
		else
			'racine, récupère la lettre de lecteur (avec ':')
			Result = Mid(Result, recherche-1, 2)
			msg = "Vous avez sélectionné une racine. Le traitement peut prendre du temps, et compromettre l'intégrité de votre ordinateur. Confirmez-vous votre choix ?"
			ok = MsgBox(msg, vbOkCancel, "Attention !")
			if ok = vbCancel then
				Result = ""
			end if
		End If
	else
		Result = ""
	End If
	BrowseForDir = Result
end function

' Test de validité de l'objet retourné par BrowseForFolder
' On ne peut pas utiliser "IsObject", qui retourne toujours "true"
Function IsValue(obj)
	Dim tmp
	On Error Resume Next
	tmp = " " & obj
	If Err <> 0 Then IsValue = False Else IsValue = True
	On Error GoTo 0
End Function
' ----------------------------------------------------------


'-----Programme principal-----
set WshShell = WScript.CreateObject("WScript.Shell")
rep = BrowseForDir()	'sélection du répertoire
if rep <> "" then
	ancienneChaine = InputBox("Chaine à rechercher (ne peut être vide)")
	if ancienneChaine <> "" then
		nouvelleChaine = InputBox("Remplacer par")
		if ancienneChaine = nouvelleChaine then
			MsgBox "Traitement inutile : vous avez entré deux valeurs identiques.", vbCritical
		else
			if MsgBox("Lancer le traitement ?", vbYesNo) = vbYes then
				call updateDir(rep, ancienneChaine, nouvelleChaine)	'lance le traitement
				MsgBox "Traitement effectué."
			end if
		end if
	end if
end if

Télécharger le zip

31 octobre 2007 12:02:22 :

Retrait de mon nom de la source pour éviter le harcèlement.