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
    strUser = objNetwork.UserName
    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
    ' targets aufzählen; TOADAPT
    astrDriveLetters = array("K:", "L:", "M:","V:")
    'sources aufzählen; TOADAPT
    astrRemotePaths = Array("\\nebraska\sanako_1", "\\nebraska\sanako_2", "\\nebraska\sanako_3","\\nebraska\lssvideo") 'todo: escaping? In VBScript, \ is not an escape character (that is for JavaScript).
    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: image
  3. More recently, I had to do the same for ALL users, including the Sanako Student Player installation, using AutoIt.
  1. No comments yet.
  1. No trackbacks yet.

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out /  Change )

Google+ photo

You are commenting using your Google+ account. Log Out /  Change )

Twitter picture

You are commenting using your Twitter account. Log Out /  Change )

Facebook photo

You are commenting using your Facebook account. Log Out /  Change )

Connecting to %s

%d bloggers like this: