 Loading |
|
Loading |
| VBScript |
| JavaScript |
| Powershell |
Search Options: 2008 Scripting Games Advanced VBScript Event 5
|
||
|
' This is my Solution for the Scripting Games 2008
' For more Information look at ' http://www.microsoft.com/technet/scriptcenter/funzone/games/games08.mspx Option Explicit Dim ofso : Set ofso = Createobject("Scripting.FileSystemObject") Const ForReading = 1 Const ForWriting = 2 Const ForAppending = 8 Dim strParamter Dim ArgArray, ArrayElement Dim iPwdScore : iPwdScore = 13 Call GetArguments(ArgArray) If IsArray(ArgArray) then For Each ArrayElement In ArgArray strParamter = strParamter & ArrayElement Next End if if strParamter > "" then Call Main() ' --------------------------------------- Sub Main() CheckPWD(strParamter) End Sub ' --------------------------------------- Private Function ReadFileToArray(strFile) Dim strNextLine, arrstrList Dim arrLines() Dim iCount : iCount = 0 If ofso.FileExists(strFile) then Dim oFile : Set oFile = ofso.OpenTextFile(strFile, ForReading) Do Until oFile.AtEndOfStream Redim Preserve arrLines(iCount) arrLines(iCount) = oFile.ReadLine iCount = iCount + 1 Loop oFile.Close End if Set oFile = nothing If IsArray(arrLines) then ReadFileToArray = arrLines End Function ' --------------------------------------- Private Function CheckPWD(strPWD) Dim arrWords, iCount, iRet,iCount2 Dim PWD_OK : PWD_OK = true Dim lMultiple : lMultiple = false Dim uMultiple : uMultiple = false Dim bDuplicate : bDuplicate = false Dim sDuplicate Dim iX_1 : iX_1 = false Dim iX_2 : iX_2 = false Dim iX_3 : iX_3 = false Dim iX_4 : iX_4 = false Dim iX_5 : iX_5 = false arrWords = ReadFileToArray("C:\Scripts\wordlist.txt") If IsArray(arrWords) then For iCount = 0 to UBound(arrWords) If arrWords(iCount) = strPWD then iX_1 = true End if If arrWords(iCount) = Left(strPWD,Len(strPWD)-1) then iX_2 = true End if If arrWords(iCount) = Right(strPWD,Len(strPWD)-1) then iX_3 = true End if if Instr(1, strPWD, "0", 1) > 0 then If GetReplacedWord(strPWD,"0","o") = arrWords(iCount) or _ GetReplacedWord(strPWD,"0","O") = arrWords(iCount) then iX_4 = true End if End if if Instr(1, strPWD, "1", 1) > 0 then If GetReplacedWord(strPWD,"1","l") = arrWords(iCount) or _ GetReplacedWord(strPWD,"1","L") = arrWords(iCount) then iX_5 = true End if End if Next End if If iX_1 = true then wscript.echo "The password is an actual word." iPwdScore = iPwdScore -1 End if If iX_2 = true then wscript.echo "The password minus the last letter is an actual word." iPwdScore = iPwdScore -1 End if If iX_3 = true then wscript.echo "The password minus the first letter is an actual word." iPwdScore = iPwdScore -1 End if If iX_4 = true then wscript.echo _ "The password is an actual word. In the case of substitute 0 (zero) for the letter O." iPwdScore = iPwdScore -1 End if If iX_5 = true then wscript.echo _ "The password is an actual word. In the case of substitute 1 (one) for the letter L." iPwdScore = iPwdScore -1 End if If Len(strPWD) < 10 or Len(strPWD) > 20 then wscript.echo "The password length is less 10 letters or larger 20 letters." iPwdScore = iPwdScore -1 End if if instrCheck("[0-9]", strPWD) = false then wscript.echo "The password does not include a number." iPwdScore = iPwdScore -1 End if if instrCheck("[A-Z]", strPWD) = false then wscript.echo "The password does not include a uppercase letter." iPwdScore = iPwdScore -1 End if if instrCheck("[a-z]", strPWD) = false then wscript.echo "The password does not include a lowercase letter." iPwdScore = iPwdScore -1 End if if instrCheck("[^A-Za-z0-9]", strPWD) = false then wscript.echo "The password does not include a symbol." iPwdScore = iPwdScore -1 End if For iCount = 1 to Len(strPWD) -3 if instrCount("[A-Z]", Mid(strPWD,iCount,4)) = 4 then uMultiple = true End if if instrCount("[a-z]", Mid(strPWD,iCount,4)) = 4 then lMultiple = true End if Next For iCount = 1 to Len(strPWD) For iCount2 = iCount to Len(strPWD) -1 sDuplicate = Mid(strPWD,iCount,1) if sDuplicate = Mid(strPWD,iCount2 +1,1) then bDuplicate = true Exit For End if Next Next if lMultiple = true then wscript.echo "Four consecutive lowercase letters in password." iPwdScore = iPwdScore -1 End if if uMultiple = true then wscript.echo "Four consecutive uppercase letters in password." iPwdScore = iPwdScore -1 End if if bDuplicate = true then wscript.echo "Duplicate letters in password." iPwdScore = iPwdScore -1 End if Select Case iPwdScore Case 0,1,2,3,4,5,6 wscript.echo VbCrLf & "A password score of " & iPwdScore & " indicates a weak password." Case 7,8,9,10 wscript.echo VbCrLf & "A password score of " & iPwdScore & " indicates a moderately-strong password." Case 11,12,13 wscript.echo VbCrLf & "A password score of " & iPwdScore & " indicates a strong password." End Select End Function ' --------------------------------------- Private Function GetReplacedWord(strPWD,strPrimLetter,strReplaceLetter) Dim strAlternatePWD strAlternatePWD = Replace(strPWD, strPrimLetter, strReplaceLetter, 1, -1, 1) GetReplacedWord = strAlternatePWD End Function ' --------------------------------------- Private Function instrCheck(strPattern, strSearch) Dim oRegEx : Set oRegEx = CreateObject("VBScript.RegExp") Dim colMatches, strMatch oRegEx.Global = True oRegEx.Pattern = strPattern Set colMatches = oRegEx.Execute(strSearch) If colMatches.Count > 0 Then instrCheck = true Else instrCheck = false End if End Function ' --------------------------------------- Private Function instrCount(strPattern, strSearch) Dim oRegEx : Set oRegEx = CreateObject("VBScript.RegExp") Dim colMatches, strMatch oRegEx.Global = True oRegEx.Pattern = strPattern Set colMatches = oRegEx.Execute(strSearch) If colMatches.Count > 0 Then instrCount = colMatches.Count Else instrCount = 0 End if End Function ' --------------------------------------- Private Function GetArguments(SourceArray) Dim iCount : iCount = 0 Dim Argument If wscript.arguments.count > 0 then ReDim ArgArray(wscript.arguments.count -1) For Each Argument in wscript.arguments ArgArray(iCount) = Argument iCount = iCount +1 Next iCount = Null GetArguments = ArgArray End if End Function | ||
© 2008 - 2013 Boris Toll :: Scripts available: 6.481 :: :: scriptbox.toll.at :: :: powered by www.toll.at :: | ||
