mkusers.vbs

' mkusers.vbs

' varie
Const ForReading = 1, ForWriting = 2, ForAppending = 8

' CDO
Const cdoSendUsingPickup = 1, cdoSendUsingPort = 2
Const cdoAnonymous = 0, cdoBasic = 1, cdoNTLM = 2
Const cdoDSNDefault = 0, cdoDSNNever = 1, cdoDSNFailure = 2, cdoDSNSuccess = 4, cdoDSNDelay = 8, cdoDSNSuccessFailOrDelay = 14

' usato per invio mail di notifica
Const MAIL_SERV = ""    ' server SMTP
Const MAIL_PORT = 25    ' porta
Const MAIL_USER = ""    ' utente
Const MAIL_PASS = ""    ' password

Const MAIL_FROM = ""    ' from per email
Const MAIL_TO = ""      ' to per email
Const MAIL_CC = ""      ' cc per email
Const MAIL_BCC = ""      ' bcc per email

' flags utente
Const ADS_UF_DONT_EXPIRE_PASSWD = &h10000
Const ADS_UF_PASSWD_CANT_CHANGE = &h40

' gruppo utenti (opzionale)
Const GROUP_NAME = "Remote Desktop Users"

' stringa connessione DB
Const CONN_STR = "File Name=mkuser.udl"

' debugging
Const DEBUG_MODE = 0


'__boot() {
  Dim args, fso, nExitCode
  Dim gsLogFile

  On Error Resume Next
  Set args = WScript.Arguments
  Set fso = CreateObject("Scripting.FileSystemObject")
  gsLogFile = "log\mkuser-" & _
              Right("0000" & Year(Now), 4) & Right("00" & Month(Now), 2) & Right("00" & Day(Now), 2) & "-" & _
              Right("00" & Hour(Now), 2) & Right("00" & Minute(Now), 2) & ".log"

  nExitCode = main(args.Count, args)
  If (nExitCode <> 0) Or (DEBUG_MODE = 1) Then
    Call SendMail(MAIL_FROM,MAIL_TO,MAIL_CC,MAIL_BCC,"[MKUSERS] Elaborazione accounts utente","Elaborazione accounts utente (mkusers)",Array(gsLogFile),False)
  End If
  WScript.Quit nExitCode
'}

