?
Solved

VB Script for Renaming LNK target and working directory

Posted on 2015-02-10
10
Medium Priority
?
181 Views
Last Modified: 2015-02-11
Hi there,

I need a vbscript that will rename the target and working directory in LNK files located in a folder and its sub-folders.

It will be called from a batch file.

cscript //nologo RenameLnkFiles.vbs "C:\My Documents" "\\server1" "\\server2"
"C:\My Documents" = Working folder (including its subfolders)
"\\server1" = Replace this from all UNCs by "\\server2"

I hope I express my need clearly ennough.  If you have any questions, please let me know.

Thanks for your help,
Rene
0
Comment
Question by:ReneGe
  • 7
  • 3
10 Comments
 
LVL 85

Accepted Solution

by:
oBdA earned 2000 total points
ID: 40602596
Try this; it's currently in test mode and will not save the updated shortcuts. Uncomment line 26 to run it for real.
strSourceFolder = WScript.Arguments(0)
strFind = WScript.Arguments(1)
strReplaceWith = WScript.Arguments(2)

Sub ReplaceInShortcutRecurse(objStartFolder, strFind, strReplaceWith)
	Set objThisFolder = objFSO.GetFolder(objStartFolder.Path)
	Set colFiles = objThisFolder.Files
	On Error Resume Next
	For Each objFile in colFiles
		If Err.Number <> 0 Then
			Err.Clear
		Else
			bSave = False
			If UCase(objFSO.GetExtensionName(objFile.Path)) = "LNK" Then
				Wscript.StdOut.Write "Processing '" & objFile.Path & "' ... "
				Set objShortcut = objWSH.CreateShortcut(objFile.Path)
				If InStr(objShortcut.TargetPath, strFind) <> 0 Then
					objShortcut.TargetPath = Replace(objShortcut.TargetPath, strFind, strReplaceWith)
					bSave = True
				End If
				If InStr(objShortcut.WorkingDirectory, strFind) <> 0 Then
					objShortcut.WorkingDirectory = Replace(objShortcut.WorkingDirectory, strFind, strReplaceWith)
					bSave = True
				End If
				If bSave Then
					' objShortcut.Save()
					If Err.Number <> 0 Then
						Wscript.StdOut.WriteLine
						WScript.StdOut.WriteLine "ERROR " & Err.Number & ": " & Err.Description
						Err.Clear
					Else
						Wscript.StdOut.WriteLine "updated."
					End If
				Else
					Wscript.StdOut.WriteLine "search string not found."
				End If
			End If
		End If
	Next
	For Each objSubfolder in objStartFolder.SubFolders
		If Err.Number <> 0 Then
			Err.Clear
		Else
			Call ReplaceInShortcutRecurse(objSubfolder, strFind, strReplaceWith)
		End If
	Next
	On Error Goto 0
End Sub

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objWSH = CreateObject("Wscript.Shell")
Set objSourceFolder = objFSO.GetFolder(strSourceFolder)
Call ReplaceInShortcutRecurse(objSourceFolder, strFind, strReplaceWith)

Open in new window

0
 
LVL 10

Author Comment

by:ReneGe
ID: 40603102
Hey oBda :) Its been a while!

Thanks a lot for your help.

I un-commented line 26.

LNK target nor their working dir was not changed.

Here is my output.

C:\BatchFiles\Replace LNK>C:\Windows\System32\cscript.exe //nologo "C:\BatchFiles\Replace LNK\ReplaceLNK.vbs" "C:\BatchFiles\Replace LNK" "C:\BatchFiles\Replace LNK\1" "C:\BatchFiles\Replace LNK\2"
Processing 'C:\BatchFiles\Replace LNK\Shortcuts\File1.txt.lnk' ... search string not found.
Processing 'C:\BatchFiles\Replace LNK\Shortcuts\File2.txt.lnk' ... search string not found.

Cheers,
Rene
0
 
LVL 10

Author Comment

by:ReneGe
ID: 40603123
For your conveniance, here is the dir of that folder.

C:\BatchFiles\Replace LNK\1
C:\BatchFiles\Replace LNK\2
C:\BatchFiles\Replace LNK\ReplaceLNK.bat
C:\BatchFiles\Replace LNK\ReplaceLNK.vbs
C:\BatchFiles\Replace LNK\Shortcuts
C:\BatchFiles\Replace LNK\Shortcuts\File1.txt.lnk
C:\BatchFiles\Replace LNK\Shortcuts\File2.txt.lnk
C:\BatchFiles\Replace LNK\1\File1.txt
C:\BatchFiles\Replace LNK\1\File2.txt
C:\BatchFiles\Replace LNK\2\File1.txt
C:\BatchFiles\Replace LNK\2\File2.txt

