Odblokowywanie oraz zmian hasła dla konta w AD – Skrypty VBS cz.4 - beitadmin.pl

<span style="font-family: inherit;">Skrypt pozwalający na odblokowanie konta użytkownika podanego jako parametr oraz zmiana hasła dla zadanego konta. </span>

1	<span style="font-family: inherit;">Skrypt pozwalający na odblokowanie konta użytkownika podanego jako parametr oraz zmiana hasła dla zadanego konta. </span>

<span style="font-family: Consolas, Lucida Console, monospace; font-size: 12px; line-height: 14px;">
</span>
<blockquote><span style="font-family: Courier New, Courier, monospace;"><span style="line-height: 14px;">Option Explicit
Dim objUser, objDomain, lngBias, objLockout, dtmLockout
Dim objDuration, lngDuration, lngHigh, lngLow, dtmUnLock
Dim strUserDN, strDNSDomain, strNetBIOSDomain, strUserNTName
Dim objTrans, objShell, lngBiasKey, k, objRootDSE
Dim strText, strTitle, intConstants, intAns, objNetwork
' Constants for the NameTranslate object.
Const ADS_NAME_INITTYPE_GC = 3
Const ADS_NAME_TYPE_NT4 = 3
Const ADS_NAME_TYPE_1779 = 1
strTitle = "UnlockUser"
Set objShell = CreateObject("Wscript.Shell")
' Request user sAMAccountName.
strUserNTName = Trim(InputBox("Enter User NT Logon Name", strTitle))
If strUserNTName = "" Then
  strText = "Program Aborted"
  intConstants = vbOKOnly + vbExclamation
  intAns = objShell.Popup(strText, , strTitle, intConstants)
  WScript.Quit
End If
' Retrieve DNS domain name.
Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = objRootDSE.Get("defaultNamingContext")
' Convert DNS domain name to NetBIOS domain name.
Set objTrans = CreateObject("NameTranslate")
objTrans.Init ADS_NAME_INITTYPE_GC, ""
objTrans.Set ADS_NAME_TYPE_1779, strDNSDomain
strNetBIOSDomain = objTrans.Get(ADS_NAME_TYPE_NT4)
' Remove trailing backslash.
strNetBIOSDomain = Left(strNetBIOSDomain, Len(strNetBIOSDomain) - 1)
Set objNetwork = CreateObject("Wscript.Network")
If UCase(Trim(strUserNTName)) = UCase(Trim(objNetwork.UserName)) And UCase(strNetBIOSDomain) = UCase(objNetwork.UserDomain) Then
  strText = "You cannot unlock or change the password for your own account."
  intConstants = vbOKOnly + vbExclamation
  intAns = objShell.Popup(strText, , strTitle, intConstants)
  WScript.Quit
End If
' Convert user NT name to Distinguished Name.
On Error Resume Next
objTrans.Set ADS_NAME_TYPE_NT4, strNetBIOSDomain & "" & strUserNTName
If Err.Number <> 0 Then
  On Error GoTo 0
  strText = "User " & strUserNTName & " not found"
  strText = strText & vbCrLf & "Program aborted"
  intConstants = vbOKOnly + vbCritical
  intAns = objShell.Popup(strText, , strTitle, intConstants)
  WScript.Quit
End If
On Error GoTo 0
strUserDN = objTrans.Get(ADS_NAME_TYPE_1779)
' Escape any forward slash characters, "/", with the backslash
' escape character. All other characters that should be escaped are.
strUserDN = Replace(strUserDN, "/", "/")
' Bind to user object.
On Error Resume Next
Set objUser = GetObject("LDAP://" & strUserDN)
If Err.Number <> 0 Then
  On Error GoTo 0
  strText = "User " & strUserNTName & " not found"
  strText = strText & vbCrLf & "DN: " & strUserDN
  strText = strText & vbCrLf & "Program aborted"
  intConstants = vbOKOnly + vbCritical
  intAns = objShell.Popup(strText, , strTitle, intConstants)
  WScript.Quit
End If
On Error GoTo 0
' Bind to domain.
Set objDomain = GetObject("LDAP://" & strDNSDomain)
' Obtain local Time Zone bias from machine registry.
lngBiasKey = objShell.RegRead("HKLMSystemCurrentControlSetControlTimeZoneInformationActiveTimeBias")
If UCase(TypeName(lngBiasKey)) = "LONG" Then
  lngBias = lngBiasKey