' startup
Function main(argc, argv)
  Dim cnCON, rsREC, cmCMD
  Dim sUsername, sFullName, sDescription, sPassword
  Dim nRet, lTotRec, lRecOk, lRecErr
  Dim nStatus

  On Error Resume Next
  If DEBUG_MODE = 1 Then
    Message "== Inizio elaborazione utenti"
  End If

  nRet = 0
  Set cnCON = CreateObject("ADODB.Connection")
  Set rsREC = CreateObject("ADODB.Recordset")
  Set cmCMD = CreateObject("ADODB.Command")

  ' --- apre la connessione al DB
  If DEBUG_MODE = 1 Then
    Message "Apertura connessione database..."
  End If
  Err.Clear
  With cnCON
    .ConnectionString = CONN_STR
    .CursorLocation = 2 ' adUseServer
    .Open
  End With
  If Err.Number <> 0 Then
    Message "ERR(con): 0x" & Hex(Err.Number) & " " & Err.Description
    main = 1
    Exit Function
  End If

  ' --- inizializza il command per update
  If DEBUG_MODE = 1 Then
    Message "Inizializzazione oggetto command..."
  End If
  Err.Clear
  With cmCMD
    Set .ActiveConnection = cnCON
    .CommandType = 1 ' adCmdText
  End With
  If Err.Number <> 0 Then
    Message "ERR(cmd): 0x" & Hex(Err.Number) & " " & Err.Description
    main = 2
    Exit Function
  End If

  ' --- apre il cursore sulla tabella utenti
  If DEBUG_MODE = 1 Then
    Message "Apertura tabella utenti..."
  End If
  Err.Clear
  With rsREC
    Set .ActiveConnection = cnCON
    .CursorType = 0     ' adOpenForwardOnly
    .LockType = 1       ' adLockReadOnly
    .Open "SELECT * FROM MKUSERS WHERE STATUS IN (1,2) ORDER BY USERNAME"
  End With
  If Err.Number <> 0 Then
    Message "ERR(rec): 0x" & Hex(Err.Number) & " " & Err.Description
    main = 3
    Exit Function
  End If

  ' --- loop ed eliminazione/creazione utenti
  If DEBUG_MODE = 1 Then
    Message "Verifica utenti da elaborare..."
  End If
  lTotRec = 0
  lRecOk = 0
  lRecErr = 0
  While Not rsREC.EOF
    lTotRec = lTotRec + 1
    sUsername = Trim("" & rsREC("USERNAME"))
    sFullName = Trim("" & rsREC("FULLNAME"))
    sDescription = Trim("" & rsREC("DESCRIPTION"))
    sPassword = Trim("" & rsREC("PASSWORD"))
    nStatus = CLng("0" & rsREC("STATUS"))
    Message "Elaborazione utente " & sUsername & " (status=" & nStatus & ") ..."
    DeleteUser ".", sUsername
    If nStatus = 2 Then
        ' --- 2: eliminazione
        If DEBUG_MODE = 1 Then
          Message "Eliminazione utente " & sUsername & " ..."
        End If
        If UpdateUserTable(cmCMD, sUsername, 6) = True Then
          Message "Utente " & sUsername & " eliminato con successo."
          lRecOk = lRecOk + 1
        Else
          Message "Errore, utente " & sUsername & " eliminato ma status non aggiornato !"
          lRecErr = lRecErr + 1
          nRet = 254
        End If
    Else
      ' --- 1: creazione utente
      If DEBUG_MODE = 1 Then
        Message "Creazione utente " & sUsername & " ..."
      End If
      If CreateUser(".", sUsername, sFullName, sDescription, sPassword, GROUP_NAME) Then
        If UpdateUserTable(cmCMD, sUsername, 5) = True Then
          Message "Utente " & sUsername & " creato con successo."
          lRecOk = lRecOk + 1
        Else
          Message "Errore, utente " & sUsername & " creato ma status non aggiornato !"
          lRecErr = lRecErr + 1
          nRet = 254
        End If
      Else
        Message "Utente " & sUsername & " NON creato causa errori."
        If UpdateUserTable(cmCMD, sUsername, 9) = False Then
          Message "ERR: Impossibile aggiornare lo status per l'utente " & sUsername
        End If
        lRecErr = lRecErr + 1
        nRet = 255
      End If
    End If
    rsREC.MoveNext
  Wend

  If DEBUG_MODE = 1 Then
    Message "Chiusura connessione database..."
  End If
  rsREC.Close
  Set rsREC.ActiveConnection = Nothing
  Set rsREC = Nothing
  Set cmCMD.ActiveConnection = Nothing
  Set cmCMD = Nothing
  cnCON.Close
  Set cnCON = Nothing

  If (lTotRec > 0) Or (DEBUG_MODE=1) Then
    Message "Elaborati " & lTotRec & " records"
    Message lRecOk & " utenti elaborati con successo"
    Message lRecErr & " utenti non elaborati causa errori"
  End If

  If DEBUG_MODE = 1 Then
    Message "Elaborazione utenti completata."
  End If
  main = nRet
End Function

' aggiorna la tabella utenti
Function UpdateUserTable(cmCMD, sUserName, nStatus)
  Dim sSQL, lRecNo, bRet

  On Error Resume Next
  bRet = False
  sSQL = "UPDATE MKUSERS SET STATUS=" & nStatus & " WHERE USERNAME='" & sUsername & "'"
  If DEBUG_MODE = 1 Then
    Message "Esecuzione SQL: " & sSQL
  End If
  cmCMD.CommandText = sSQL
  lRecNo = 0
  cmCMD.Execute lRecNo
  If (Err.Number <> 0) Or (lRecNo < 1) Then
    Message "ERR(cmd): 0x" & Hex(Err.Number) & " " & Err.Description & " (" & sSQL & ")"
  Else
    bRet = True
  End If
  UpdateUserTable = bRet
End Function

' scrive una riga nel logfile
Sub LogMsg(sStr)
  Dim fp, sDate

  On Error Resume Next
  Set fp = fso.OpenTextFile(gsLogFile, ForAppending, True)
  sDate = Right("00" & Day(Now), 2) & "-" & Right("00" & Hour(Now), 2) & ":" & Right("00" & Minute(Now), 2)
  fp.WriteLine sDate & " " & sStr
  fp.Close