So basically, the vbscript as executed from the command line, should replace the "target" and "working directory" of both "File1.txt.lnk" and "File2.txt.lnk" to point to the folder "C:\BatchFiles\Replace LNK\2"

Thanks
0
Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
LVL 85

Expert Comment

by:oBdA
ID: 40603185
This now supports a debug mode where it prints out what happened:
strSourceFolder = WScript.Arguments(0)
strFind = WScript.Arguments(1)
strReplaceWith = WScript.Arguments(2)
bDebug = True

Sub ReplaceInShortcutRecurse(objStartFolder, strFind, strReplaceWith)
	Set objThisFolder = objFSO.GetFolder(objStartFolder.Path)
	Set colFiles = objThisFolder.Files
	On Error Resume Next
	For Each objFile in colFiles
		If Err.Number <> 0 Then
			Err.Clear
		Else
			bSave = False
			If UCase(objFSO.GetExtensionName(objFile.Path)) = "LNK" Then
				Wscript.StdOut.Write "Processing '" & objFile.Path & "' ... "
				Set objShortcut = objWSH.CreateShortcut(objFile.Path)
				strOldTargetPath = objShortcut.TargetPath
				If InStr(objShortcut.TargetPath, strFind) <> 0 Then
					strNewTargetPath = Replace(strOldTargetPath, strFind, strReplaceWith)
					objShortcut.TargetPath = strNewTargetPath
					bSave = True
				Else
					strNewTargetPath = objShortcut.TargetPath
				End If
				strOldWorkingDirectory = objShortcut.WorkingDirectory
				If InStr(objShortcut.WorkingDirectory, strFind) <> 0 Then
					strNewWorkingDirectory = Replace(objShortcut.WorkingDirectory, strFind, strReplaceWith)
					objShortcut.WorkingDirectory = strNewWorkingDirectory
					bSave = True
				Else
					strNewWorkingDirectory = objShortcut.WorkingDirectory
				End If
				If bSave Then
					objShortcut.Save()
					If Err.Number <> 0 Then
						Wscript.StdOut.WriteLine
						WScript.StdOut.WriteLine "ERROR " & Err.Number & ": " & Err.Description
						Err.Clear
					Else
						Wscript.StdOut.WriteLine "updated."
					End If
					If bDebug Then
						Wscript.StdOut.WriteLine vbTab & "Target path: '" & strOldTargetPath & "' --> '" & strNewTargetPath & "'"
						Wscript.StdOut.WriteLine vbTab & "Working dir: '" & strOldWorkingDirectory & "' --> '" & strNewWorkingDirectory & "'"
					End If
				Else
					Wscript.StdOut.WriteLine "search string not found."
					If bDebug Then
						Wscript.StdOut.WriteLine vbTab & "Target path: '" & objShortcut.TargetPath & "'"
						Wscript.StdOut.WriteLine vbTab & "Working dir: '" & objShortcut.WorkingDirectory & "'"
					End If
				End If
			End If
		End If
	Next
	For Each objSubfolder in objStartFolder.SubFolders
		If Err.Number <> 0 Then
			Err.Clear
		Else
			Call ReplaceInShortcutRecurse(objSubfolder, strFind, strReplaceWith)
		End If
	Next
	On Error Goto 0
End Sub

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objWSH = CreateObject("Wscript.Shell")
Set objSourceFolder = objFSO.GetFolder(strSourceFolder)
Wscript.StdOut.WriteLine "Search string: '" & strFind & "'"
Wscript.StdOut.WriteLine "Replace with:  '" & strReplaceWith & "'"
Call ReplaceInShortcutRecurse(objSourceFolder, strFind, strReplaceWith)

Open in new window

0
 
LVL 10

Author Comment

by:ReneGe
ID: 40603273
Search string: 'C:\BatchFiles\Replace LNK\1'
Replace with:  'C:\BatchFiles\Replace LNK\2'
Processing 'C:\BatchFiles\Replace LNK\Shortcuts\File1.txt.lnk' ... search string not found.
      Target path: 'C:\TEST\Replace LNK\1\File1.txt'
      Working dir: 'C:\TEST\Replace LNK\1'
Processing 'C:\BatchFiles\Replace LNK\Shortcuts\File2.txt.lnk' ... search string not found.
      Target path: 'C:\TEST\Replace LNK\1\File2.txt'
      Working dir: 'C:\TEST\Replace LNK\1'
0
 
LVL 10

Author Comment

by:ReneGe
ID: 40603282
Oops, one moment
0
 
LVL 10

Author Comment

by:ReneGe
ID: 40603299
Sorry about that, this was my mistake.
Your script was working from the start.
I forgot to update the UNCs after moving the files :(

Thanks oBda!

Your script is working like a charm.

Cheers mate :)

Rene
0
 
LVL 10

Author Comment

by:ReneGe
ID: 40603508
Hi oBda

