Home > service-is-configuring-learning-tools, service-is-programming, sourcecode > How to map network shares using VBScript and WMI

## How to map network shares using VBScript and WMI

1. Cannot get IT to map network drives that your users need for your departmental applications (Users? Cannot get users to map them manually in Windows. VBScript to the rescue, here is an example VBScript that uses WMI and employs some error checking:
```'search for TOADAPT and customize to your environment
'todo: is the default host wscript? if not, will user see messages from cscript like "Drive letters changed, please reboot to see the change, then rerun this program!" "
Option Explicit
'On error resume next 'When debugging, always disable

Const HKLM = &H80000002 'for ChangeDrvLetter
Dim objNetwork
Set objNetwork = CreateObject("WScript.Network")

Dim strUser 'set at beginning
Dim strLogFileLocation 'set at beginning
strLogFileLocation = "\\nebraska\Sanako_3\trp\lang\map_sanako\users\"  'trailing backslash; user needs write permission
Dim strLogFilePath
Dim strMessage 'set within program flow

dim blnForce
blnForce = true

Dim blnUpdateProfile
blnUpdateProfile = true

dim strComputer
strComputer = "."
Dim objWMIService
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Dim colDisks, objDisk
Dim colVolumes, objVolume
Dim astrDriveLetters, strDriveLetter
Dim astrRemotePaths, strRemotePath
astrDriveLetters = array("K:", "L:", "M:","V:")
Dim intMatchCounter
intMatchCounter = 0
Dim i
dim strFreeDriveLetter
Dim blnExecute
blnExecute =True
Dim intDrives
intDrives = ubound(astrDriveLetters)

'For Each strDriveLetter In astrDriveLetters
for  i=0 to intDrives  '-1
strDriveLetter  = astrDriveLetters(i)
strRemotePath= astrRemotePaths(i)
' check drive types
Set colDisks = objWMIService.ExecQuery ("Select * from Win32_LogicalDisk where DeviceID = '" & strDriveLetter & "'")
'Set colDisks = objWMIService.ExecQuery ("Select * from Win32_LogicalDisk where DeviceID = 'V:'") 'todo:release
For Each objDisk in colDisks 'todo: if strDriveletter not already in use, this should fail quietly - or does it 80041017 The error means the query was invalid

Select Case objDisk.DriveType
Case 1
' No root directory. Drive type could not be determined.
' todo: do nothing, handle later
blnExecute = False
Call logUserResults(strLogFileLocation, strUser, Left(strDriveLetter,1) & "_case1" )
Case 2
'Removable drive --> dismount: wmi cannot do this on xp
'todo: really, for a floppy?
'Set colVolumes = objWMIService1.ExecQuery ("Select * From Win32_Volume Where Name = "& strDriveletter & "\\") '   todo:Win32_Volume isn't availble on windows xp or earlier.
'For Each objVolume in colVolumes 				 	returncode = objVolume.Dismount(True, True) next
'blnExecute = true
Dim strWarning
strWarning = "Please first remove your drive " & strDriveLetter & ", then restart this program."
WScript.Echo strWarning
Call logUserResults(strLogFileLocation, strUser, Left(strDriveLetter,1) & "_case2" )
WScript.Quit
'oder get wmi:ejectname like 'USB Mass Storage Device' (das ist aber nicht unique)
'Call shell and run from same folder as script deveject -EjectDrive:<Drive>|-EjectName:<Name>|-EjectId:<DeviceId> [-v] [-Debug]
Case 3
' Local hard disk. -> change drive letter,
if isSystemDrive(strDriveLetter) then'unless system drive
'do nothing
blnExecute = False
Call logUserResults(strLogFileLocation, strUser, Left(strDriveLetter,1) & "_case3" )
else  ' alter
' Script that changes drive letters
' Note: Do NOT use it on SYSTEM or BOOT partition drive letters !!!
' Author: Torgeir Bakken
' from/to
strFreeDriveLetter = FreeDrive()
If ChangeDrvLetter(strDriveLetter, strFreeDriveLetter) Then
WScript.Echo "Drive letters changed, please reboot to see the change, then rerun this program!"
WScript.Quit '[exitcode]
Else
'WScript.Echo "Failed changing drive letters!"
' todo: do not know how to handle this, do nothing for now
blnExecute = False
Call logUserResults(strLogFileLocation, strUser, Left(strDriveLetter,1) & "_case3_failedchanging" )
End If
end if
Case 4
'Network disk -> removenetworkdrive
Set objNetwork = CreateObject("WScript.Network")
objNetwork.removeNetworkDrive strDriveLetter, blnForce, blnUpdateProfile 'done: this errors if drive is not mapped
'force tut es nicht "this network connection has files open or requests pending":
'you're running the script from Z: and trying to unmap/map Z: in the script
blnExecute = true
Case 5
'Compact disk --> change drive letter
' Script that changes drive letters
' Note: Do NOT use it on SYSTEM or BOOT partition drive letters !!!
' Author: Torgeir Bakken
' from/to
strFreeDriveLetter = FreeDrive()
If ChangeDrvLetter(strDriveLetter, strFreeDriveLetter) Then
WScript.Echo "Drive letters changed, please reboot to see the change, then rerun this program!"
WScript.Quit '[exitcode]
Else
'WScript.Echo "Failed changing drive letters!"
' todo: do not know how to handle this, do nothing for now
blnExecute = False
Call logUserResults(strLogFileLocation, strUser, Left(strDriveLetter,1) & "_case5failedchanging" )
End If
Case 6
'RAM disk.
' todo: do nothing, handle later
blnExecute = False
Call logUserResults(strLogFileLocation, strUser, Left(strDriveLetter,1) & "_case6" )
Case Else
'Drive type could not be determined."
' todo: do not know how to handle this
blnExecute = False
Call  logUserResults(strLogFileLocation, strUser, Left(strDriveLetter,1) & "_caseelse" )
End Select
next 'objdisk within coldisk with strdriveletter

if blnExecute then 'drive letter is free for use
'need to reconnect on logon
'five possible arguments for MapNetworkDrive: objNetwork.MapNetworkDrive:
'1) strDriveLetter, 2) strRemotePath, 3) blnUpdateProfile, 4) strUser, 5) strPassword.
objNetwork.MapNetworkDrive strDriveLetter, strRemotePath, blnUpdateProfile
Call  logUserResults(strLogFileLocation, strUser, Left(strDriveLetter,1) & "_success" )
end if

next 'driveletter

'ergebnis demonstriern
dim shobj
Set ShObj = CreateObject("wscript.shell")
ShObj.run "explorer.exe /select,z:\"

WScript.Quit

Function logUserResults(strLogFileLocation, strUser, strMessage)
Dim objFSO
dim objFile
Set objFSO = CreateObject("Scripting.FileSystemObject")
strLogFilePath = strLogFileLocation & strUser & "_"& strMessage & ".txt"
Set objFile = objFSO.CreateTextFile(strLogFilePath, true) 'overwrite is better than erroring
End Function

Function ChangeDrvLetter(sSourceDrive, sTargetDrive)
Dim bOk, oReg, sKeyPath , sSrc , sValue, iRC, sTrg
bOk = True  ' Init value
Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")

sKeyPath = "SYSTEM\MountedDevices"
sSrc = "\DosDevices\" & UCase(sSourceDrive)

iRC = oReg.GetBinaryValue(HKLM, sKeyPath, sSrc, sValue) 'getbinaryvalue outputs result into svalue (can be aray, see http://msdn2.microsoft.com/en-us/library/aa394600(VS.85).aspx)

If iRC = 0 Then
sTrg = "\DosDevices\" & UCase(sTargetDrive)

iRC = oReg.SetBinaryValue(HKLM, sKeyPath, sTrg, sValue)

If iRC = 0 Then
oReg.DeleteValue HKLM, sKeyPath, sSrc
Else
bOK = False
End If
Else
bOK = False
End If
ChangeDrvLetter = bOK
End Function

'Michael Harris
Function FreeDrive
Dim I, oFso
Set oFso = CreateObject("Scripting.FileSystemObject")
For I = Asc("D") to Asc("U")
If Not oFso.DriveExists(Chr(I)) Then
Freedrive = Chr(I) & ":"
Exit Function
End If
Next
End Function

function Get_System_Drive()
Dim objShell, strSystemDrv
Set objShell = WScript.CreateObject ("WScript.Shell")
strSystemDrv = objShell.ExpandEnvironmentStrings("%SYSTEMDRIVE%")
Get_System_Drive = strSystemDrv
end function

function isSystemDrive(strDriveLetter)
if strDriveletter = Get_System_Drive() then
isSystemDrive = true
else
isSystemDrive = false
end if
End function ```
2. This script will also emit a poor man’s log,  in the file system on the network share, per users and drives that could be mapped, for them, like in this example:
3. More recently, I had to do the same for ALL users, including the Sanako Student Player installation, using AutoIt.