' --------------------------------------------- '
' ----- By Jakob H. Heidelberg 22-05-2009 ----- '
' ----- - - - - - - - - - - - - - - - - - ----- '
' -----      Set Local User Password      ----- '
' -----       Proof of Concept Code       ----- '
' ----- - - - - - - - - - - - - - - - - - ----- '
' -----           Developed for:          ----- '
' -----         www.IT-experts.dk         ----- '
' ----- - - - - - - - - - - - - - - - - - ----- '
' -----           version 2.00            ----- '
' -----    Last rev. date: 23-05-2009     ----- '
' --------------------------------------------- '

OPTION EXPLICIT

' SET variables (section A)
  Dim intDays       : intDays       = 60 'default: 60 days
  Dim strNetShare   : strNetShare   = "\\SERVER\SHARE\" 'backslash\
  Dim strLocalLog   : strLocalLog   = "C:\admpwd.log"
  Dim strLocalStamp : strLocalStamp = "C:\admpwd.stp"
  Dim strLocalUser  : strLocalUser  = "test-user"

' GET computername (used for network logfile name = strNetFile)
  Dim wshNetwork  : Set wshNetwork = WScript.CreateObject("WScript.Network")
  Dim strComputer : strComputer = wshNetwork.ComputerName
  Set wshNetwork = Nothing
  Dim strNetFile : strNetFile = strNetShare & strComputer & ".log"

' START logging of all actions to strLocalLog =>
  WriteToLogFile "[STARTED]" & strNewPassword,strLocalLog

' LOG variables (section A)
  WriteToLogFile "[VARIABLES - A]" & strNewPassword,strLocalLog
  WriteToLogFile " - intDays          : " & intDays,strLocalLog
  WriteToLogFile " - strNetShare      : '" & strNetShare & "'",strLocalLog
  WriteToLogFile " - strLocalLog      : '" & strLocalLog & "'",strLocalLog
  WriteToLogFile " - strLocalStamp    : '" & strLocalStamp & "'",strLocalLog
  WriteToLogFile " - strLocalUser     : '" & strLocalUser & "'",strLocalLog
  WriteToLogFile " - strComputer      : '" & strComputer & "'",strLocalLog
  WriteToLogFile " - strNetFile       : '" & strNetFile & "'",strLocalLog

' CHECK IF strLocalStamp exists
  If FileExists(strLocalStamp) Then
  ' -> IF YES then CHECK strLocalStamp LastModified
    Dim strSTAMP : strSTAMP = GetLastModifiedData(strLocalStamp)
      WriteToLogFile "STATUS  - STAMP last modified: " & strSTAMP,strLocalLog
    If DateAdd("d",-intDays,Now()) > strSTAMP Then
    ' --> Continue IF NOT EXIST OR OLD
      WriteToLogFile "STATUS  - STAMP older than: " & intDays & " days!",strLocalLog
    Else
    ' --> Quit if modified lately
      WriteToLogFile "STATUS  - STAMP younger than: " & intDays & " days!",strLocalLog
      WriteToLogFile "[COMPLETED]" & vbNewLine,strLocalLog
      Wscript.Quit
    End if
  Else
  ' -> IF NOT then just continue (probably first run)
    WriteToLogFile "STATUS  - No local stamp file, probably first run",strLocalLog
  End if

' CHECK strNetShare network access
  If ShareAlive(strNetShare) Then
    ' -> Continue IF access is OK
    WriteToLogFile "SUCCESS - ALIVE:" & strNetShare,strLocalLog
  Else
    ' -> Quit IF there's NO access
    WriteToLogFile "FAILURE - DEAD :" & strNetShare,strLocalLog
    WriteToLogFile "[ABORTED]" & vbNewLine,strLocalLog
    Wscript.Quit
  End If

' CREATE a new PWD to use ===>>>

'-PWD----------------------------------------
'------- Dim Userdefined Variables ----------
'--------------------------------------------
  Dim intPasswordLength : intPasswordLength = 12
  Dim intWantNumbers    : intWantNumbers    = 1
  Dim intWantLcase      : intWantLcase      = 1
  Dim intWantUcase      : intWantUcase      = 1

' LOG variables (section B)
  WriteToLogFile "[VARIABLES - B]" & strNewPassword,strLocalLog
  WriteToLogFile " - intPasswordLength: " & intPasswordLength,strLocalLog
  WriteToLogFile " - intWantNumbers   : " & intWantNumbers,strLocalLog
  WriteToLogFile " - intWantLcase     : " & intWantLcase,strLocalLog
  WriteToLogFile " - intWantUcase     : " & intWantUcase,strLocalLog

' Dim Global PWD Variables
  Dim intTestMinLength  : intTestMinLength = intWantNumbers + intWantLcase + intWantUcase
  Dim intPasswordOK     : intPasswordOK     = 0
  Dim strNewPassword    : strNewPassword    = ""
  Const UCASELOWER = 65  ' 65 = A
  Const UCASEUPPER = 90  ' 90 = Z
  Const LCASELOWER = 97  ' 97 = a
  Const LCASEUPPER = 122 ' 122 = z
  Dim intUcase : intUcase = UCASEUPPER - UCASELOWER + 1 'number of uppercase chars included from ASCII table
  Dim intLcase : intLcase = LCASEUPPER - LCASELOWER + 1 'number of lowercase chars included from ASCII table
  Dim arrUcase()
  Dim arrLcase()

' GET new PWD by calling NewPassword()
  NewPassword() '<<<=== new PWD in: strNewPassword

' LOG the PWD to file (strNetFile) on network share
  If WriteToCriticalLogFile(RightNow() & " " & strLocalUser & " = '" & strNewPassword & "'",strNetFile) Then
    WriteToLogFile "SUCCESS - PWD written to: '" & strNetFile & "'",strLocalLog
  Else
    WriteToLogFile "FAILURE - PWD NOT written to: '" & strNetFile & "'",strLocalLog
    WriteToLogFile "[ABORTED]" & vbNewLine,strLocalLog
    Wscript.Quit
  End If

' SET user (strLocalUser) password
  If SetLocalUserPassword(strLocalUser,strNewPassword) Then
    WriteToLogFile "SUCCESS - PWD SET for: '" & strLocalUser & "'",strLocalLog
  Else
    WriteToLogFile "FAILURE - PWD NOT SET for '" & strLocalUser & "'",strLocalLog
    WriteToLogFile strLocalUser & " -> above password was not set anyway, sorry...",strNetFile
    WriteToLogFile "[ABORTED]" & vbNewLine,strLocalLog
    Wscript.Quit
  End if

' STAMP strLocalStamp (just a timestamp)
  WriteToLogFile "",strLocalStamp
  WriteToLogFile "SUCCESS - TIME written to: '" & strLocalStamp & "'",strLocalLog

' STOP logging of all actions to strLocalLog <=
  WriteToLogFile "[COMPLETED]" & vbNewLine,strLocalLog

'------'
' DONE '
'------'


'--------------------------------------------
'--------- FUNCTIONS / SUBS BELOW -----------
'--------------------------------------------

Sub PreparePassword
  Dim i
  If intTestMinLength = 0 Then
    WriteToLogFile "FAILURE - Complexity requirements are not defined!",strLocalLog
    Wscript.Quit
  End If
  If IntPasswordLength - intTestMinLength < 0 Then
    WriteToLogFile "FAILURE - Passwordlength will have to be at least " & intTestMinLength & " chars to meet complexity requirements...",strLocalLog
    Wscript.Quit
  End If
  'Initialize Randomizer
    Randomize()
  'Create array containing allowed Ucase
  For i = 0 to intUcase
    Redim Preserve arrUcase(i)
    arrUcase(i) = Chr(UCASELOWER + i)
  Next
  'Create array containing allowed Lcase
  For i = 0 to intLcase
    Redim Preserve arrLcase(i)
    arrLcase(i) = Chr(LCASELOWER + i)
  Next
End sub

Sub MakePassword()
 strNewPassword = ""
 'Loop until the requested password length is reached
 Do Until len(strNewPassword) = IntPasswordLength
   'A random number from 1 to 5 is generated
  Dim intRandomNumber : intRandomNumber = Int((5 * Rnd) + 1)
  'Depending on the random number a charset (allowed by the user) is chosen
  'This is done to randomize the order of character/numbers/symbols etc.
  Select Case intRandomNumber
  Case 1 'Add Numbers
    If intWantNumbers Then strNewPassword = strNewPassword & Int((10 * Rnd)) 'Get a random number (0 to 9)
  Case 2 'Add Ucase
    If intWantUcase   Then strNewPassword = strNewPassword & arrUcase(Int((intUcase*Rnd)+0))
  Case 3 'Add Lcase
    If intWantLcase   Then strNewPassword = strNewPassword & arrLcase(Int((intLcase*Rnd)+0))
  End Select
 Loop

End Sub

Sub TestPassword()
 Dim j
 intPasswordOK = 0

 'The following variables is for checking whether or not a given password meets the complexity requirements
 Dim intGotNumbers : intGotNumbers  = 0
 Dim intGotUcase   : intGotUcase    = 0
 Dim intGotLcase   : intGotLcase    = 0