ElseIf UCase(TypeName(lngBiasKey)) = "VARIANT()" Then
  lngBias = 0
  For k = 0 To UBound(lngBiasKey)
    lngBias = lngBias + (lngBiasKey(k) * 256^k)
  Next
End If
' Retrieve user lockoutTime, Convert to date and display lockout status.
On Error Resume Next
Set objLockout = objUser.lockoutTime
If Err.Number <> 0 Then
 On Error GoTo 0
 strText = "User " & strUserNTName & " is not locked out."
 strText = strText & vbCrLf & "Would you like to reset the password?"
 intConstants = vbYesNo + vbQuestion
 intAns = objShell.Popup(strText, , strTitle, intConstants)
 If intAns = vbYes Then Call ChangePassword(objUser)
 WScript.Quit
End If
On Error GoTo 0
dtmLockout = Integer8Date(objLockout, lngBias)
If dtmLockout = #1/1/1601# Then
 strText = "User " & strUserNTName & " is not locked out."
 strText = strText & vbCrLf & "Would you like to reset the password?"
 intConstants = vbYesNo + vbQuestion
 intAns = objShell.Popup(strText, , strTitle, intConstants)
 If intAns = vbYes Then Call ChangePassword(objUser)
 WScript.Quit
End If
strText = "User " & strUserNTName & " locked out at: " & dtmLockout
' Retrieve domain lockoutDuration policy.
Set objDuration = objDomain.lockoutDuration
lngHigh = objDuration.HighPart
lngLow = objDuration.LowPart
If (lngHigh = 0 And lngLow = 0) Then
 ' There is no domain lockout duration policy.
 ' Locked out accounts remain locked out Until reset.
 ' Any user With value of lockoutTime greater than 0 is locked out.
 lngDuration = -999
 strText = strText & vbCrLf & "Domain locked accounts do not automatically unlock."
Else
 If (lngLow < 0) Then
 lngHigh = lngHigh + 1
 End If
 lngDuration = lngHigh * (2^32) + lngLow
 lngDuration = -lngDuration/(60 * 10000000)
 strText = strText & vbCrLf & "Domain lockout duration (minutes): " & lngDuration
End If
' Determine if account still locked out and ask user how to proceed.
Dim intUnlockAns
intUnlockAns = vbNo
If lngDuration = -999 Then
  strText = strText & vbCrLf & "Account is locked indefinately."
  strText = strText & vbCrLf & "Click ""Yes"" to unlock account now"
  strText = strText & vbCrLf & "Click ""No"" to leave account locked"
  intConstants = vbYesNo + vbExclamation
  intUnlockAns = objShell.Popup(strText, , strTitle, intConstants)
Else
 dtmUnLock = DateAdd("n", lngDuration, dtmLockout)
 If Now > dtmUnLock Then
  strText = strText & vbCrLf & "The account was unlocked at: " & dtmUnLock
  strText = strText & vbCrLf & "Would you like to reset the password?"
  intConstants = vbYesNo + vbQuestion
  intAns = objShell.Popup(strText, , strTitle, intConstants)
  If intAns = vbYes Then Call ChangePassword(objUser)
  WScript.Quit
 Else
  strText = strText & vbCrLf & "Account will unlock at: " & dtmUnLock
  strText = strText & vbCrLf & "Click ""Yes"" to unlock account now"
  strText = strText & vbCrLf & "Click ""No"" to leave account locked"
  intConstants = vbYesNo + vbExclamation
  intUnlockAns = objShell.Popup(strText, , strTitle, intConstants)
 End If
End If
If intUnlockAns = vbYes Then
 On Error Resume Next
 objUser.IsAccountLocked = False
 objUser.SetInfo
 If Err.Number <> 0 Then
   On Error GoTo 0
   strText = "Unable to unlock user " & strUserNTName
   strText = "You may not have sufficient rights"
   strText = "Program aborted"
   intConstants = vbOKOnly + vbCritical
   intAns = objShell.Popup(strText, , strTitle, intConstants)
 Else
   On Error GoTo 0
   strText = "User " & strUserNTName & " unlocked"
   intConstants = vbOKOnly + vbExclamation
   intAns = objShell.Popup(strText, , strTitle, intConstants)
 End If
ElseIf intAns = vbNo Then
 strText = "User " & strUserNTName & " account left locked out"
 intConstants = vbOKOnly + vbInformation
 intAns = objShell.Popup(strText, , strTitle, intConstants)
