' Dim strDrive
' strDrive = NetConnect("\\SERVER", "\SHARE", "", "", "")
' If strDrive = "" Then
'	 WScript.Quit
' End If
' Main
' NetDisconnect strDrive

Function NetConnect(strServer, strPath, strUserName, strPassword, strEnc) 'As String
'Connects to server, maps path to last available drive, returns mapped drive letter.
Dim net 'As WScript.Network
Dim fs, drv
Dim intDrive
	On Error Resume Next
	Set fs = CreateObject("Scripting.FileSystemObject")
	Set net = CreateObject("WScript.Network")
	
	'Find an unused drive letter
	For intDrive = Asc("Z") To Asc("E") Step -1
		If fs.GetDrive(Chr(intDrive) & ":").DriveType = 0 Then Exit For
	Next
	If intDrive <= Asc("E") Then
		NetConnect = ""
		Exit Function
	End If
	
	'Fix up arguments
	If Left(strServer,2) <> "\\" Then strServer = "\\" & strServer
	If Left(strPath,1) <> "\" Then strPath = "\" & strPath
	If strUserName = "" Then strUserName = "DOMAIN\username"
	If strPassword = "" Then 
		strPassword = CreateObject("Wscript.Shell").Environment("SYSTEM").Item("PASSWORD")
	End If
	If strEnc = "" Then
		strEnc = CreateObject("Wscript.Shell").Environment("SYSTEM").Item("ENCODING_METHOD")
	End If
	
	'Decode password if encoding_method was supplied
	strPassword = Decode(strPassword, strEnc)
	
	'Attach network. Map to a drive because I have to. Sometimes the drive
	'maps okay, but returns a "Device Unavailable" error, so only consider 
	'things a failure if I get an error AND the drive didn't get mapped.
	'For example, even a bad password will map okay (but throw an error) 
	'for an authenticated user.
	'Try plain-text password
	net.MapNetworkDrive Chr(intDrive) & ":", strServer & strPath, , strUserName, strPassword
	If ((Err.Number <> 0) And (fs.GetDrive(Chr(intDrive) & ":").DriveType <> 3)) Then 
		'Try reversing the password
		Err.Clear
		net.MapNetworkDrive Chr(intDrive) & ":", strServer & strPath, , strUserName, StrReverse(strPassword)
		If ((Err.Number <> 0) And (fs.GetDrive(Chr(intDrive) & ":").DriveType <> 3)) Then 
			'Try interleaving (odd characters, then even characters)
			Err.Clear
			net.MapNetworkDrive Chr(intDrive) & ":", strServer & strPath, , strUserName, Interleave(strPassword)
			If ((Err.Number <> 0) And (fs.GetDrive(Chr(intDrive) & ":").DriveType <> 3)) Then 
				'Try pig latin (throw away last letter, move new last letter to start)
				Err.Clear
				net.MapNetworkDrive Chr(intDrive) & ":", strServer & strPath, , strUserName, PigLatin(strPassword)
				If ((Err.Number <> 0) And (fs.GetDrive(Chr(intDrive) & ":").DriveType <> 3)) Then 
					'Try odd characters (only use odd characters)
					Err.Clear
					net.MapNetworkDrive Chr(intDrive) & ":", strServer & strPath, , strUserName, OddCharacters(strPassword)
					If ((Err.Number <> 0) And (fs.GetDrive(Chr(intDrive) & ":").DriveType <> 3)) Then 
						'Try ROT13
						Err.Clear
						net.MapNetworkDrive Chr(intDrive) & ":", strServer & strPath, , strUserName, Rot13(strPassword)
						If ((Err.Number <> 0) And (fs.GetDrive(Chr(intDrive) & ":").DriveType <> 3)) Then
							Err.Clear
							NetConnect = ""
							Exit Function
						End If
					End If
				End If
			End If
		End If
	End If
	Err.Clear
	NetConnect = Chr(intDrive)
End Function

