Welcome to EdListen:
Never Stop Learning

Map Drives App

With Chromebooks, tablets, iPads and BYOD becoming so popular I have been changing the way I manage workflow in my network.  One of the top things I have done is change all the student-use Windows machines from logging in each student to using a single profile.   This works well since most students are using Google Apps for their office productivity, however there are a few places like our CAD lab that uploading the files to Google Drive is just not practical.

The solution I found/modified was a simple script originally written by Vaughn Miller that asked for a username and password and could map drives after the computer was turned on.   I modified the script to include a user home folder mapping.    The script is basically a VBS script with an html front end.   The file type is .hta, which when doubl-clicked opens up an internet explorer window.

  1. Open Notepad
  2. Copy the below code into it
  3. Save as filename.hta

 <!-- HTA script to allow machines that are not joined to a domain to access   
    Windows file shares with domain credentials. It will atomatically prepend the   
    domain to the username and then map several drives. If a drive is already   
    mapped, it is disconnected and then mapped for the current user.  
    Version 1.0.2 Written by Vaughn Miller 7/20/2012   
       Version 1.0.3 Modified by Bjorn Behrendt 1/30/14 ~ http://www.edlisten.com  
           ~ Removed looped mapped drive.  Was unneeded for my own situation but probably should get put back in  
           ~ Added home folder mapping. This will map to a folder that matches to the username  
           ~ Now removes all current mapped drives, even if they are not defined in this script. This solves a multiple connections error if there is a current mapped drive.  
 <TITLE>Connect Network Drives</title>  
 ' *** Define Drive Mappings ***  
 dim arrDrives(1,2)  
 intMaxdrives = 1  
 arrDrives(0,0) = "K:"  
 arrDrives(0,1) = "\\server\TShare"  
 arrDrives(0,2) = "TShare"  
 arrDrives(1,0) = "W:"  
 arrDrives(1,1) = "\\server\homefolders\"  
 arrDrives(1,2) = "Username" 'Not used in version 1.0.3  
 ' *** End Drive Map Definitions ***  
 strDOMAIN = "YourDomainName\" 'Domain to prepend to the username  
 msgSuccess = "The following drives have mapped correctly" & vbCrLf & "K: = CadShare" & vbCrLf & "W: = " & strUsr2 & "'s CAD Folder"  
 msgError = "An error occurred while mapping: " & Err2 & vbCrLf & vbCrLf & "Please check your password" & vbCrLf & "If that does not work please restart the computer." & vbCrLf & "If it still does not work after a restart, have your teacher submit a help desk ticket."  
 Sub Window_Onload  
  '# Size Window  
  sHorizontal = 440  
  sVertical = 220  
  Window.resizeTo sHorizontal, sVertical  
  '# Get Monitor Details  
  Set objWMIService = GetObject _  
  intHorizontal = sHorizontal *2  
  intVertical = sVertical *2  
  Set colItems = objWMIService.ExecQuery( _  
   "Select ScreenWidth, ScreenHeight from" _  
   & " Win32_DesktopMonitor", , 48)  
  For Each objItem In colItems  
   sWidth= objItem.ScreenWidth  
   sHeight = objItem.ScreenHeight  
   If sWidth > sHorizontal _  
    then intHorizontal = sWidth  
   If sHeight > sVertical _  
    then intVertical = sHeight  
  Set objWMIService = Nothing  
  '# Center window on the screen  
  intLeft = (intHorizontal - sHorizontal) /2  
  intTop = (intVertical - sVertical) /2  
  Window.moveTo intLeft, intTop  
  '# default window content  
 End Sub  
 Sub RunScript  
   on Error Resume Next  
   minUSRnamelength = 2  
   minPASSwrdlength = 3  
   strUsr = UsrnameArea.Value  
   strPas = PasswordArea.Value  
   strUsr2 = strUsr  
   Set objNetwork = CreateObject("WScript.Network")  
   Set oShell = CreateObject("Shell.Application")  
   If Len(strUsr) >= minUSRnamelength then  
    strUsr = strDOMAIN & UCase(strUsr) '<--- adds the domain before the username  
    if Len(strPas) >= minPASSwrdlength Then  
      Call ClearDrives ' Delete existing mappings if they exist  
            '***** Begin Drive mapping *****  
       objNetwork.MapNetworkDrive arrDrives(0,0), arrDrives(0,1), False, strUsr, strPas  
       If Err.Number = 0 Then  
         oShell.NameSpace(arrDrives(0,0)).Self.Name = arrDrives(0,2)  
                     Err2 = arrDrives(0,2) & ", " & Err2   
       End If   
                netLocation = arrDrives(1,1) & strUsr2  
       objNetwork.MapNetworkDrive arrDrives(1,0), netLocation, False, strUsr, strPas  
       If Err.Number = 0 Then  
                  oShell.NameSpace(arrDrives(1,0)).Self.Name = strUsr2  
                 Err2 = strUsr2 & ", " & Err2   
       End If   
                If Err.Number = 0 Then  
                End If  
      '***** End Drive Mapping *****  
       Msgbox chr(34) & strPas & """ is an incorrect password !"  
       Exit Sub  
      End If  
    Msgbox chr(34) & strUsr & """ is an incorrect Username !"  
    Exit Sub  
   End If  
   ' Clean up the objects before exiting  
   Set oShell = Nothing  
   Set objNetwork = Nothing  
 End Sub  
 Sub ClearDrives   ' Sub Routine to remove the drives if they are already mapped      
 SET objNetwork = CREATEOBJECT("Wscript.Network")  
 SET colDrives = objNetwork.EnumNetworkDrives  
 FOR i = 0 to colDrives.Count-1 Step 2  
      ' Force Removal of network drive and remove from user profile   
      ' objNetwork.RemoveNetworkDrive strName, [bForce], [bUpdateProfile]  
      objNetwork.RemoveNetworkDrive colDrives.Item(i),TRUE,TRUE  
 ' on Error Resume Next  
 ' Set objNetwork = CreateObject("WScript.Network")  
 ' '***** Begin section to delete drive mappings ***  
 ' Set AllDrives = objNetwork.EnumNetworkDrives      
 ' For n = 0 To intMaxDrives   'Loop through our array of drives   
 '   For i = 0 To AllDrives.Count - 1 Step 2   
 '    If AllDrives.Item(i) = arrDrives(n,0) Then AlreadyConnected = True   
 '   Next      
 '   If AlreadyConnected = True then   
 '    objNetwork.RemoveNetworkDrive arrDrives(n,0), True, True  
 '   End If   
 ' Next    
 ' 'msgbox ("disconnected1")  
 ' 'msgbox ("d-end")  
 ' '***** End section to delete drive mappings   
  End Sub  
 Sub DisconnectDrives ' Calls ClearDrives subroutine and then closes the window  
     Call ClearDrives  
   Set oShell = Nothing  
   Set objNetwork = Nothing  
 End Sub  
 Sub sbWait(iSeconds)  
   Dim oShell : Set oShell = CreateObject("WScript.Shell")  
   oShell.run "cmd /c ping localhost -n " & iSeconds,0,True  
 End Sub       
 Sub CancelScript  
   Set oShell = Nothing  
   Set objNetwork = Nothing  
 End Sub  
 <BODY STYLE="font:14 pt arial; color:black;">  
 <a name="Top"></a><CENTER>  
  <table border="0" cellpadding="0" cellspacing="0"><font size="2" color="black" face="Arial">  
    <td colspan="2" height="50" valign="top"><p style="text-align: center;">  
                Your School<br />  
                The Lab</p></td>  
    <td height="30"><p align="right">Your Username</p></td>  
    <td height="30">&nbsp;&nbsp; <input type="text" name="UsrnameArea" size="30"></td></tr>  
    <td height="30"><p align="right">Password</p></td>  
    <td height="30">&nbsp;&nbsp; <input type="password" name="PasswordArea" size="30"></td></tr>  
 <HR color="#0000FF">  
  <Input id=runbutton class="button" type="button" value=" Log On " name="run_button" onClick="RunScript">  
  <Input id=runbutton class="button" type="button" value=" Log Off " name="dis_button" onClick="DisconnectDrives">  
  <Input id=runbutton class="button" type="button" value="Cancel" name="cancel_button" onClick="CancelScript">  

I used http://codeformatter.blogspot.com/ to convert the source-code into a format that I can post on Blogger.

No comments:

Post a Comment