Else
 strText = "Program aborted"
 strText = strText & vbCrLf & "User " & strUserNTName & " still locked out"
 intConstants = vbOKOnly + vbExclamation
 intAns = objShell.Popup(strText, , strTitle, intConstants)
End If
' Clean up.
Set objUser = Nothing
Set objDomain = Nothing
Set objLockout = Nothing
Set objDuration = Nothing
Set objTrans = Nothing
Set objShell = Nothing
Function Integer8Date(objDate, lngBias)
' Function to convert Integer8 (64-bit) value to a date, adjusted for
' local time zone bias.
Dim lngAdjust, lngDate, lngHigh, lngLow
lngAdjust = lngBias
lngHigh = objDate.HighPart
lngLow = objdate.LowPart
' Account for bug in IADslargeInteger property methods.
If lngLow < 0 Then
 lngHigh = lngHigh + 1
End If
If (lngHigh = 0) And (lngLow = 0) Then
 lngAdjust = 0
End If
lngDate = #1/1/1601# + (((lngHigh * (2 ^ 32)) + lngLow) / 600000000 - lngAdjust) / 1440
Integer8Date = CDate(lngDate)
End Function
Sub ChangePassword(objUser)
Dim strPassword, intPwdValue, strText
strPassword = RandomPassword(8)
intPwdValue = 0     ' Force a change of password at next logon
strText = "The user will be required to change their password when they logon."
strPassword = InputBox(strText,"The new password is:",strPassword)
If strPassword <> "" Then
 objUser.SetPassword strPassword
 objUser.Put "PwdLastSet", intPwdValue
 objUser.SetInfo
Else
 strText = "Password not changed"
 intConstants = vbOKOnly + vbExclamation
 intAns = objShell.Popup(strText, , strTitle, intConstants)
End If
End Sub
Function RandomPassword(intCharacters)
Dim intASCIIValue, i, intLowerLimit, intUpperLimit
Randomize  
intLowerLimit = 48
intUpperLimit = 122
For i = 1 To intCharacters
 intASCIIValue = Int(((intUpperLimit - intLowerLimit + 1) * Rnd) + intLowerLimit)  
 RandomPassword = RandomPassword & Chr(intASCIIValue)
Next
End Function</span></span></blockquote>

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

<blockquote>Option Explicit

Dim objUser, objDomain, lngBias, objLockout, dtmLockout

Dim objDuration, lngDuration, lngHigh, lngLow, dtmUnLock

Dim strUserDN, strDNSDomain, strNetBIOSDomain, strUserNTName

Dim objTrans, objShell, lngBiasKey, k, objRootDSE

Dim strText, strTitle, intConstants, intAns, objNetwork

' Constants for the NameTranslate object.

Const ADS_NAME_INITTYPE_GC = 3

Const ADS_NAME_TYPE_NT4 = 3

Const ADS_NAME_TYPE_1779 = 1

strTitle = "UnlockUser"

Set objShell = CreateObject("Wscript.Shell")

' Request user sAMAccountName.

strUserNTName = Trim(InputBox("Enter User NT Logon Name", strTitle))

If strUserNTName = "" Then

strText = "Program Aborted"

intConstants = vbOKOnly + vbExclamation

intAns = objShell.Popup(strText, , strTitle, intConstants)

WScript.Quit

End If

' Retrieve DNS domain name.

Set objRootDSE = GetObject("LDAP://RootDSE")

strDNSDomain = objRootDSE.Get("defaultNamingContext")

' Convert DNS domain name to NetBIOS domain name.

Set objTrans = CreateObject("NameTranslate")

objTrans.Init ADS_NAME_INITTYPE_GC, ""

objTrans.Set ADS_NAME_TYPE_1779, strDNSDomain

strNetBIOSDomain = objTrans.Get(ADS_NAME_TYPE_NT4)

' Remove trailing backslash.

strNetBIOSDomain = Left(strNetBIOSDomain, Len(strNetBIOSDomain) - 1)

Set objNetwork = CreateObject("Wscript.Network")

If UCase(Trim(strUserNTName)) = UCase(Trim(objNetwork.UserName)) And UCase(strNetBIOSDomain) = UCase(objNetwork.UserDomain) Then

strText = "You cannot unlock or change the password for your own account."

intConstants = vbOKOnly + vbExclamation

intAns = objShell.Popup(strText, , strTitle, intConstants)

WScript.Quit

End If

' Convert user NT name to Distinguished Name.

On Error Resume Next