I found that the search is case sensitive.

Can you please tell me how can we make it not case sensitive?

Thanks,
Rene
0
 
LVL 85

Expert Comment

by:oBdA
ID: 40603543
strSourceFolder = WScript.Arguments(0)
strFind = WScript.Arguments(1)
strReplaceWith = WScript.Arguments(2)
bDebug = True

Sub ReplaceInShortcutRecurse(objStartFolder, strFind, strReplaceWith)
	Set objThisFolder = objFSO.GetFolder(objStartFolder.Path)
	Set colFiles = objThisFolder.Files
	On Error Resume Next
	For Each objFile in colFiles
		If Err.Number <> 0 Then
			Err.Clear
		Else
			bSave = False
			If UCase(objFSO.GetExtensionName(objFile.Path)) = "LNK" Then
				Wscript.StdOut.Write "Processing '" & objFile.Path & "' ... "
				Set objShortcut = objWSH.CreateShortcut(objFile.Path)
				strOldTargetPath = objShortcut.TargetPath
				If InStr(1, objShortcut.TargetPath, strFind, 1) <> 0 Then
					strNewTargetPath = Replace(strOldTargetPath, strFind, strReplaceWith, 1, -1, 1)
					objShortcut.TargetPath = strNewTargetPath
					bSave = True
				Else
					strNewTargetPath = objShortcut.TargetPath
				End If
				strOldWorkingDirectory = objShortcut.WorkingDirectory
				If InStr(1, objShortcut.WorkingDirectory, strFind, 1) <> 0 Then
					strNewWorkingDirectory = Replace(objShortcut.WorkingDirectory, strFind, strReplaceWith, 1, -1, 1)
					objShortcut.WorkingDirectory = strNewWorkingDirectory
					bSave = True
				Else
					strNewWorkingDirectory = objShortcut.WorkingDirectory
				End If
				If bSave Then
					objShortcut.Save()
					If Err.Number <> 0 Then
						Wscript.StdOut.WriteLine
						WScript.StdOut.WriteLine "ERROR " & Err.Number & ": " & Err.Description
						Err.Clear
					Else
						Wscript.StdOut.WriteLine "updated."
					End If
					If bDebug Then
						Wscript.StdOut.WriteLine vbTab & "Target path: '" & strOldTargetPath & "' --> '" & strNewTargetPath & "'"
						Wscript.StdOut.WriteLine vbTab & "Working dir: '" & strOldWorkingDirectory & "' --> '" & strNewWorkingDirectory & "'"
					End If
				Else
					Wscript.StdOut.WriteLine "search string not found."
					If bDebug Then
						Wscript.StdOut.WriteLine vbTab & "Target path: '" & objShortcut.TargetPath & "'"
						Wscript.StdOut.WriteLine vbTab & "Working dir: '" & objShortcut.WorkingDirectory & "'"
					End If
				End If
			End If
		End If
	Next
	For Each objSubfolder in objStartFolder.SubFolders
		If Err.Number <> 0 Then
			Err.Clear
		Else
			Call ReplaceInShortcutRecurse(objSubfolder, strFind, strReplaceWith)
		End If
	Next
	On Error Goto 0
End Sub

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objWSH = CreateObject("Wscript.Shell")
Set objSourceFolder = objFSO.GetFolder(strSourceFolder)
Wscript.StdOut.WriteLine "Search string: '" & strFind & "'"
Wscript.StdOut.WriteLine "Replace with:  '" & strReplaceWith & "'"
Call ReplaceInShortcutRecurse(objSourceFolder, strFind, strReplaceWith)

Open in new window

0
 
LVL 10

Author Comment

by:ReneGe
ID: 40603561
Thank you so much!

Cheers mate :)
Rene
0

Featured Post

NEW Veeam Backup for Microsoft Office 365 1.5

With Office 365, it’s your data and your responsibility to protect it. NEW Veeam Backup for Microsoft Office 365 eliminates the risk of losing access to your Office 365 data.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

When you receive another warning that your shared drive is almost full and you have asked your users to clean out old files again and again, here is a single command that may help. This command will place all the files that have not been used rec…
How to remove superseded packages in windows w60 or w61 installation media (.wim) or online system to prevent unnecessary space. w60 means Windows Vista or Windows Server 2008. w61 means Windows 7 or Windows Server 2008 R2. There are various …
Are you ready to place your question in front of subject-matter experts for more timely responses? With the release of Priority Question, Premium Members, Team Accounts and Qualified Experts can now identify the emergent level of their issue, signal…
As many of you are aware about Scanpst.exe utility which is owned by Microsoft itself to repair inaccessible or damaged PST files, but the question is do you really think Scanpst.exe is capable to repair all sorts of PST related corruption issues?
Suggested Courses
Course of the Month17 days, 12 hours left to enroll

830 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question