'Runs though each char in strNewPassword to check if a wanted charset is present,
'if NOT, we will exit the sub for a complete new password to be created -
'else, we will continue to next verification of present user-chosen charsets
'Whenever a correct char is present 1 is added to the value of intPasswordOK
 If intWantNumbers Then
  For j = 0 To 9
     If InStr(strNewPassword,j) Then
       intGotNumbers = 1
      intPasswordOK = intPasswordOK + 1
      Exit For
    End If
  Next
  If intGotNumbers = 0 Then Exit Sub
 End If
 If intWantUcase Then
   For j = 0 To UBound(arrUcase)
     If InStr(strNewPassword,arrUcase(j)) Then
       intGotUcase = 1
       intPasswordOK = intPasswordOK + 1
       Exit For
     End If
   Next
   If intGotUcase = 0 Then Exit Sub
 End If
 If intWantLcase Then
    For j = 0 To UBound(arrLcase)
       If InStr(strNewPassword,arrLcase(j)) Then
          intGotLcase = 1
          intPasswordOK = intPasswordOK + 1
          Exit For
       End If
    Next
   If intGotLcase = 0 Then Exit Sub
 End If
End Sub

Sub NewPassword()
  Call PreparePassword
  Do
    'Request a rondom password
    Call MakePassword
    'Test to see if the password is as complex as the user has chosen
    Call TestPassword
    'Whenever intPasswordOK reaches intTestMinLength the password complies with the requested number of charset-categories
  Loop Until intPasswordOK = intTestMinLength
  'We should have the new password in GLOBAL strNewPassword
End Sub

Function SetLocalUserPassword(USER,PASSWORD)
  SetLocalUserPassword = True
  On Error Resume Next
    Dim objUser : Set objUser = GetObject("WinNT://./" & USER)
    objUser.SetPassword(PASSWORD)
  If Err.Number <> 0 Then SetLocalUserPassword = False
    Set objUser = Nothing
End Function

Function RightNow
 Dim strNow : strNow = now()
 Dim YearMonthDay : YearMonthDay = Year(strNow) & "-" & Month(strNow) & "-" & Day(strNow)
 Dim strYear      : strYear      = Year(strNow)
 Dim strMonth     : strMonth     = Month(strNow)
 Dim strDay       : strDay       = Day(strNow)
 Dim strHour      : strHour      = Hour(strNow)
 Dim strMinute    : strMinute    = Minute(strNow)
 Dim strSecond    : strSecond    = Second(strNow)
  Do While LEN(strMonth) < 2
    strMonth = "0" & strMonth
  Loop
  Do While LEN(strDay) < 2
    strDay = "0" & strDay
  Loop
 YearMonthDay = strYear & "-" & strMonth & "-" & strDay
  Do While LEN(strHour) < 2
    strHour = "0" & strHour
  Loop
  Do While LEN(strMinute) < 2
    strMinute = "0" & strMinute
  Loop
  Do While LEN(strSecond) < 2
    strSecond = "0" & strSecond
  Loop
 Dim HourMinSec  : HourMinSec  = strHour & ":" & strMinute & ":" & strSecond
 Dim strRightNow : strRightNow = YearMonthDay & " " & HourMinSec
 RightNow = strRightNow
End Function

Function WriteToLogFile(strLineToWrite,logFile)
 Dim objFSO : Set objFSO = CreateObject("Scripting.FileSystemObject")
 'create logfil if not exist
 If not objFSO.FileExists(logFile) Then objFSO.CreateTextFile(logFile)
  Dim LogFileEdit : Set LogFileEdit = objFSO.OpenTextFile(logFile, 8, True) '8 = Append
    LogFileEdit.WriteLine(RightNow() & " " & strLineToWrite)
  LogFileEdit.Close
 Set objFSO = Nothing
 Set LogFileEdit = Nothing
End Function

Function ShareAlive(SHARE)
  On Error Resume Next
  ShareAlive = False
  Dim FSO : Set FSO = CreateObject("Scripting.FileSystemObject")
  Dim Directory : Directory = FSO.GetFolder(SHARE)
  If Err.Number = 0 Then ShareAlive = True
  Set FSO = Nothing
  Err.Clear
End Function

Function GetLastModifiedData(filespec)
  Dim FSO, FILE
  Set FSO = CreateObject("Scripting.FileSystemObject")
  Set FILE = FSO.GetFile(filespec)
  GetLastModifiedData = FILE.DateLastModified
  Set FILE = Nothing
  Set FSO = Nothing
End Function

Function FileExists(filespec)
  FileExists = False
  Dim FSO : Set FSO = CreateObject("Scripting.FileSystemObject")
  If FSO.FileExists(filespec) Then FileExists = True
  Set FSO = Nothing
End Function

Function WriteToCriticalLogFile(strLineToWrite,logFile)
 WriteToCriticalLogFile = False
 On Error Resume Next
 Dim objFSO : Set objFSO = CreateObject("Scripting.FileSystemObject")
 'create logfil if not exist
 If not objFSO.FileExists(logFile) Then objFSO.CreateTextFile(logFile)
  Dim LogFileEdit : Set LogFileEdit = objFSO.OpenTextFile(logFile, 8, True) '8 = Append
    LogFileEdit.WriteLine(strLineToWrite)
  LogFileEdit.Close
 Set objFSO = Nothing
 Set LogFileEdit = Nothing
 If Err.number = 0 Then WriteToCriticalLogFile = True
End Function