Thomas' Work Space

'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