Exchange Öffentliche Ordner per VBScript o.ä. Email-aktivieren

Zu 1: Im Emails direkt an öffentliche Ordner zuzustellen, müssen diese Email-aktiviert werden. Das kann man über den System-Manager machen.
In ordner, öffentliche Ordner rechte Maustatste auf den Ordner, alle Tasks und dann Email aktivieren.

zu 2:
ich lese das AD wie folgt aus:

Function ReadAD()
On Error Resume Next
Const AccessTable = "ADEmailadressen"

' List of Folders who should NOT be exported
' This list should contain the Folder's logon name
' Separate each name by a comma
Const Folders2Skip = ""

' Constant for the search to search subtrees
Const ADS_SCOPE_SUBTREE = 2

Const adOpenStatic = 3
Const adLockOptimistic = 3

' General variable declarations
Dim objConnectionDB As Database
Dim objRecordsetDB As Recordset
Dim objConnectionAD, objCommandAD, objRecordsetAD
Dim strSQL
Dim objRootDSE, strDNSDomain
Dim strDN, strDisplayName
Dim objFolder
Dim i

'Create and open ADO connection to the Access database
Set objConnectionDB = CurrentDb
Set objRecordsetDB = objConnectionDB.OpenRecordset("ADEmailAdressen", dbOpenTable)

' Define the SQL statement used to clear out previous
' Folder info which was exported from AD
DoCmd.SetWarnings False
DoCmd.RunSQL "DELETE FROM ADEmailAdressen WHERE ImportedFromAD = True"

' Determine the DNS domain from the RootDSE object.
Set objRootDSE = GetObject("LDAP:RootDSE")
strDNSDomain = objRootDSE.Get("defaultNamingContext")

' Create and open an ADO connection to AD
Set objConnectionAD = CreateObject("ADODB.Connection")
Set objCommandAD = CreateObject("ADODB.Command")

objConnectionAD.Provider = "ADsDSOObject"
objConnectionAD.Open "Active Directory Provider"

' Set connection properties
With objCommandAD
.ActiveConnection = objConnectionAD

' Use SQL syntax for the query
' This retrieves all values named in the SELECT section for
' Folder accounts which do not have the Notes section = NoExport.
' The recordset is sorted ascending on the displayName value.


.CommandText = "Select distinguishedName, name, ObjectClass," & _
" displayName, msExchHideFromAddressLists, givenname, sn, cn, mail, " & _
" sAMAccountname, displayName, textEncodedORAddress" & _
" FROM 'LDAP:" & strDNSDomain & "'" & _
" WHERE objectCategory = 'person' AND objectClass='user' OR" & _
" objectCategory='publicFolder' or objectCategory='group' OR" & _
" objectCategory='contact' OR objectCategory='msExchDynamicDistributionList'" & _
" ORDER BY displayName"

' "distinguishedName,name,ObjectClass,LegacyExchangeDN,msExchADCGlobalNames," & _
' "displayName,msExchHideFromAddressLists,hideDLMembership,msexchmasteraccountsid," & _
' "msExchALObjectVersion,showInAddressBook,msExchPolicyEnabled,givenName,sn,cn,mailNickname,targetAddress,proxyAddresses," & _
' "mail,textEncodedORAddress,msExchHomeServerName,msExchExpansionServerName,msExchCustomProxyAddresses,msExchPoliciesIncluded," & _
' "msExchPoliciesExcluded,homeMDB,homeMTA,msExchMailboxGuid,unmergedAtts,msExchDynamicDLFilter,msExchPurportedSearchUI," & _
' "msExchMailboxSecurityDescriptor,msExchResourceGUID,UserAccountControl,msExchUserAccountControl

.Properties("Page Size") = 1000
.Properties("Timeout") = 30
.Properties("Searchscope") = ADS_SCOPE_SUBTREE
.Properties("Cache Results") = False
End With
Set objRecordsetAD = objCommandAD.Execute

' Move to the first record in the recordset
objRecordsetAD.MoveFirst

' Loop until we reach the end of the recordset
Do While Not objRecordsetAD.EOF
' Get the distinguished name of this folder
' The syntax is something like:
' CN=Joe E. Law,OU=Sales,OU=US,DC=mydomain,DC=local
strDN = objRecordsetAD.Fields("distinguishedName")
' Bind to the user object
Err.Clear
Set objFolder = GetObject("LDAP://" & strDN & "")

With objFolder
If Err.Number = 0 And _
Not IsNull(.DisplayName) And Trim(.DisplayName) <> "" And Not IsNull(.mail) And Trim(.mail) <> "" _
And InStr(.DisplayName, "SystemMailbox") = 0 _
And InStr(.DisplayName, "OWAScratch") = 0 _
And InStr(.DisplayName, "Outlook 10") = 0 _
And InStr(.DisplayName, "StoreEvents") = 0 Then

'Add new record to the Access database
objRecordsetDB.AddNew
' Get Folder data from AD and populate the new record in the
' Access database
objRecordsetDB("DisplayName") = .DisplayName
objRecordsetDB("Description") = .sAMAccountname
objRecordsetDB("objectCategory") = .objectCategory
objRecordsetDB("distinguishedName") = .textEncodedORAddress
objRecordsetDB("Email") = .mail
objRecordsetDB("ImportedFromAD") = True
' Commit the record
objRecordsetDB.Update
End If
' Release this object reference
Set objFolder = Nothing
End With

' Move to the next record in the AD recordset
objRecordsetAD.MoveNext
Loop

' Close the Access database recordset
objRecordsetDB.Close
' Close the Access database connection
objConnectionDB.Close

' Release these object references
Set objRecordsetDB = Nothing
Set objConnectionDB = Nothing

' Close the AD recordset
objRecordsetAD.Close
' Close the AD connection
objConnectionAD.Close

' Release these object references
Set objRecordsetAD = Nothing
Set objConnectionAD = Nothing

' Delete Empty entries
DoCmd.RunSQL "DELETE FROM ADEmailAdressen WHERE Trim(nz(DisplayName)) = ''"

End Function

Die Routine ist noch im Test und enthält deshalb überflüssigen/nicht optimierten Code.

Hierbei erhalte ich den Ordnernamen allerdings nicht in seiner Baumstruktur. Ein Ordner
Öffentliche Ordner\Alle öffentlichenOrdner\Testordner\Unterordner1 wird nur mit dem Namen Unterordner1 ausgegeben.


Gruß Jehemo2001