End Sub

' stampa una stringa a console con crlf
Sub Message(sMsg)
  On Error Resume Next
  WScript.StdOut.WriteLine sMsg
  LogMsg sMsg
End Sub

' elimina un utente
Sub DeleteUser(sComputer, sUsername)
  Dim objComputer

  On Error Resume Next
  If DEBUG_MODE = 1 Then
    Message "DeleteUser(" & sUserName & ")"
  End If
  Set objComputer = GetObject("WinNT://" & sComputer & "")
  objComputer.Delete "user", sUsername
End Sub

' crea un utente
Function CreateUser(sComputer, sUserName, sFullName, sDescription, sPassword, sGroup)
  Dim objSystem, objUser, objUserFlags
  Dim bResult

  On Error Resume Next
  bResult = False
  CreateUser = bResult

  If DEBUG_MODE = 1 Then
    ''Message "CreateUser(" & sUserName & "," & sFullName & "," & sDescription & "," & sPassword & "," & sGroup & ")"
    Message "CreateUser(" & sUserName & "," & sFullName & "," & sDescription & "," & String(8, "*") & "," & sGroup & ")"
  End If

  ' controlla la password
  If IsComplex(sPassword) = False Then
    Message "ERR(pwd): " & sUserName & " la password non corrisponde alle regole di complessità."
    Exit Function
  End If

  ' crea l'utente
  Err.Clear
  Set objSystem = GetObject("WinNT://" & sComputer)
  Set objUser = objSystem.Create("user", sUserName)
  objUser.FullName = sFullName
  objUser.Description = sDescription
  objUser.SetPassword sPassword
  ' @# Solo remoteAPP
  'objUser.TerminalServicesInitialProgram = "%SYSTEMROOT%\system32\logoff.exe"
  'objUser.TerminalServicesWorkDirectory = "%SYSTEMROOT%\system32"
  objUser.SetInfo
  If Err.Number <> 0 Then
    Message "ERR(usr): " & sUserName & " 0x" & Hex(Err.Number) & " " & Err.Description
    Exit Function
  End If

  ' imposta i flags "password never expires"
  ' e "user can't change password"
  Err.Clear
  objUserFlags = objUser.Get("UserFlags")
  objPasswordExpirationFlag = objUserFlags Or ADS_UF_PASSWD_CANT_CHANGE Or ADS_UF_DONT_EXPIRE_PASSWD
  objUser.Put "userFlags", objPasswordExpirationFlag
  objUser.SetInfo
  If Err.Number <> 0 Then
    Message "ERR(pwd): " & sUserName & " 0x" & Hex(Err.Number) & " " & Err.Description
    Exit Function
  Else
    ' se richiesto, aggiunge l'utente ad un gruppo
    If Len(sGroup) > 0 Then
      bRet = AddToGroup(sComputer, sUsername, sGroup)
    Else
      bRet = True
    End If
  End If

  If bRet Then
    bRet = SetInitialProg(sUserName)
  End If

  CreateUser = bRet
End Function

' imposta il programma da avviare al logon
Function SetInitialProg(sUserName)
  Dim objUser

  On Error Resume Next
  SetInitialProg = False
  Err.Clear
  Set objUser = GetObject("WinNT://localhost/" & sUserName)
  objUser.TerminalServicesInitialProgram = "C:\Windows\System32\logoff.exe"
  objUser.TerminalServicesWorkDirectory = "C:\Windows\System32"
  objUser.SetInfo

  If Err.Number <> 0 Then
    Message "ERR(prog): " & sUserName & " 0x" & Hex(Err.Number) & " " & Err.Description
    Exit Function
  End If
  SetInitialProg = True
End Function


' aggiunge l'utente ad un gruppo
Function AddToGroup(sComputer, sUsername, sGroup)
  Dim objUser, ObjGroup, bRet

  On Error Resume Next
  If DEBUG_MODE = 1 Then
    Message "AddToGroup(" & sUserName & "," & sGroup & ")"
  End If
  bRet = False
  AddToGroup = bRet

  Err.Clear
  set objUser = GetObject("WinNT://" & sUsername)
  set objGroup = GetObject("WinNT://" & sComputer & "/" + sGroup & ",group")
  objGroup.Add(objUser.AdsPath)
  If Err.Number <> 0 Then
    Message "ERR(grp): " & sUserName & " 0x" & Hex(Err.Number) & " " & Err.Description
    Exit Function
  Else
    bRet = True
  End If
  AddToGroup = bRet