objTrans.Set ADS_NAME_TYPE_NT4, strNetBIOSDomain & "" & strUserNTName

If Err.Number <> 0 Then

On Error GoTo 0

strText = "User " & strUserNTName & " not found"

strText = strText & vbCrLf & "Program aborted"

intConstants = vbOKOnly + vbCritical

intAns = objShell.Popup(strText, , strTitle, intConstants)

WScript.Quit

End If

On Error GoTo 0

strUserDN = objTrans.Get(ADS_NAME_TYPE_1779)

' Escape any forward slash characters, "/", with the backslash

' escape character. All other characters that should be escaped are.

strUserDN = Replace(strUserDN, "/", "/")

' Bind to user object.

On Error Resume Next

Set objUser = GetObject("LDAP://" & strUserDN)

If Err.Number <> 0 Then

On Error GoTo 0

strText = "User " & strUserNTName & " not found"

strText = strText & vbCrLf & "DN: " & strUserDN

strText = strText & vbCrLf & "Program aborted"

intConstants = vbOKOnly + vbCritical

intAns = objShell.Popup(strText, , strTitle, intConstants)

WScript.Quit

End If

On Error GoTo 0

' Bind to domain.

Set objDomain = GetObject("LDAP://" & strDNSDomain)

' Obtain local Time Zone bias from machine registry.

lngBiasKey = objShell.RegRead("HKLMSystemCurrentControlSetControlTimeZoneInformationActiveTimeBias")

If UCase(TypeName(lngBiasKey)) = "LONG" Then

lngBias = lngBiasKey

ElseIf UCase(TypeName(lngBiasKey)) = "VARIANT()" Then

lngBias = 0

For k = 0 To UBound(lngBiasKey)

lngBias = lngBias + (lngBiasKey(k) * 256^k)

End If

' Retrieve user lockoutTime, Convert to date and display lockout status.

On Error Resume Next

Set objLockout = objUser.lockoutTime

If Err.Number <> 0 Then

On Error GoTo 0

strText = "User " & strUserNTName & " is not locked out."

strText = strText & vbCrLf & "Would you like to reset the password?"

intConstants = vbYesNo + vbQuestion

intAns = objShell.Popup(strText, , strTitle, intConstants)

If intAns = vbYes Then Call ChangePassword(objUser)

WScript.Quit

End If

On Error GoTo 0

dtmLockout = Integer8Date(objLockout, lngBias)

If dtmLockout = #1/1/1601# Then

strText = "User " & strUserNTName & " is not locked out."

strText = strText & vbCrLf & "Would you like to reset the password?"

intConstants = vbYesNo + vbQuestion

intAns = objShell.Popup(strText, , strTitle, intConstants)

If intAns = vbYes Then Call ChangePassword(objUser)

WScript.Quit

End If

strText = "User " & strUserNTName & " locked out at: " & dtmLockout

' Retrieve domain lockoutDuration policy.

Set objDuration = objDomain.lockoutDuration

lngHigh = objDuration.HighPart

lngLow = objDuration.LowPart

If (lngHigh = 0 And lngLow = 0) Then

' There is no domain lockout duration policy.

' Locked out accounts remain locked out Until reset.

' Any user With value of lockoutTime greater than 0 is locked out.

lngDuration = -999

strText = strText & vbCrLf & "Domain locked accounts do not automatically unlock."

Else

If (lngLow < 0) Then

lngHigh = lngHigh + 1

End If

lngDuration = lngHigh * (2^32) + lngLow

lngDuration = -lngDuration/(60 * 10000000)

strText = strText & vbCrLf & "Domain lockout duration (minutes): " & lngDuration

End If

' Determine if account still locked out and ask user how to proceed.

Dim intUnlockAns

intUnlockAns = vbNo

If lngDuration = -999 Then

strText = strText & vbCrLf & "Account is locked indefinately."

strText = strText & vbCrLf & "Click ""Yes"" to unlock account now"

strText = strText & vbCrLf & "Click ""No"" to leave account locked"

intConstants = vbYesNo + vbExclamation

intUnlockAns = objShell.Popup(strText, , strTitle, intConstants)

Else

dtmUnLock = DateAdd("n", lngDuration, dtmLockout)

If Now > dtmUnLock Then

strText = strText & vbCrLf & "The account was unlocked at: " & dtmUnLock

strText = strText & vbCrLf & "Would you like to reset the password?"

intConstants = vbYesNo + vbQuestion

