LNKUPDATER

---

Commentaire sur cette source (0)
Ajouter un commentaire et/ou une note

Assemblage de quelques extraits de code VBS, permettant de mettre à jour tous les racourcis Windows se trouvant dans un répertoire donné (ainsi que dans tous ses sous-répertoires).

Par exemple, si vous avez des documents sous X: et un dossier avec des raccourcis s'y rattachant, et que vous déplacez les documents sous Y:, ce script vous permettra de remplacer "X:" par "Y:" dans tous les raccourcis.

'-----------------------------------------------------
'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

Si vous spécifiez une destination qui n'existe pas (par exemple, changer "X:\" pour "toto:\"), les raccourcis seront modifiés, mais à l'appel ils reviendront à leur cible initiale.

Je n'ai jamais essayé ce script sur une racine... Quoi qu'il en soit, testez-le d'abord sur des fichiers et raccourcis bidon !

A la base, j'ai assemblé ce script pour mettre à jour tous les raccourcis dans "Documents and Settings", après le déplacement de "Program Files" sur une autre partition. Mais tout ceci fera prochainement l'objet d'un article sur technos-sources.com !

Pour les "Membres Club", vous pouvez télécharger directement un fichier contenu dans le zip sans télécharger le zip en entier !

Télécharger le zip

31 octobre 2007 12:02:22 :

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

• CHIFFRE DE VIGENÈRE

• LAUTREESIZE
• MP3REN - RENOMMEUR DE MP3
• [VB6] YMXPLORER : DOUBLE EXPLORATEUR DE FICHIERS
• CREATION DE FICHIER ASX POUR LECTURE EN STREAMING SUR UN SITE WEB
• CHKDSKSPC- CHECK DISK SPACE / AFFICHAGE DE L'ÉTAT D'OCCUPATION DES DISQUES

• LE DÉFLÈCHEUR
• SETFILEDATE
• CHANGER LA RESOLUTION AFFICHAGE WINDOWS (+ COULEUR + FREQUENCE)
• CHANGER LA DATE
• CHANGER LA RESOLUTION DE WINDOWS