End Function

' controlla se la password risponde
' alle "regole di complessità"
Function IsComplex(sPassword)
  Dim iChr, bFlag

  On Error Resume Next
  IsComplex = True

  ' Lunghezza
  If Len(sPassword) < 8 Then
    IsComplex = False
    Exit Function
  End If

  ' numeri
  bFlag = False
  For iChr = 48 to 57
    If Instr(1, sPassword, Chr(iChr)) > 0 Then
       bFlag = True
       Exit For
    End If
  Next
  If bFlag = False Then
    IsComplex = False
    Exit Function
  End If

  ' caratteri maiuscoli
  bFlag = False
  For iChr = 65 to 90
    If Instr(1, sPassword, Chr(iChr)) > 0 Then
       bFlag = True
       Exit For
    End If
  Next
  If bFlag = False Then
    IsComplex = False
    Exit Function
  End If

  ' caratteri minuscoli
  bFlag = False
  For iChr = 97 to 122
    If Instr(1, sPassword, Chr(iChr)) > 0 Then
       bFlag = True
       Exit For
    End If
  Next
  If bFlag = False Then
    IsComplex = False
    Exit Function
  End If
End Function

' Invia un messaggio email
Function SendMail(sFrom, sTo, sCc, sBCc, sSubject, sBody, vaAttach, bReceipt)
  Dim objMsg, objConf
  Dim iAtt

  On Error Resume Next
  If Len(MAIL_SERV) < 1 Then
    SendMail = True
    Exit Function
  End If

  SendMail = False
  set objMsg = CreateObject("CDO.Message")
  set objConf = CreateObject("CDO.Configuration")

  ' inizializza la config del "motore" SMTP
  Message "Inizializzazione supporto email..."
  Set objFlds = objConf.Fields
  With objFlds
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = cdoSendUsingPort
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = MAIL_SERV
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = MAIL_PORT
    If (Len(MAIL_USER) < 1) Or (Len(MAIL_PASS) < 1) Then
      .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoAnonymous
      .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = ""
      .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = ""
    Else
      .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasic
      .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = MAIL_USER
      .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = MAIL_PASS
    End If
    .Update
  End With

  ' crea ed invia il messaggio e-mail
  Message "Creazione messaggio email " & Chr(34) & sSubject & Chr(34)
  With objMsg
    Set .Configuration = objConf
    .From = sFrom
    .To = sTo
    .Cc = sCc
    .BCc = sBcc
    .Subject = sSubject
    .TextBody = sBody
    For iAtt = LBound(vaAttach) To UBound(vaAttach)
      If Len(vaAttach(iAtt)) > 0 Then
        Message "Aggiunta allegato " & vaAttach(iAtt)
        .Addattachment GetFileName(vaAttach(iAtt))
      End If
    Next
    If bReceipt = True Then
      .Fields("urn:schemas:mailheader:disposition-notification-to") = sFrom
      .Fields("urn:schemas:mailheader:return-receipt-to") = sFrom
      .DSNOptions = cdoDSNSuccessFailOrDelay
    End If
    .Fields.update
    Message "Invio messaggio email"
    Err.Clear
    .Send
  End With

  ' verifica esito dell'operazione
  If Err.Number <> 0 Then
    Message "Errore invio email: 0x" & Hex(Err.Number) & " " & Err.Description
  Else
    Message "Messaggio inviato con successo"
    SendMail = True
  End If
End Function

' converte pathname parziale in pathname completo
' la funzione è necessaria dato che CDO richiede
' un nome file completo per gli attachments
Function GetFileName(sPathName)
  On Error Resume Next
  GetFileName = ""
  If Not fso.FileExists(sPathName) Then
    Exit Function
  End If
  Set fi = fso.GetFile(sPathName)
  '' Message "File " & fi.Path & " ok."
  GetFileName = fi.Path
End Function