VBS – Taking input from one spreadsheet and output to another

15 pts.
Tags:
Development
VBS
VBScript
Visual Basic developers
Visual Basic Script
Hello, I am hoping someone can shed some light as I am at a complete lost. I am using an excellent script written by Ralph Montgomery named NTUser.wsf for account audit purposes and I am attempting to modify it to suit my needs. The script, in its native format, prompts for a username upon execution via input box and then displays a wide range of relevant information about that user via pop-up as well. i have modified the script so that instead of entering a single username at a time via vbs pop-up, it pulls usernames from a previously generated spreadsheet (which I am passing to the script via a cscript argument). This part works in that it parses through the "input" spread and presents me with a pop-up with information about each user, one at a time as it reads the spreadsheet. My problem is that I am now attempting to collect the entire output for each one of these user via a second spreadsheet (whose name I also plan to pass along to the script via a second cscript argument) but I cannot wrap my head around it. The below code is what I have so far and all I end up with is the output of the very last user from the input spreadsheet. I am not too experienced with vbscript and I am not sure what I am doing wrong. The code I have so far is below. The original script is found here http://www.akaplan.com/blog/wp-content/uploads/2009/10/NTUserInfo.txt
' Abridged original remarks from Ralph Mongtomery
' Get User Information NTUser.wsf
' Version 1.0 Created 11-26-2001 by Ralph Montgomery (rmonty@myself.com)

' Alan Kaplan remarks
' 3/23/2009 I have been using this script for a very long time, and have probably hacked
' it beyond recognition. I take neither the credit nor the blame for the clumsy bits...
' I stripped out Win9x stuff, and system info detection, as everyone I know
' using this is at XP or later.

'10/23/2009 added support for and enumeration of UPN

Option Explicit
on error resume next 'iffy
Dim strUserName, objUserDomain, objGroup, objUser, strGroupList
Dim WshShell, strMessage, strTitle
Dim oDomain, strNTDomain, strVer
Dim strSortedGroups, arrGroupList, strUserList
Dim objChangePwdTrue, objChangePwd, objUserProfile
Dim objPwdExpiresTrue, objFlags, oPwdExpire, strPwdExpires
Dim objAcctDisabled, intPwdExpired, objPwdExpiredTrue, objPwdExpires,bAccountDisabled
Dim StrQuote, iBadLogins, iMaxPadPw, iAccountLockout, iPwdAge
' Excel
Dim strExcelReadPath, strExcelwritePath, objExcel, objSheet, intRow, strUserDN, strPassword, k


' Check for required Excel arguments ''''''''''
If (Wscript.Arguments.Count < 1) Then
Wscript.Echo "Arguments <FileName> required. For example:" & vbCrLf _
& "cscript enumaccountpolicies.vbs c:inputspreadsheet.xls c:outputspreadsheet.xls"
Wscript.Quit(0)
End If


' Spreadsheet files (IN & OUT)
strExcelReadPath = Wscript.Arguments(0)
strExcelwritePath = Wscript.Arguments(1)


' Bind to Excel object
On Error Resume Next
Set objExcel = CreateObject("Excel.Application")
If (Err.Number <> 0) Then
On Error GoTo 0
Wscript.Echo "Excel application not found."
Wscript.Quit
End If
On Error GoTo 0

'''
Set WshShell = WScript.CreateObject("WScript.Shell")
strVer = "Ver 3.1 "
strQuote = Chr(34)
Dim strNTName, strUPN
Const ADS_NAME_INITTYPE_GC = 3
Const ADS_NAME_TYPE_NT4 = 3
Const ADS_NAME_TYPE_1779 = 1
Const ADS_NAME_TYPE_USER_PRINCIPAL_NAME = 9
Dim strNTUserName
Const ADS_NAME_INITTYPE_DOMAIN = 1
Const ADS_NAME_TYPE_UNKNOWN = 8
Const ADS_NAME_TYPE_CANONICAL = 2

Dim oTrans
Set oTrans = CreateObject("NameTranslate")

