Find duplicate smtp address in domain

Hi Experts,

I am looking for a VB Script to find the duplicate smtp address exist in network.
Please help me to obtain this task... also am fine if some other script if you have.

Script Source:
https://support.quest.com/SolutionDetail.aspx?id=SOL48668

i found a script on a website, but it throughs an error below.

ERROR:
*************************************************************
................................................................................
................................................................................
....

AD domains processed:
        DC=Temple,DC=qc Objects: 147235

C:\Temp\SOL48668_DupSMTP-s\DupSMTP.vbs(234, 5) Microsoft VBScript runtime error:
 Invalid procedure call or argument
**************************************************************

Script:

'	Version:	20020210.02
'
'	DUPSMTP	locate duplicate SMTP addresses across all AD domains
'			Produces a tab-separated values file of all SMTP proxy
'			addresses that are used by more than one Active Directory
'			object.
'
'			The script must be run from CSCRIPT. The suggested command line is:
'				cscript dupsmtp.vbs >output.txt //Nologo
'
'			The outout file contains these fields:
'				ProxyAddress		- the SMTP address
'				DistinguishedName	- the DN of the object that uses the ProxyAddress
'				FolderPath			- the folderPathname if the DN is a Public Folder
'									  otherwise it's empty (making it convenient to find
'									  conflicts between public folders and users or groups
'			
'		
'	Author:	Rich Matheisen
' --------------------------------------------------------------------------
'	Copyright (C) 2002 Richard Matheisen
' --------------------------------------------------------------------------
'
'	Changes:
'		20020209.01	-	initial release
'		20020210.02 -
' 			added count of items processed in each domain to domain dictionary
' 			added folderPathname to compliment DN (probably needs work on the display format)
' 			added error checking on binding to GC
' 			write errors to SDTERR
' 			write duplicates dictionary to STDOUT
'				changed format to tab-separated w/header, 
'				each set of duplicates separated by one blank line
' 			write domains dictionary to STDERR
'			write version info to STDERR
'			sort the data in Domain and Proxy dictionaries before output
'			added progress "crawl" to STDERR
'			adjusted LDAP page size (100, was 1000)
'			adjusted LDAP query timeout (900 seconds, was 120 seconds)
' ==========================================================================================

option explicit

Dim oGC				' IADs
DIM strGCADsPath	' String
DIM var				' Variant
Dim adoConn			' ADODB.Connection
Dim adoCmd			' ADODB.Command
Dim adoRecSet		' ADODB.Recordset
DIM strADOQuery 	' String
Dim strADOFields	' String
Dim Base			' String

' values used to open connection
Dim userID, Password, Options
UserID		= vbNullString
Password	= vbNullString
Options		= -1

' **  LDAP query parameters  **
' keep the pages size small (100 may even be too big)
' keep the timeout long - 900 seconds (15 min)
'  (busy GCs may take quite a long time to return a page full of results, 
'   and timing out after running for 10 minutes on a large dataset is discouraging)
Dim pgsize			' LDAP query page size
pgsize		= 100
Dim tmout			' LDAP query timeout
tmout		= 900

Dim bIsOK	' just a boolean used to return results

' variables used to work with the data
Dim pxy				' the array of proxyAddresses
Dim dn				' the Distinguished Name
Dim	fldr			' the Public Folder path name
DIM dictSmtpaddr	' dictionary of SMTP addresses
DIM dictDomains		' dictionary of AD Domains processed


	Wscript.StdErr.WriteBlanklines(1)
	Wscript.StdErr.Writeline "#"
	Wscript.StdErr.Writeline "# DUPSMTP - Version 20020210.02"
	Wscript.StdErr.Writeline "#"

'	---------------------------------------
'	Bind to the Global catalog.  
'	---------------------------------------
	Dim NS

	On Error resume Next
	Set NS = GetObject("GC:")
	If Err.Number <> 0 Then
		WScript.StdErr.Writeline "Cannot bind to GC: " & _
					 vbLF & "Error code: " & Err.Number & _
					 vbLF & "Error desc: " & Err.Description
		Wscript.Exit
	End If
	On Error Goto 0

'	---------------------------------------
'	Once we have the container we enumerate 
'	one time to get the GC object
'	---------------------------------------
	For Each var in NS
		Set oGC = var
	Next
	strGCADsPath = oGC.ADsPath    ' cache the ADsPath for the query
	Base = strGCADsPath
'	---------------------------------------
'	Set up the connection
'	---------------------------------------
	bIsOK = OpenAdoConnection(adoConn, UserId, Password, Options)
	If (Not bIsOK) Then
		Wscript.StdErr.WriteLine "Couldn't open connection. Exiting."
		Wscript.Quit
	End If

'   -----------------------------------------
'	Build the query string using LDAP dialect
'	Build the results string using LDAP dialect
'   -----------------------------------------
	strADOQuery = "(|(&(objectCategory=person)(objectClass=user))" & _
				  "(objectClass=publicFolder)" & _
				  "(&(objectCategory=person)(objectClass=contact))" & _
				  "(&(objectCategory=Group)(objectClass=group)))"
	strADOFields =  "cn,distinguishedName,proxyAddresses,folderPathname,objectClass,objectCategory"

'   -----------------------------------------
'   Set up the command
'   --------------------------------------
	bIsOK = OpenAdoCommand(	Base, _
							strADOQuery, _
							strADOFields, _
							"Subtree",pgsize,tmout,adoConn,adoCmd)
	If (Not bIsOK) Then
		Wscript.StdErr.Writeline "Couldn't create command. Exiting."
		Wscript.Quit
	End If

'   ----------------------------------------------------
'	Execute the query for the objects in the directory
'   ----------------------------------------------------
	bIsOK = OpenAdoRecordSet(adoCmd, adoRecSet)
	If (Not bIsOK) Then
		Wscript.StdErr.Writeline "Failed to create record set. Exiting."
		Wscript.Quit
	End If

	' Create the Dictionaries to hold the results
	Set dictDomains = CreateObject("Scripting.Dictionary")
	dictDomains.CompareMode = 1									' case-insensitive keys
	Set dictSmtpAddr = CreateObject("Scripting.Dictionary")
	dictSmtpAddr.CompareMode = 1								' case-insensitive keys

'	--------------------------------------------------
'	Process each item in the recordset
'	--------------------------------------------------
	Dim ctr									' just a progress indicator
	while (not adoRecSet.EOF)
		Dim n, i, a							' scratch areas
		
		ctr = ctr + 1
		If (ctr MOD 200) Then				' write a "crawl" on the console to indicate progress
			Wscript.StdErr.Write "."
		End If
		pxy = adoRecSet.Fields("proxyAddresses")
		dn = adoRecSet.Fields("distinguishedName")
		fldr = adoRecSet.Fields("folderPathname")

		' extract just the AD domain from the Distinguished Name
		i = InStr(1, dn, ",DC=",vbTextCompare)	' find the first DC in the DN (case-insensitive search)
		n = Right(dn,Len(dn) - i)				' use the DC's as the key
		If (not dictDomains.Exists(n)) Then
			dictDomains.Add n, 1
		Else
			dictDomains.Item(n) = (dictDomains.Item(n)) + 1
		End If


		' store the DN and folder path with all other DN's having the same SMTP address	
		'  the proxy addresses may not exist, so test to avoid any runtime errors
		'  *   the VarType should be 8204 [8192 (vbArray) + 12 (vbVariant)]
		If (VarType(pxy) AND vbArray) Then
			Dim j
			For j = LBound(pxy) To UBound(pxy)
				n = pxy(j)
				If (UCase(Left(n,5)) = "SMTP:") then
					dn = dn & vbTab & fldr				' add folderPathname to DN so Public Folders are easier to find
					i = Right(n,Len(n)-5)				' omit the address type prefix
					If (dictSmtpaddr.Exists(i)) Then	' use SMTP address as key
						a = dictSmtpaddr.Item(i)		' get the array of DN using this address
						Redim Preserve a(Ubound(a) + 1)	' increase size of array, preserving contents
						a(Ubound(a)) = dn				' add new DN
						dictSmtpAddr.Item(i) = a		' save the list
					Else
						Redim a(0)						' create new list
						a(0) = dn						' add DN to it
						dictSmtpaddr.Add i, a			' save list in dictionary
					End If
				End If
			Next	' next proxy address
		End If		' end of proxy addresses array test
		' Advance the recordset
		adoRecSet.MoveNext
	Wend

'	-----------------------------------------------------
'	All information has been processed, begin reporting
'	-----------------------------------------------------
	Dim k, keys, ln

	' report on the domains that were encountered and the number
	' of objects in each domain (this doesn't add anything to the 
	' value of the data but it does "validate" that all domains
	' have been looked at.
	WScript.StdErr.WriteBlankLines(2)
	WScript.StdErr.Writeline "AD domains processed:"
	keys = dictDomains.keys
	Call Quicksort (keys, LBound(keys), UBound(keys))
	For Each k In keys
		Wscript.StdErr.WriteLine vbTab & k & vbTab & "Objects: " & dictDomains.Item(k)
	Next
	WScript.StdErr.WriteBlankLines(1)

	' report on the duplicate SMTP addresses encountered
	keys = dictSmtpAddr.Keys
	Call Quicksort (keys, LBound(keys), UBound(keys))
	Wscript.StdOut.Writeline "ProxyAddress" & vbTab & "DistinguishedName" & vbTab & "FolderPath"
	For Each k In keys
		a = dictSmtpaddr.Item(k)
		If (Ubound(a) > 0) Then		' only report the exceptions (>1 DN uses the same proxy address)
			For Each i In a
				ln = k & vbTab & i	' each "i" contains a vbTab to separate DN and folder path
				Wscript.StdOut.Writeline ln
			Next
			Wscript.Stdout.Writeline vbTab & vbTab	' keep same number of columns in each row
		End If
	Next

	adoRecSet.Close
	adoConn.Close

	Set adoRecSet = Nothing
	Set adoCmd = Nothing
	Set adoConn = Nothing

	Set oGC = Nothing

'================================================================

' Use:
'	Dim bIsOK
'	Dim adoConn
'	Dim UserId, Password, Options
'	UserId = vbNullString
'	Password = vbNullString
'	Options = -1
' 	bIsOK = OpenAdoCommand(adoConn, UserId, Password, Options)
'   if Not bIsOK Then
'		... no connection was returned
'	Else
'		... connection is open and ready to use
'	End If
'

Function OpenAdoConnection (ByRef adoConnection, ByVal UserId, ByVal Password, ByVal Options)

	Dim adoCommand

	On Error Resume Next

	Set adoConnection 	= Wscript.CreateObject("ADODB.Connection")

	' Open the connection
	adoConnection.Provider	= "ADsDSOObject"

	' connection string, userid, password, options
	Err.Clear
	adoConnection.Open  "Active Directory Provider", UserId, Password, Options

	' Return "false" and exit if connection failed
	If Err.Number <> 0 Then
		OpenAdoConnection = False
		Exit Function
	End If
	OpenAdoConnection = True
End Function

'=================================================================================
' Close an existing connection
Function CloseAdoConnection(ByRef adoConnection)
	adoConnection.Close
	Set adoConnection = Nothing
End Function


'=================================================================================
' Use:
' Dim bIsOK
' Dim adoConn		' a Connection object
' Dim adoCmd
'
' bIsOK = OpenAdoCommand("LDAP://dc3.rmcons.com:3268/dc=rmcons,dc=com"
'			"(&(objectCategory=person)(objectClass=user))", _
'			"cn,distinguishedName","Subtree",100,120,adoConn,adoCmd)
'
Function OpenAdoCommand( _
	ByVal strLDAPBase, ByVal strCriteria, ByVal strAttributeList, _
	ByVal strDepth, ByVal PageSize, ByVal TimeOut, _
	ByVal adoConnection, ByRef adoCommand _
)

	Const ADS_SCOPE_BASE		= 0	' see ADS_SCOPE in ADSI docs
	Const ADS_SCOPE_ONELEVEL	= 1	' see ADS_SCOPE in ADSI docs
	Const ADS_SCOPE_SUBTREE		= 2	' see ADS_SCOPE in ADSI docs
	Const ADS_CHASE_REFERRALS_EXTERNAL = 64

	Set adoCommand		= Wscript.CreateObject("ADODB.Command")
	Set adoCommand.ActiveConnection = adoConnection

	' Set the command to execute the query
	adoCommand.CommandText = "<" & strLDAPBase & ">;" & _
		strCriteria & ";" & strAttributeList & ";" & _
		strDepth

'	adoCommand.CommandText = 	"SELECT '" & _
'								strAttributeList & "' " & _
'								"FROM '" & _
'								strLDAPBase & "' " & _
'								"WHERE '" & _
'								strCriteria & "'"

	adoCommand.Properties("Page Size") 	= PageSize
	adoCommand.Properties("Timeout")	= Timeout
	adoCommand.Properties("Chase referrals") = ADS_CHASE_REFERRALS_EXTERNAL
	Select Case Lcase(strDepth)
		Case "base"
			adoCommand.Properties("searchscope")	= ADS_SCOPE_BASE
		Case "onelevel"
			adoCommand.Properties("searchscope")	= ADS_SCOPE_ONELEVEL
		Case "subtree"
			adoCommand.Properties("searchscope")	= ADS_SCOPE_SUBTREE
		Case Else
			adoCommand.Properties("searchscope")	= ADS_SCOPE_SUBTREE
	End Select
	adoCommand.Properties("Cache Results")	= False

' uncomment the next line to display the command used to run the query
'Wscript.Echo adoCommand.CommandText

	OpenAdoCommand = True
End Function

'=================================================================================
' -- execute the connection's command and return the resulting record set
Function OpenAdoRecordSet(ByVal adoCommand, ByRef adoRecordSet)
	' Execute the command
	Err.Clear
	Set adoRecordset = adoCommand.Execute
	If Err.Number <> 0 Then
		Set adoRecordset = Nothing
		OpenAdoRecordSet = False
		Exit Function
	End If

	OpenAdoRecordSet = True
End Function

'=================================================================================
' -- Close and release an open record set
Function CloseAdoRecordSet(ByRef adoRecSet)
	adoRecSet.Close
	Set adoRecSet = Nothing
	CloseAdoRecordSet = True
End Function

' ================================================================================
'
Sub Quicksort(strValues(), ByVal min, ByVal max)

	Dim strMediumValue, high, low, i
	
	If (min >= max) Then Exit Sub	' if there's only one item

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

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

	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

		strValues(low) = strValues(high)	' swap the low and high strValues

		' 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 values
		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

Select allOpen in new window

Thanks,
Prem