OL, VBA, Name des Publ Folders herausbekommen

Hallo,

ich schreibe ein Makro, mit dem man in OL (hier 2013) eine E-Mail aus einem Spam-Filter-Ordner in den Posteingang des ursprünglichen Adressaten zu verschieben.
Für eine Person mit Postfach funktioniert das. Auch wenn der ursprüngliche Adressat die "Haupt-E-Mail-Adresse" (Adresse 1) eines öffentlichen Ordners ist funktioniert mein Code.
Allerdings habe ich ein Problem, wenn der Öffentliche Ordner weitere E-Mail-Adressen hat (Adresse 2, ..., Adresse n). Ohne es getestet zu haben nehme ich an, dass ich ein ähnliches Problem bekommen könnte, wenn eine Person mit Postfach mehrere E-Mail-Adressen hat.

Ich suche nun einen Weg, mit dem ich, basierend auf der vorliegenden E-Mail-Adresse (Adresse 2) die Hauptadresse (Adresse 1) herausfinden kann. Wie kann ich das anstellen?

Wenn weitere Infos nötig sind, stelle ich die gerne zur Verfügung.

Neugierige Grüße,
Andreas

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

Content-ID: 351409

Url: https://administrator.de/forum/ol-vba-name-des-publ-folders-herausbekommen-351409.html

Ausgedruckt am: 23.12.2024 um 10:12 Uhr

6 Kommentare

Neuester Kommentar

Hi,
AD via LDAP abfragen mit Filter "(proxyAddresses=SMTP:email@adresse.de)"
Beim betreffenden Objekt das ganze Attribut "proxyAddresses" auslesen. Das ist ein Array.
Die erste Adresse im Array mit "SMTP:" in Großbuchstaben am Anfang ist die primäre SMTP-Adresse dieses Empfängers.

E.

Servus Andreas,
die PrimarySmtpAddress bekommst du in Outlook so

Sub ShowPrimarySMTPAddressForRecipient()
    Dim rec As Recipient, usr as ExchangeUser
    Set rec = Application.GetNamespace("MAPI").CreateRecipient("Max Mustermann")  
    rec.Resolve
    If rec.Resolved Then
        set usr = rec.AddressEntry.GetExchangeUser()
        if not usr is Nothing then
            msgbox usr.PrimarySmtpAddress
        End if
    Else
        MsgBox "Kontakt konnte nicht gefunden werden", vbExclamation  
    End If
End Sub

oder eben direkt

Set objUser = GetObject("LDAP://cn=Max Muster,cn=Users,dc=mydomain,dc=mytld")  
msgbox "E-MailAddress: " & objUser.EMailAddress  

oder Ausführlich über LDAP (s. Emeriks)

set objUser = FindAccount("user@domain.tld")  
if not objUser is nothing then
	msgbox objUser.EMailAddress
else
	msgbox "User nicht gefunden.",vbExclamation  
End if

Function FindAccount(strMail)
	On Error Resume Next
	Dim adoCommand, adoConnection
	Dim varBaseDN, varFilter
	Dim objRootDSE, varDNSDomain, strQuery, adoRecordset

	Set adoCommand = CreateObject("ADODB.Command")  
	Set adoConnection = CreateObject("ADODB.Connection")  
	adoConnection.Provider = "ADsDSOObject"  
	adoConnection.Open "Active Directory Provider"  
	Set adoCommand.ActiveConnection = adoConnection
	
	' Search entire Active Directory domain.  
	Set objRootDSE = GetObject("LDAP://RootDSE")  
	
	varDNSDomain = objRootDSE.Get("defaultNamingContext")  
	varBaseDN = "<LDAP://" & varDNSDomain & ">"  
	
	' Filter for user objects.  
	varFilter = "(&(objectClass=user)(proxyAddresses=smtp:" & strMail & "))"  
	
	' Construct the LDAP syntax query.  
	adoCommand.CommandText = varBaseDN & ";" & varFilter & ";ADSPath;Subtree"  
	adoCommand.Properties("Page Size") = 2  
	adoCommand.Properties("Timeout") = 20  
	adoCommand.Properties("Cache Results") = False  
	Set adoRecordset = adoCommand.Execute
	adoRecordset.MoveFirst

	If adoRecordset.RecordCount > 0 Then
		set FindAccount = GetObject(adoRecordset("ADSPath"))  
	else
		set FindAccount = Nothing
	End If
	
	adoRecordset.Close
	adoConnection.Close
End Function

Grüße Uwe

Cool! Danke! Damit bekomme ich auf jeden Fall die User abgefangen!
Was damit leider nicht geht, ist das Auslesen der Namen öffentlicher Ordner basierend auf einer vorliegenden E-Mail-Adresse...

Dann nimm als Filter einfach

varFilter = "(proxyAddresses=smtp:" & strMail & ")"

Zitat von @ahstax:

Cool! Danke! Damit bekomme ich auf jeden Fall die User abgefangen!
Was damit leider nicht geht, ist das Auslesen der Namen öffentlicher Ordner basierend auf einer vorliegenden E-Mail-Adresse...

Doch das kannst du auch via LDAP abfragen wenn du die Mail des öffentlichen Ordners hast, denn die Infos liegen ebenfalls im AD im Container CN=Microsoft Exchange System Objects.
Also die Method minimal angepasst das der BaseDN auf den System-Container zeigt und der Filter nur Public Folder mit der passenden Adresse filtert

set objFolder = FindAccount("publicfolder@domain.tld")  
if not objFolder is nothing then
	msgbox "Ordnername des mailaktivierten öffentlichen Ordners: " & objFolder.DisplayName  
else
	msgbox "Öffentlicher Ordner nicht gefunden.",vbExclamation  
End if


Function FindAccount(strMail)
	On Error Resume Next
	Dim adoCommand, adoConnection
	Dim varBaseDN, varFilter
	Dim objRootDSE, varDNSDomain, strQuery, adoRecordset

	Set adoCommand = CreateObject("ADODB.Command")  
	Set adoConnection = CreateObject("ADODB.Connection")  
	adoConnection.Provider = "ADsDSOObject"  
	adoConnection.Open "Active Directory Provider"  
	Set adoCommand.ActiveConnection = adoConnection
	
	' Search entire Active Directory domain.  
	Set objRootDSE = GetObject("LDAP://RootDSE")  
	
	varDNSDomain = objRootDSE.Get("defaultNamingContext")  
	varBaseDN = "<LDAP://CN=Microsoft Exchange System Objects," & varDNSDomain & ">"  
	
	' Filter for user objects.  
	varFilter = "(&(objectClass=publicFolder)(proxyAddresses=smtp:" & strMail & "))"  
	
	' Construct the LDAP syntax query.  
	adoCommand.CommandText = varBaseDN & ";" & varFilter & ";ADSPath;OneLevel"  
	adoCommand.Properties("Page Size") = 2  
	adoCommand.Properties("Timeout") = 20  
	adoCommand.Properties("Cache Results") = False  
	Set adoRecordset = adoCommand.Execute
	adoRecordset.MoveFirst

	If adoRecordset.RecordCount > 0 Then
		set FindAccount = GetObject(adoRecordset("ADSPath"))  
	else
		set FindAccount = Nothing
	End If
	
	adoRecordset.Close
	adoConnection.Close
End Function