intAns = objShell.Popup(strText, , strTitle, intConstants)

If intAns = vbYes Then Call ChangePassword(objUser)

WScript.Quit

Else

strText = strText & vbCrLf & "Account will unlock at: " & dtmUnLock

strText = strText & vbCrLf & "Click ""Yes"" to unlock account now"

strText = strText & vbCrLf & "Click ""No"" to leave account locked"

intConstants = vbYesNo + vbExclamation

intUnlockAns = objShell.Popup(strText, , strTitle, intConstants)

End If

If intUnlockAns = vbYes Then

On Error Resume Next

objUser.IsAccountLocked = False

objUser.SetInfo

If Err.Number <> 0 Then

On Error GoTo 0

strText = "Unable to unlock user " & strUserNTName

strText = "You may not have sufficient rights"

strText = "Program aborted"

intConstants = vbOKOnly + vbCritical

intAns = objShell.Popup(strText, , strTitle, intConstants)

Else

On Error GoTo 0

strText = "User " & strUserNTName & " unlocked"

intConstants = vbOKOnly + vbExclamation

intAns = objShell.Popup(strText, , strTitle, intConstants)

End If

ElseIf intAns = vbNo Then

strText = "User " & strUserNTName & " account left locked out"

intConstants = vbOKOnly + vbInformation

intAns = objShell.Popup(strText, , strTitle, intConstants)

Else

strText = "Program aborted"

strText = strText & vbCrLf & "User " & strUserNTName & " still locked out"

intConstants = vbOKOnly + vbExclamation

intAns = objShell.Popup(strText, , strTitle, intConstants)

End If

' Clean up.

Set objUser = Nothing

Set objDomain = Nothing

Set objLockout = Nothing

Set objDuration = Nothing

Set objTrans = Nothing

Set objShell = Nothing

Function Integer8Date(objDate, lngBias)

' Function to convert Integer8 (64-bit) value to a date, adjusted for

' local time zone bias.

Dim lngAdjust, lngDate, lngHigh, lngLow

lngAdjust = lngBias

lngHigh = objDate.HighPart

lngLow = objdate.LowPart

' Account for bug in IADslargeInteger property methods.

If lngLow < 0 Then

lngHigh = lngHigh + 1

End If

If (lngHigh = 0) And (lngLow = 0) Then

lngAdjust = 0

End If

lngDate = #1/1/1601# + (((lngHigh * (2 ^ 32)) + lngLow) / 600000000 - lngAdjust) / 1440

Integer8Date = CDate(lngDate)

End Function

Sub ChangePassword(objUser)

Dim strPassword, intPwdValue, strText

strPassword = RandomPassword(8)

intPwdValue = 0 ' Force a change of password at next logon

strText = "The user will be required to change their password when they logon."

strPassword = InputBox(strText,"The new password is:",strPassword)

If strPassword <> "" Then

objUser.SetPassword strPassword

objUser.Put "PwdLastSet", intPwdValue

objUser.SetInfo

Else

strText = "Password not changed"

intConstants = vbOKOnly + vbExclamation

intAns = objShell.Popup(strText, , strTitle, intConstants)

End If

End Sub

Function RandomPassword(intCharacters)

Dim intASCIIValue, i, intLowerLimit, intUpperLimit

Randomize

intLowerLimit = 48

intUpperLimit = 122

For i = 1 To intCharacters

intASCIIValue = Int(((intUpperLimit - intLowerLimit + 1) * Rnd) + intLowerLimit)

RandomPassword = RandomPassword & Chr(intASCIIValue)

End Function</blockquote>

Dziękuję Ci, za poświęcony czas na przeczytanie tego artykułu. Jeśli był on dla Ciebie przydatny, to gorąco zachęcam Cię do zapisania się na mój newsletter, jeżeli jeszcze Cię tam nie ma. Proszę Cię także o “polubienie” mojego bloga na Facebooku oraz kanału na YouTube – pomoże mi to dotrzeć do nowych odbiorców. Raz w tygodniu (niedziela punkt 17.00) otrzymasz powiadomienia o nowych artykułach / projektach zanim staną się publiczne. Możesz również pozostawić całkowicie anonimowy pomysł na wpis/nagranie.

Link do formularza tutaj: https://beitadmin.pl/pomysly

Pozostaw również komentarz lub napisz do mnie wiadomość odpisuję na każdą, jeżeli Masz jakieś pytania:).

Dodaj komentarz Anuluj pisanie odpowiedzi