Function NetDisconnect(strDriveLetter) 'As Boolean
'Breaks the mapping to the drive that was performed by NetConnect
'Doesn't necessarily break the authentication to the server!
Dim net 'As WScript.Network
	On Error Resume Next
	Set net = CreateObject("WScript.Network")
	net.RemoveNetworkDrive Ucase(Left(strDriveLetter, 1)) & ":"
	If Err.Number <> 0 Then
		Err.Clear 
		WScript.Sleep 1000
		net.RemoveNetworkDrive Ucase(Left(strDriveLetter, 1)) & ":"
	End If
	If Err.Number <> 0 Then 
		NetDisconnect = False
		Exit Function
	End If
	NetDisconnect = True
End Function

Function ROT13(strString) 'As String
'ROT13 substitutes each letter for one that is 13 characters 
'further in the alphabet. "A" becomes "N", "B" becomes "O", 
'and so on. This is a symetrical code (encoding and decoding
'by the same function)
Const DOUBLE_ALPHABET = "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZ"
Dim strROT13
Dim lngPos
Dim intChar
	For lngPos = 1 To Len(strString)
		intChar = Instr(DOUBLE_ALPHABET, Mid(strString, lngPos, 1))
		If intChar = 0 Then
			strROT13 = strROT13 & Mid(strString, lngPos, 1)
		Else
			strROT13 = strROT13 & Mid(DOUBLE_ALPHABET, intChar + 13, 1)
		End If
	Next
	ROT13 = strROT13
End Function

Function PigLatin(strText) 'As String
'This function decodes pig latin.
'Pig Latin is encoded by moving the first letter to the End
'of the word, then adding an "A". For example, "hello" becomes "elloha"
Dim strDecoded
	strDecoded = strText
	'Remove last letter
	strDecoded = Left(strDecoded, Len(strDecoded) - 1)
	'Put new last letter in first position
	strDecoded = Right(strDecoded, 1) & Left(strDecoded, Len(strDecoded) - 1)
	PigLatin = strDecoded
End Function

Function Interleave(strText) 'As String
'This function decodes interleaved text.
'Interleave is encoded by taking odd letters followed by even letters.
'For example, "abcdef" becomes "acebdf".
	Dim strBuffer, intCounter
	For intCounter = 1 To Len(strText) Step 2
		strBuffer = strBuffer & Mid(strText, intCounter, 1)
	Next
	For intCounter = 2 To Len(strText) Step 2
		strBuffer = strBuffer & Mid(strText, intCounter, 1)
	Next
	Interleave = strBuffer
End Function

Function OddCharacters(strText)
'This function decodes "odd character" encoded text.
'OddCharacters is encoded by filling every other character with junk.
'This has the effect of doubling the size. For example, "abcdef"
'might become "atbycddiekfs" or "a6bscodme f!"
	Dim strBuffer, intCounter
	For intCounter = 1 To Len(strText) Step 2
		strBuffer = strBuffer & Mid(strText, intCounter, 1)
	Next
	OddCharacters = strBuffer
End Function

Function Decode(strText, strEnc)
'This function decodes text that has been encoded multiple
'times. "strText" is the encoded text, and "strEnc" is a 
'list of numbers indicating what order the encoding was done.
Dim intCounter, strBuffer
	If strEnc = "" Then 
		Decode = strText
		Exit Function
	End If
	strBuffer = strText
	'Decode password if encoding method was supplied
	For intCounter = Len(strEnc) To 1 Step -1
		Select Case Mid(strEnc, intCounter, 1)
			Case "1" 'Reversed
				strBuffer = StrReverse(strBuffer)
			Case "2" 'Interleaved
				strBuffer = Interleave(strBuffer)
			Case "3" 'PigLatin
				strBuffer = PigLatin(strBuffer)
			Case "4" 'OddCharacters
				strBuffer = OddCharacters(strBuffer)
			Case "5" 'ROT13
				strBuffer = ROT13(strBuffer)
			Case Else
				'Do Nothing
		End Select
	Next
	Decode = strBuffer
End Function