' Pull Environment variables for domain/user
strNTDomain = WshShell.ExpandEnvironmentStrings("%USERDOMAIN%")
strNTUserName = ucase(WshShell.ExpandEnvironmentStrings("%USERNAME%"))

'Call info sub
GetInfo

''''''''''''''' Functions and Subs ''''''''''''''''''
Sub GetInfo()

' Open "Read" spreadsheet
On Error Resume Next
objExcel.Workbooks.Open strExcelReadPath
If (Err.Number <> 0) Then
On Error GoTo 0
Wscript.Echo "Spreadsheet cannot be opened: " & strExcelReadPath
Wscript.Quit
End If
On Error GoTo 0

' Bind to worksheet
Set objSheet = objExcel.ActiveWorkbook.Worksheets(1)

' The first row of the spreadsheet is skipped (column headings). Each
' row after the first is processed until the first blank entry in the
' first column is encountered.
intRow = 2
Do While objSheet.Cells(intRow, 1).Value <> ""
strUserName = objSheet.Cells(intRow, 1).Value
strNTUserName = strUserName
On Error Resume Next

'Attempt to bind to the user
Set objUser = GetObject("WinNT://"& strNTDomain & "/" & strNTUserName & ", user")
If (Err.Number <> 0) Then
On Error GoTo 0
Wscript.Echo "User NOT found: " & strNTUserName
Else
'Call Output sub
'Output
End If
'Next Row
intRow = intRow + 1
Loop
'Call Output sub
Output

' Close the workbook.
objExcel.ActiveWorkbook.Close

' Quit Excel.
objExcel.Application.Quit

' Clean up.
Set objUser = Nothing
Set objExcel = Nothing
Set objSheet = Nothing

Wscript.Echo "Read Done"

End Sub

Sub Output()
'Mostly RM. AK added AdminBitCount, copy to IE
Dim iAdminCount, dPwdLastChanged, iAutoUnlock
On Error resume Next
' Creates the list of goups the user belongs To
For Each objGroup In objUser.Groups
If strGroupList = "" Then
strGroupList = objGroup.Name
Else
strGroupList = strGroupList & ", " & objGroup.Name
End If
Next
' Convert strgrouplist to Array
arrGroupList = Split(strGroupList,",")
'Sort the durn thing
Quicksort arrGroupList, LBound(arrGroupList), UBound(arrGroupList)
' Now concatenate arrGroupList into a variable for display
strSortedGroups = trim(Join(arrGroupList, ", "))

'check for expired password
intPwdExpired = objUser.Get("PasswordExpired")

If intPwdExpired = 1 Then
objPwdExpiredTrue = "Yes"
Else objPwdExpiredTrue = "No"
End If

'Check for Must Change Password Flag
objFlags = objUser.Get("UserFlags")
If (objFlags And &H00040) <> 0 Then
objChangePwdTrue = "No"
Else objChangePwdTrue = "Yes"
End If

' Is password set to NEVER expire?
objPwdExpires = objUser.Get("UserFlags")

If (objPwdExpires And &H10000) <> 0 Then
objPwdExpiresTrue = "Yes"
strPwdExpires = "Date Set: "
Else objPwdExpiresTrue = "No"
strPwdExpires = "Password Expires: "
End If

' Is the account disabled?
If objUser.AccountDisabled = True Then
bAccountDisabled = "Yes"
Else bAccountDisabled = "No"
End If

'How many wrong logins?
'Dim iBadLogins
iBadLogins = objUser.BadPasswordAttempts

'Maximum bad password attempts?
iMaxPadPw = objUser.MaxBadPasswordsAllowed

'Account Lockout Observation Interval
iAccountLockout = FormatNumber((objUser.LockoutObservationInterval/60), 0)

' How old is the current password?
iPwdAge = FormatNumber(((objUser.Get("PasswordAge")/60)/60)/24, 0)

' Calculate the date the password was last changed
dPwdLastChanged = CStr(objUser.PasswordExpirationDate - objUser.Get("MaxPasswordAge") / (60 * 60 * 24))

iAdminCount = objUser.Get("AdminCount")

' Set Profile path to tabs if blank
objUserProfile = objUser.Profile
If objUserProfile = "" Then
objUserProfile= "<None>" & vbTab
Else objUserProfile = objUserProfile
End If

' Determine how many passwords are saved
Set oDomain = GetObject("WinNT://" & strNTDomain)

Dim intPwdHistory
intPwdHistory = oDomain.PasswordHistoryLength
iAutoUnlock = oDomain.AutoUnlockInterval/60

' Set strMessage box variables to null
strMessage =""

''''''''''''''''''''''''''''''
' Generate Output Worksheet '
''''''''''''''''''''''''''''''

' Create a new workbook.
objExcel.Workbooks.Add

' Bind to worksheet.
Set objSheet = objExcel.ActiveWorkbook.Worksheets(1)
objSheet.Name = "Audit Results"

' Populate spreadsheet cells with user attributes.
objSheet.Cells(1, 1).Value = "Account Attributes"
objSheet.Cells(1, 2).Value = "Date & Time of Retrieval: " & (NOW())
objSheet.Cells(3, 1).Value = "Full Name"
objSheet.Cells(3, 2).Value = "Account Name"
objSheet.Cells(3, 3).Value = "Description"
objSheet.Cells(3, 4).Value = "Account Disabled?"
objSheet.Cells(3, 5).Value = "Account Locked Out?"
objSheet.Cells(3, 6).Value = "Bad Logins"
objSheet.Cells(3, 7).Value = "~Last Logon"
objSheet.Cells(3, 8).Value = "Max Password Attempts"
objSheet.Cells(3, 9).Value = "Attempts Left"
objSheet.Cells(3, 10).Value = "Password Never Expires?"
objSheet.Cells(3, 11).Value = "Password Expired?"
objSheet.Cells(3, 12).Value = "Password Age"
objSheet.Cells(3, 13).Value = "Password Last Changed"
objSheet.Cells(3, 14).Value = "Password Next Change"
objSheet.Cells(3, 15).Value = "User can Change Password?"
objSheet.Cells(3, 16).Value = "Password minimum length"
objSheet.Cells(3, 17).Value = "Passwords kept in history"
objSheet.Cells(3, 18).Value = "Lock-out Time"
objSheet.Cells(3, 19).Value = "Auto-Unlock Time"
objSheet.Cells(3, 20).Value = "Group Memberships"

k = 4
For each objUser in strNTUserName
objSheet.Cells(k, 1).Value = objUser.FullName
objSheet.Cells(k, 2).Value = strNTDomain & "" & strNTUserName
objSheet.Cells(k, 3).Value = objUser.Description
objSheet.Cells(k, 4).Value = bAccountDisabled
objSheet.Cells(k, 5).Value = objUser.IsAccountLocked
objSheet.Cells(k, 6).Value = iBadLogins
objSheet.Cells(k, 7).Value = objUser.LastLogin
objSheet.Cells(k, 8).Value = iMaxPadPw
objSheet.Cells(k, 9).Value = iMaxPadPw - iBadLogins
objSheet.Cells(k, 10).Value = objPwdExpiresTrue
objSheet.Cells(k, 11).Value = objPwdExpiredTrue
objSheet.Cells(k, 12).Value = iPwdAge & " days"
objSheet.Cells(k, 13).Value = dPwdLastChanged
objSheet.Cells(k, 14).Value = strPwdExpires
objSheet.Cells(k, 15).Value = objChangePwdTrue
objSheet.Cells(k, 16).Value = objUser.PasswordMinimumLength
objSheet.Cells(k, 17).Value = intPwdHistory & " password(s)"
objSheet.Cells(k, 18).Value = iAccountLockout & " minutes"
objSheet.Cells(k, 19).Value = iAutoUnlock & " minutes"
objSheet.Cells(k, 20).Value = strSortedGroups

k = k + 1
Next





End Sub

' Sorts the items in the array (between the two values you pass in).
Sub Quicksort(strValues(), ByVal min, ByVal max)

Dim strMediumValue, high, low, i

'If the list has only 1 item, it's sorted.
If min >= max Then Exit Sub

' Pick a dividing item randomly.
i = min + Int(Rnd(max - min + 1))
strMediumValue = strValues(i)

' Swap the dividing item to the front of the list.
strValues(i) = strValues(min)

' Separate the list into sublists.
low = min
high = max
Do
' Look down from high for a value < strMediumValue.
Do While strValues(high) >= strMediumValue
high = high - 1
If high <= low Then Exit Do
Loop

If high <= low Then
'The list is separated.
strValues(low) = strMediumValue
Exit Do
End If

'Swap the low and high strValues.
strValues(low) = strValues(high)

'Look up from low for a value >= strMediumValue.
low = low + 1
Do While strValues(low) < strMediumValue
low = low + 1
If low >= high Then Exit Do
Loop

If low >= high Then
'The list is separated.
low = high
strValues(high) = strMediumValue
Exit Do
End If

'Swap the low and high strValues.
strValues(high) = strValues(low)
Loop 'Loop until the list is separated.

'Recursively sort the sublists.
Quicksort strValues, min, low - 1
Quicksort strValues, low + 1, max

End Sub

Function GetUPN (strNTName)
On Error Resume Next
oTrans.Init ADS_NAME_INITTYPE_GC, ""
oTrans.Set ADS_NAME_TYPE_UNKNOWN,strNTName
If Err <> 0 Then
MsgBox "Unable to lookup " & strNTName,vbCritical + vbOKOnly,"Error"
WScript.Quit
End If
GetUPN = oTrans.Get(5)
End Function

Function GetNTPath (strUPN)
On Error Resume next
oTrans.Init ADS_NAME_INITTYPE_GC, ""
oTrans.Set ADS_NAME_TYPE_USER_PRINCIPAL_NAME,strUPN
If Err <> 0 Then
MsgBox "Unable to lookup " & strUPN,vbCritical + vbOKOnly,"Error"
WScript.Quit
End If

GetNTPath = oTrans.Get(ADS_NAME_TYPE_NT4)
GetNTPath = Replace(GetNTPath,"","/")
End Function 

Answer Wiki

Thanks. We'll let you know when a new response is added.

Without spending a lot of time on this, one thing jumps at me. You are using the same global variable “objSheet” for both input and output, setting it in the functions “ExcelReadSheet” and “ExcelWriteSheet”.
I suspect that changing the objSheet binding back and forth may be causing the loop to fail.

I would first try declaring a second “objSheetOut” and only use that for the output sheet.

Discuss This Question: 2  Replies

 
There was an error processing your information. Please try again later.
Thanks. We'll let you know when a new response is added.
Send me notifications when members answer or reply to this question.

REGISTER or login:

Forgot Password?
By submitting you agree to receive email from TechTarget and its partners. If you reside outside of the United States, you consent to having your personal data transferred to and processed in the United States. Privacy
  • Fsck
    Anyone? I have updated the code (below). My problem is that it is only working partially. To summarize, I am using a single workbook containing two worksheets. Worksheet 1 is where the script reads from, and it is just one column with a list of sAMAccountNames. Worksheet 2 is where the script writes the output to for each of the sAMAccountNames after fetching the values from the domain. My problem seems to be that I do not know how to code the Loop such that it increments to the next Row for each of worksheets as it parses through the sAMAccountNames. As a result, the script succeeds only for the first row (reads input from first row in worksheet 1 and writes output to first row in worksheet2) but it does not process the subsequent rows. Does anyone know how I can accomplish this loop?
    ' Abridged original remarks from Ralph Mongtomery
    ' Get User Information NTUser.wsf
    ' Version 1.0 Created 11-26-2001 by Ralph Montgomery (rmonty@myself.com)
    
    ' Alan Kaplan remarks
    ' 3/23/2009 I have been using this script for a very long time, and have probably hacked
    ' it beyond recognition. I take neither the credit nor the blame for the clumsy bits...
    ' I stripped out Win9x stuff, and system info detection, as everyone I know
    ' using this is at XP or later.
    
    '10/23/2009 added support for and enumeration of UPN
    
    Option Explicit
    Dim strUserName, objUserDomain, objGroup, objUser, strGroupList
    Dim WshShell, strMessage, strTitle
    Dim oDomain, strNTDomain, strVer
    Dim strSortedGroups, arrGroupList, strUserList
    Dim objChangePwdTrue, objChangePwd, objUserProfile
    Dim objPwdExpiresTrue, objFlags, oPwdExpire, strPwdExpires, iAdminCount, dPwdLastChanged, iAutoUnlock
    Dim objAcctDisabled, intPwdExpired, objPwdExpiredTrue, objPwdExpires,bAccountDisabled
    Dim StrQuote, iBadLogins, iMaxPadPw, iAccountLockout, iPwdAge, intPwdHistory
    Dim strExcelPath, objExcel, objSheet, intReadRow, strUserDN, strPassword, xlExcel7, intWriteRow
    Set WshShell = WScript.CreateObject("WScript.Shell")
    strVer = "Ver 3.1 "
    strQuote = Chr(34)
    Dim strNTName, strUPN
    Const ADS_NAME_INITTYPE_GC = 3
    Const ADS_NAME_TYPE_NT4 = 3
    Const ADS_NAME_TYPE_1779 = 1
    Const ADS_NAME_TYPE_USER_PRINCIPAL_NAME = 9
    Dim strNTUserName
    Const ADS_NAME_INITTYPE_DOMAIN = 1
    Const ADS_NAME_TYPE_UNKNOWN = 8
    Const ADS_NAME_TYPE_CANONICAL = 2
    
    Dim oTrans
    Set oTrans = CreateObject("NameTranslate")
    
    ' Check for required script arguments
    If (Wscript.Arguments.Count < 1) Then
        Wscript.Echo "Arguments <FileName> required. For example:" & vbCrLf _
            & "cscript enumaccountpolicies.vbs c:spreadsheet.xls"
        Wscript.Quit(0)
    End If
    
    ' Pull Environment variables for domain/user
    strNTDomain = WshShell.ExpandEnvironmentStrings("%USERDOMAIN%")
    strNTUserName = ucase(WshShell.ExpandEnvironmentStrings("%USERNAME%"))
    
    
    	'------------------------------------------MAIN----------------------------------------------
    	
    	Call Excel
    	Call ExcelAddOutputSheet
    	Call GetandWriteInfo
    
    
    	' Format the spreadsheet.
    	'objSheet.Range("A1:A5").Font.Bold = True
    	'objSheet.Select
    	'objSheet.Range("B5").Select
    	'objExcel.ActiveWindow.FreezePanes = True
    	'objExcel.Columns(1).ColumnWidth = 20
    	'objExcel.Columns(2).ColumnWidth = 30
    	
    	' Save the spreadsheet and close the workbook.
    	objExcel.ActiveWorkbook.SaveAs strExcelPath
    	objExcel.ActiveWorkbook.Close
    	
    	' Quit Excel.
    	objExcel.Application.Quit
    	
    	' Clean up.
    	Set objUser = Nothing
    	Set objExcel = Nothing
    	Set objSheet = Nothing
    	
    	Wscript.Echo "Done"
    
    	'---------------------------------------------END MAIN-------------------------------------------
    	
    	
    
    '''''''''Subs and Functions ''''''''''
    
    Sub Excel  'Bind to Excel object and Workbook
    
    	' Define Workbook Path
    	strExcelPath = Wscript.Arguments(0)
    	
    	' Bind to Excel object
    	On Error Resume Next
    	Set objExcel = CreateObject("Excel.Application")
    	If (Err.Number <> 0) Then
    	On Error GoTo 0
    	Wscript.Echo "Excel application not found"
    	Wscript.Quit
    	End If
    	objExcel.Visible = True
    	On Error GoTo 0
    	
    	' Bind to Workbook
    	On Error Resume Next
    	objExcel.Workbooks.Open strExcelPath
    	If (Err.Number <> 0) Then
    	On Error GoTo 0
    	Wscript.Echo "Spreadsheet cannot be opened: " & strExcelPath
    	Wscript.Quit
    	End If
    	On Error GoTo 0
    End Sub
    
    
    Sub ExcelReadSheet 'Bind to INPUT Worksheet in Workbook
    	Set objSheet = objExcel.ActiveWorkbook.Worksheets(1)
    End Sub
    
    
    Sub ExcelWritesheet  'Bind to OUTPUT Worksheet in Workbook
    	Set objSheet = objExcel.ActiveWorkbook.Worksheets(2)
    End Sub
    
    
    Sub ExcelAddOutputSheet 'Populate Headings in OUTPUT Worksheet
    	
    	'Bind to OUTPUT worksheet in current Workbook
    	Call ExcelWriteSheet
    	'Name Worksheet
    	objSheet.Name = "Audit Results"
    	'Populate
    	objSheet.Cells(1, 1).Value = "Account Attributes"
    	objSheet.Cells(1, 2).Value = "Date & Time of Retrieval: " & (NOW())
    	objSheet.Cells(3, 1).Value = "Full Name"
    	objSheet.Cells(3, 2).Value = "Account Name"
    	objSheet.Cells(3, 3).Value = "Description"
    	objSheet.Cells(3, 4).Value = "Account Disabled"
    	objSheet.Cells(3, 5).Value = "Account Locked Out"
    	objSheet.Cells(3, 6).Value = "Bad Logins"
    	objSheet.Cells(3, 7).Value = "~Last Logon"
    	objSheet.Cells(3, 8).Value = "Max Password Attempts"
    	objSheet.Cells(3, 9).Value = "Attempts Left"
    	objSheet.Cells(3, 10).Value = "Password Never Expires"
    	objSheet.Cells(3, 11).Value = "Password Expired?"
    	objSheet.Cells(3, 12).Value = "Password Age"
    	objSheet.Cells(3, 13).Value = "Password Last Changed"
    	objSheet.Cells(3, 14).Value = "Password Next Change"
    	objSheet.Cells(3, 15).Value = "User can Change Password"
    	objSheet.Cells(3, 16).Value = "Password Minimum Length"
    	objSheet.Cells(3, 17).Value = "Passwords Kept in History"
    	objSheet.Cells(3, 18).Value = "Lock-out Time"
    	objSheet.Cells(3, 19).Value = "Auto-Unlock Time"
    	objSheet.Cells(3, 20).Value = "Group Memberships"
    End Sub
    
    
    Sub GetandWriteInfo  'Reads INPUT Worksheet, Fetches Parameters, and writes to OUTPUT Worksheet
    
    	'Read INPUT Worksheet
    	Call ExcelReadSheet
    	
    	'The first row of the input worksheet is skipped (column headings). 
    	'Each row after the first is processed until the first blank entry 
    	'in the first column is encountered.
    	intReadRow = 2
    	Do While objSheet.Cells(intReadRow, 1).Value <> ""
    	strUserName = objSheet.Cells(intReadRow, 1).Value
    	strNTUserName = strUserName
    	On Error Resume Next
    	
    	'Attempt to bind to the user account
    	Set objUser = GetObject("WinNT://"& strNTDomain & "/" & strNTUserName & ", user")
    	If (Err.Number <> 0) Then
    	On Error GoTo 0
    	Wscript.Echo "User NOT found: " & strNTUserName 
    	
    	Else
    	
    	''''''Fetch Account Parameters''''''
    	On Error resume Next
    	' Creates the list of groups the user belongs To
    	For Each objGroup In objUser.Groups
    	If strGroupList = "" Then
    	strGroupList = objGroup.Name
    	Else
    	strGroupList = strGroupList & ", " & objGroup.Name
    	End If
    	Next
    	' Convert strgrouplist to Array
    	arrGroupList = Split(strGroupList,",")
    	'Sort the darn thing
    	Quicksort arrGroupList, LBound(arrGroupList), UBound(arrGroupList)
    	' Now concatenate arrGroupList into a variable for display
    	strSortedGroups = trim(Join(arrGroupList, ", "))
    	
    	'check for expired password
    	intPwdExpired = objUser.Get("PasswordExpired")
    	If intPwdExpired = 1 Then
    	objPwdExpiredTrue = "Yes"
    	Else objPwdExpiredTrue = "No"
    	End If
    	
    	'Check for Must Change Password Flag
    	objFlags = objUser.Get("UserFlags")
    	If (objFlags And &H00040) <> 0 Then
    	objChangePwdTrue = "No"
    	Else objChangePwdTrue = "Yes"
    	End If
    	
    	' Is password set to NEVER expire?
    	objPwdExpires = objUser.Get("UserFlags")
    	If (objPwdExpires And &H10000) <> 0 Then
    	objPwdExpiresTrue = "Yes"
    	strPwdExpires = "Date Set: "
    	Else objPwdExpiresTrue = "No"
    	strPwdExpires = "Password Expires: "
    	End If
    	
    	' Is the account disabled?
    	If objUser.AccountDisabled = True Then
    	bAccountDisabled = "Yes"
    	Else bAccountDisabled = "No"
    	End If
    	
    	'How many wrong logins?
    	iBadLogins = objUser.BadPasswordAttempts
    	
    	'Maximum bad password attempts?
    	iMaxPadPw = objUser.MaxBadPasswordsAllowed
    	
    	'Account Lockout Observation Interval
    	iAccountLockout = FormatNumber((objUser.LockoutObservationInterval/60), 0)
    	
    	'How old is the current password?
    	iPwdAge = FormatNumber(((objUser.Get("PasswordAge")/60)/60)/24, 0)
    	
    	'Calculate the date the password was last changed
    	dPwdLastChanged = CStr(objUser.PasswordExpirationDate - objUser.Get("MaxPasswordAge") / (60 * 60 * 24))
    	
    	iAdminCount = objUser.Get("AdminCount")
    	
    	'Set Profile path to tabs if blank
    	objUserProfile = objUser.Profile
    	If objUserProfile = "" Then
    	objUserProfile= "<None>" & vbTab
    	Else objUserProfile = objUserProfile
    	End If
    	
    	'Determine how many passwords are saved
    	Set oDomain = GetObject("WinNT://" & strNTDomain)
    	intPwdHistory = oDomain.PasswordHistoryLength
    	iAutoUnlock = oDomain.AutoUnlockInterval/60
    	
    	
    	'Bind to OUTPUT Worksheet in current Workbook
    	Call ExcelWriteSheet
    	'Write results to OUTPUT Worksheet
    	Call Writeinfo
    	
    	End If
    	
    	'Attempt to process next worksheet rows via Loop
    	intReadRow = intReadRow + 1
    	'intWriteRow = intWriteRow + 1
    	Loop
    
    End Sub 
    
    
    Sub WriteInfo 'Writes Fetched Parameters to OUTPUT Worksheet
    	
    	'Write values to OUTPUT Worksheet
    	intWriteRow = 4
    	objSheet.Cells(intWriteRow, 1).Value = objUser.FullName
    	objSheet.Cells(intWriteRow, 2).Value = strNTDomain & "" & strNTUserName
    	objSheet.Cells(intWriteRow, 3).Value = objUser.Description
    	objSheet.Cells(intWriteRow, 4).Value = bAccountDisabled
    	objSheet.Cells(intWriteRow, 5).Value = objUser.IsAccountLocked
    	objSheet.Cells(intWriteRow, 6).Value = iBadLogins
    	objSheet.Cells(intWriteRow, 7).Value = objUser.LastLogin
    	objSheet.Cells(intWriteRow, 8).Value = iMaxPadPw
    	objSheet.Cells(intWriteRow, 9).Value = iMaxPadPw - iBadLogins
    	objSheet.Cells(intWriteRow, 10).Value = objPwdExpiresTrue
    	objSheet.Cells(intWriteRow, 11).Value = objPwdExpiredTrue
    	objSheet.Cells(intWriteRow, 12).Value = iPwdAge
    	objSheet.Cells(intWriteRow, 13).Value = dPwdLastChanged
    	objSheet.Cells(intWriteRow, 14).Value = strPwdExpires
    	objSheet.Cells(intWriteRow, 15).Value = objChangePwdTrue
    	objSheet.Cells(intWriteRow, 16).Value = objUser.PasswordMinimumLength
    	objSheet.Cells(intWriteRow, 17).Value = intPwdHistory & " password(s)"
    	objSheet.Cells(intWriteRow, 18).Value = iAccountLockout & " minutes"
    	objSheet.Cells(intWriteRow, 19).Value = iAutoUnlock & " minutes"
    	objSheet.Cells(intWriteRow, 20).Value = strSortedGroups
    
    End Sub
    
    
    Sub Quicksort(strValues(), ByVal min, ByVal max) 'Sorts the items in the array (between the two values you pass in)
    	Dim strMediumValue, high, low, i
    	
    	'If the list has only 1 item, it's sorted.
    	If min >= max Then Exit Sub
    	
    	' Pick a dividing item randomly.
    	i = min + Int(Rnd(max - min + 1))
    	strMediumValue = strValues(i)
    	
    	' Swap the dividing item to the front of the list.
    	strValues(i) = strValues(min)
    	
    	' Separate the list into sublists.
    	low = min
    	high = max
    	Do
    	' Look down from high for a value < strMediumValue.
    	Do While strValues(high) >= strMediumValue
    	high = high - 1
    	If high <= low Then Exit Do
    	Loop
    	
    	If high <= low Then
    	'The list is separated.
    	strValues(low) = strMediumValue
    	Exit Do
    	End If
    	
    	'Swap the low and high strValues.
    	strValues(low) = strValues(high)
    	
    	'Look up from low for a value >= strMediumValue.
    	low = low + 1
    	Do While strValues(low) < strMediumValue
    	low = low + 1
    	If low >= high Then Exit Do
    	Loop
    	
    	If low >= high Then
    	'The list is separated.
    	low = high
    	strValues(high) = strMediumValue
    	Exit Do
    	End If
    	
    	'Swap the low and high strValues.
    	strValues(high) = strValues(low)
    	Loop 'Loop until the list is separated.
    	
    	'Recursively sort the sublists.
    	Quicksort strValues, min, low - 1
    	Quicksort strValues, low + 1, max
    
    End Sub
    
    
    Function GetUPN (strNTName)
    	On Error Resume Next
    	oTrans.Init ADS_NAME_INITTYPE_GC, ""
    	oTrans.Set ADS_NAME_TYPE_UNKNOWN,strNTName
    	If Err <> 0 Then
    	MsgBox "Unable to lookup " & strNTName,vbCritical + vbOKOnly,"Error"
    	WScript.Quit
    	End If
    	GetUPN = oTrans.Get(5)
    End Function
    
    
    Function GetNTPath (strUPN)
    	On Error Resume next
    	oTrans.Init ADS_NAME_INITTYPE_GC, ""
    	oTrans.Set ADS_NAME_TYPE_USER_PRINCIPAL_NAME,strUPN
    	If Err <> 0 Then
    	MsgBox "Unable to lookup " & strUPN,vbCritical + vbOKOnly,"Error"
    	WScript.Quit
    	End If
    	
    	GetNTPath = oTrans.Get(ADS_NAME_TYPE_NT4)
    	GetNTPath = Replace(GetNTPath,"","/")
    End Function 
    15 pointsBadges:
    report
  • Chippy088
    If I have understood the code, I think the problem lies within the Sub WriteInfo ‘Write values to OUTPUT Worksheet intWriteRow = 4 this is setting the output line to be always 4 as it is not being used properly within the sub routine try incrementing writerow at the end of the sub and take out the intWriteRow = 4 line and make the variable public. (it is telling the sub to write at line 4 and is not getting incremented as far as i can see, so it keeps writing to line 4, overwriting anything already there.)
    4,625 pointsBadges:
    report

Forgot Password

No problem! Submit your e-mail address below. We'll send you an e-mail containing your password.

Your password has been sent to:

To follow this tag...

There was an error processing your information. Please try again later.

REGISTER or login:

Forgot Password?
By submitting you agree to receive email from TechTarget and its partners. If you reside outside of the United States, you consent to having your personal data transferred to and processed in the United States. Privacy

Thanks! We'll email you when relevant content is added and updated.

Following