Active Directory - alle EMailadressen in Datei ausgeben

Hi,

aufgrund der Komplexität habe ich die Umsetzung angepasst.

Es geht nun darum alle Mailadressen der Domäne, also von Benutzern, Gruppen etc. auszulesen und in eine Datei zu schreiben (wenn möglich nur bis zum @ Zeichen).

Das auslesen des Namens und der DN funktioniert auch, Problem hier ist nur das, sobald ich bei "Do Until" "Mail" ausgeben möchte (also auch die Mailadresse) sagt er:

Error: Type mismatch: 'WriteLine'
Code: 800A000D
Sorce: Microsoft VBScript runtime error

Hier der Code:

Const ADS_SCOPE_SUBTREE = 5
Dim fso, file
Set fso = CreateObject("Scripting.FileSystemObject")
Set file = fso.CreateTextFile("n:\ausgabe.txt", True)

Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection

objCommand.Properties("Page Size") = 1000
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE

objCommand.CommandText = "SELECT distinguishedname,mail,name FROM 'LDAP://DC=www,DC=domain,DC=de'WHERE objectCategory='user'" & _
"OR objectCategory='group'"

Set objRecordSet = objCommand.Execute

Do Until objRecordSet.EOF
file.WriteLine(objRecordSet.Fields("distinguishedname"))
file.WriteLine(objRecordSet.Fields("mail"))
file.WriteLine(objRecordSet.Fields("name"))
objRecordSet.MoveNext
Loop

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 74893

Url: https://administrator.de/contentid/74893

Ausgedruckt am: 14.11.2024 um 09:11 Uhr

2 Kommentare

Neuester Kommentar

Hallo Breede,

ich habe leider nur den Tip, die dem jeweiligen System bekannten SMTP-Adressen auszulesen, vielleicht hilft es trotzdem:

http://www.msexchangefaq.de/code/smtplist.htm

Grüße, Steffen

Hier die Lösung:

Noch etwas zur Erklärung.

Erst hole ich alle Attribute aus dem LDAP die eine Mail Adresse enthalten können.

Mailadresse : mail
Weitere Mailadressen: proxyAddresses
Mailbox: othermailbox

Diese gebe ich dann in eine Datei aus, da aber viele Objekte die eine Mail Adresse haben könnten keine haben, entstehen viele Leerzeilen. Diese werden mit der Prozedur "Leerzeilen" entfernt.

Um das ganze lesbarer zu machen, habe ich zusätzlich alles ab dem @ mit dem Replace entfernt.

Nun liegen alle Mailadressen der Domäne, alphabetisch sortiert und ohne Leerzeilen in einer Datei.

''''' Konstanten '''''  

Const ADS_SCOPE_SUBTREE = 5

''''' Variablen '''''  

Dim fso
Dim strRecordsetInhalt
Dim File_SAC_Input
Dim File_SAC

Set fso             = CreateObject("Scripting.FileSystemObject")  
Set File_SAC_Input  = fso.CreateTextFile("N:\SAC_Input.txt", True)  
Set File_SAC        = fso.CreateTextFile("N:\SAC.txt", True)  

''''' Verbindung zum Active Directory '''''  

Set objConnection               = CreateObject("ADODB.Connection")  
Set objCommand                  = CreateObject("ADODB.Command")  
objConnection.Provider          = "ADsDSOObject"  
objConnection.Open("Active Directory Provider")  

Set objCommand.ActiveConnection      = objConnection
objCommand.Properties("Page Size")   = 1000  
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE  

''''' Abfrage und Ausgabe per SQL über LDAP '''''  

objCommand.CommandText =	" SELECT mail, othermailbox, proxyAddresses " & _  
			" FROM 'LDAP://DC=www,DC=xxx,DC=de' " & _  
			" WHERE mail <> '@' " & _  
			" ORDER BY mail "  
' Ohne WHERE konnte kein ORDER BY angesprochen werden  

Set objRecordSet = objCommand.Execute

Do Until objRecordSet.EOF
	strRecordsetInhalt = Trim(objRecordSet.GetString(2, , VbCrLf,VbCrLf,""))  
	strRecordsetInhalt = UCase(strRecordsetInhalt)
	strRecordsetInhalt = Replace(strRecordsetInhalt,"@WWW.XXX.DE","")  
	File_SAC_Input.WriteLine(strRecordsetInhalt)
	If not objRecordSet.EOF Or objRecordSet.BOF Then
		objRecordSet.MoveNext 
		' MoveNext bei objRecordSet.EOF verursacht einen Fehler  
	End If
Loop

File_SAC_Input.Close
Call Leerzeichen

''''' Sub Routinen '''''  

Sub Leerzeichen

''''' Alle Leerzeilen werden entfernt  
'''''  
''''' Quelle mit Leerzeilen: "Open_SAC_Input"  
''''' Ziel ohne Leerzeilen : "File_SAC"  

''''' Variablen '''''  

Dim sLine

Set Open_SAC_Input  = fso.OpenTextFile("N:\SAC_Input.txt", 1, True)  

''''' Entfernen der Leerzeilen '''''  

Do Until Open_SAC_Input.AtEndOfStream
	sLine = Open_SAC_Input.ReadLine
	If Trim(sLine) <> "" Then  
		File_SAC.WriteLine(sLine)
	End If
Loop
File_SAC.Close

End Sub