VBA Anpassung für Laufwerkmapping mit User und Passwort

'--------------------------------------------------------------------  
' Netzlaufwerke f: bis z: trennen Asc(f)=102 ...Asc(z)=122  
' ACHTUNG: auf Kleinschreibung bei Netzlaufwerken achten  
'-----------------------------------------------------------------  
Dim DelNetDrive
set WshNetwork = WScript.CreateObject("WScript.Network")  

For DriveAsc = 105 To 122
On Error Resume Next
DelNetDrive = Chr(DriveAsc) & ":"  

WshNetwork.RemoveNetworkDrive DelNetDrive, True, True 
next
on error goto 0

call IELogin ( getLoginName, getPassword) 

'Netzlaufwerke verbinden  
On Error Resume Next
If getLoginName = "User1" then  
'msgbox  "User: " & getLoginName & vbCrLf & "Password: " & getPassword  
WshNetwork.MapNetworkDrive "k:", "\\homenas\1", False, getLoginName, getPassword  
WshNetwork.MapNetworkDrive "l:", "\\homenas\2", False, getLoginName, getPassword  
WshNetwork.MapNetworkDrive "m:", "\\homenas\3", False, getLoginName, getPassword  
WshNetwork.MapNetworkDrive "n:", "\\homenas\4", False, getLoginName, getPassword  
WshNetwork.MapNetworkDrive "o:", "\\homenas\5", False, getLoginName, getPassword  
WshNetwork.MapNetworkDrive "p:", "\\homenas\6", False, getLoginName, getPassword  
WshNetwork.MapNetworkDrive "q:", "\\homenas\7", False, getLoginName, getPassword  
call error

elseIf getLoginName = "User2" then  
'msgbox  "User: " & getLoginName & vbCrLf & "Password: " & getPassword  
WshNetwork.MapNetworkDrive "k:", "\\homenas\1", False, getLoginName, getPassword  
WshNetwork.MapNetworkDrive "l:", "\\homenas\2", False, getLoginName, getPassword  
WshNetwork.MapNetworkDrive "m:", "\\homenas\3", False, getLoginName, getPassword  
WshNetwork.MapNetworkDrive "o:", "\\homenas\4", False, getLoginName, getPassword  
WshNetwork.MapNetworkDrive "p:", "\\homenas\5", False, getLoginName, getPassword  
call error

else 
msgbox "Netzlaufwerke wurden nicht verbunden: Username falsch oder nicht eingegeben"  
End If
On Error Goto 0


Function IELogin( getLoginName, getPassword) 
    Dim objIE
    ' Create an IE object  
    Set objIE = CreateObject( "InternetExplorer.Application" )  
    ' specify some of the IE window's settings  
    objIE.Navigate "about:blank"  
    objIE.Document.Title = "NetworkLogin" & String( 100, "." )  
    objIE.ToolBar        = False
    objIE.Resizable      = False
    objIE.StatusBar      = False
    objIE.Width          = 300
    objIE.Height         = 200
    ' Center the dialog window on the screen  
    With objIE.Document.ParentWindow.Screen
        objIE.Left = (.AvailWidth  - objIE.Width ) \ 2
        objIE.Top  = (.Availheight - objIE.Height) \ 2
    End With
    ' Wait till IE is ready  
    Do While objIE.Busy
        WScript.Sleep 200
    Loop
    ' Insert the HTML code to prompt for user input  
    objIE.Document.Body.InnerHTML = "<div align=""left"">" & vbcrlf _  
                                  & "<table cellspacing=""5""><tr nowrap>" _  
                                  & "<td>Username:</td><td>" _  
                                  & "<input type=""text"" size=""20"" " _  
                                  & "autocomplete=""off"" " _  
                                  & "id=""LoginName""></td></tr>" & vbcrlf _  
                                  & "<tr nowrap><td>Password:</td>" _  
                                  & "<td><input type=""password"" size=""21"" " _  
                                  & "id=""Password""></td>" & vbcrlf _  
                                  & "</tr></div></table>" & vbcrlf _  
                                  & "<div align=""center""><p><input type=""hidden"" id=""OK"" " _  
                                  & "name=""OK"" value=""0""> " _  
                                  & "<input type=""submit"" value="" OK "" " _  
								  & "onClick=""VBScript:OK.Value=1""> "_   
								  & "<input type=""hidden"" id=""Beenden"" name=""Beenden"" value=""0"">" _  
								  & "<input type='submit' value='Beenden' onClick=""VBScript:Beenden.Value=2""></p></div>"  
    ' Hide the scrollbars  
    objIE.Document.Body.Style.overflow = "visible"  
    ' Make the window visible  
    objIE.Visible = True
    ' Set focus on input field  
    objIE.Document.All.LoginName.Focus
	
	' Wait till the OK button has been clicked  
    On Error Resume Next
    Do While objIE.Document.All.OK.Value = 0 and objIE.Document.All.Beenden.Value = 0
        WScript.Sleep 200
		If Err or objIE.Document.All.Beenden.Value = 2 Then    'user clicked red X (or alt-F4) to close IE window  
             objIE.Quit
			 WScript.Quit
            Set objIE = Nothing
            Exit Function
			     End if
    Loop
    On Error Goto 0
	 
		    
    ' Read the user input from the dialog window  
   	getLoginName = objIE.Document.All.LoginName.Value
	getPassword = objIE.Document.All.Password.Value
	
	
	' Close and release the object  
    objIE.Quit
    Set objIE = Nothing
	
	
End Function

Function error
if Err =  0 then
msgbox "Netzlaufwerke wurden verbunden."  
else
select case Err.Number
case -2147024843
' Netzlaufwerke konnte nicht verbunden werden  
msgbox "Netzlaufwerke wurden nicht verbunden. Vielleicht ist das Ziel offline. Versuchen Sie es später nochmal"  
' Anmeldung fehlgeschlagen: Username oder Password falsch  
case -2147023570
msgbox "Netzlaufwerke wurden nicht verbunden: Username und/oder Password falsch."  
' Anmeldung fehlgeschlagen: Password falsch  
case -2147024810
msgbox "Netzlaufwerke wurden nicht verbunden: Password falsch."  
' Netzlaufwerk konnte nicht verbunden werden: Netzlaufwerke schon verbunden  
case -2147024811
msgbox "Netzlaufwerke sind schon verbunden."  
' anderer Fehler  
case else
msgbox "Teilen Sie den aufgetretenen Fehler dem Administrator mit: "& vbCrLf & vbCrLf & err.Number & vbCrLf & Err.Description  
end select
end if
End Function