'RemapShares.vbs
'Change mapping of shares, runs in logon script
'Alan dot Kaplan at VA dot gov
'3/10/2010

On Error Resume Next
strcomputer = "."
Set WshNetwork = WScript.CreateObject("WScript.Network")
Dim d  
Set d = CreateObject("Scripting.Dictionary")
dim wshShell
Set wshShell = WScript.CreateObject("WScript.Shell")

'Edit this Old Path in CAPS, new path
'examples
d.Add "OLDSERVERNAME1", "NEWSERVNAME1" 
d.Add "OLDSERVERNAME2\OLDSHARE2", "NEWSERVERNAME2\NEWSHARE2"
d.Add "OLDSERVERNAME3", "NEWSERVERNAME3\NEWSHARE3"
OldPaths = d.Keys
NewPaths = d.items

Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_NetworkConnection where Localname !=Null",,48)

For Each objItem In colItems
	If objItem.ResourceType = "Disk" then
    	RemapDrive objItem.LocalName, UCASE(objItem.RemotePath), objItem.Persistent
   End If 
Next

Function RemapDrive(strDrive,strRemotePath,bPersistent)
	For i = 0 To d.Count -1 				'Iterate the dictionary object
		If InStr(strRemotePath,Ucase(OldPaths(i))) Then 
		   'wshshell.popup OldPaths(i) & " should be replaced by " & NewPaths(i) 
		   'Unmap drive
		   'wshshell.popup "Unmapping drive"
		   wshnetwork.removenetworkdrive strDrive,True,True
		   strPath = Replace(strRemotePath,OldPaths(i),NewPaths(i))
		   'wshshell.popup "IRM is changing mapping of " & strDrive & " from " & strRemotePath & " to new server location " & strPath,3,"Please wait"
		   WshNetwork.MapNetworkDrive strDrive,strPath,bPersistent
		End If 
	Next
End Function