owner123
Goto Top

Word Vorlage - Daten aus Active Directory ziehen

Hallo,

meine Frage: Wie kann man per VBA in einem Worddokument die AD Daten auslesen. Es soll somit eine Vorlage für User geschaffen werden.
Es gab schon einige Threads, aber bisher nie eine funktionierende Lösung.

Wir arbeiten mit Office03 und Windows Server 2003. Betriebssysteme sind 2000 und hauptsächlich XP.

Alter, nicht funktionierender Code:
'######################################################   
'active directory auslesen   
' AnbindungDomain   
If Templates(I).CustomDocumentProperties("AnbindungDomain") = True Then   

Dim objSystemInfo As Object 
Dim objUser As Object 

Set objSystemInfo = CreateObject("ADSystemInfo")   
Set objUser = GetObject("LDAP://" & objSystemInfo.UserName)   

'Anmeldename = samAccountName   
If ActiveDocument.Bookmarks.Exists("AbsenderuserPrincipalName") = True Then   
Selection.GoTo what:=wdGoToBookmark, Name:="AbsenderuserPrincipalName"   
Selection.TypeText objUser.samAccountName 
End If 

'Vorname   
If ActiveDocument.Bookmarks.Exists("AbsendergivenName") = True Then   
Selection.GoTo what:=wdGoToBookmark, Name:="AbsendergivenName"   
Selection.TypeText objUser.FirstName 
End If 

'Nachname   
If ActiveDocument.Bookmarks.Exists("Absendersn") = True Then   
Selection.GoTo what:=wdGoToBookmark, Name:="Absendersn"   
Selection.TypeText objUser.sn 
End If 

'Telefon = telephoneNumber   
If ActiveDocument.Bookmarks.Exists("AbsendertelephoneNumber") = True Then   
Selection.GoTo what:=wdGoToBookmark, Name:="AbsendertelephoneNumber"   
Selection.TypeText objUser.telephoneNumber 
End If 

'BüroFax = facsimileTelephoneNumber   
If ActiveDocument.Bookmarks.Exists("AbsenderfacsimileTelephoneNumber") = True Then   
Selection.GoTo what:=wdGoToBookmark, Name:="AbsenderfacsimileTelephoneNumber"   
Selection.TypeText objUser.facsimileTelephoneNumber 
End If 

'Mail   
If ActiveDocument.Bookmarks.Exists("Absendermail") = True Then   
Selection.GoTo what:=wdGoToBookmark, Name:="Absendermail"   
Selection.TypeText objUser.EmailAddress 
End If 

'Title = Absendertitle   
If ActiveDocument.Bookmarks.Exists("Absendertitle") = True Then   
Selection.GoTo what:=wdGoToBookmark, Name:="Absendertitle"   
Selection.TypeText objUser.Title 
End If 

'Abteilung = Absenderdepartment   
If ActiveDocument.Bookmarks.Exists("Absenderdepartment") = True Then   
Selection.GoTo what:=wdGoToBookmark, Name:="Absenderdepartment"   
Selection.TypeText objUser.Department 
End If 

'Standort = physicalDeliveryOfficeName   
If ActiveDocument.Bookmarks.Exists("AbsenderphysicalDeliveryOfficeName") = True Then   
Selection.GoTo what:=wdGoToBookmark, Name:="AbsenderphysicalDeliveryOfficeName"   
Selection.TypeText objUser.physicalDeliveryOfficeName 
End If 

'Firma = company   
If ActiveDocument.Bookmarks.Exists("Absendercompany") = True Then   
Selection.GoTo what:=wdGoToBookmark, Name:="Absendercompany"   
Selection.TypeText objUser.company 
End If 

' Strasse = streetAddress   
If ActiveDocument.Bookmarks.Exists("AbsenderstreetAddress") = True Then   
Selection.GoTo what:=wdGoToBookmark, Name:="AbsenderstreetAddress"   
Selection.TypeText objUser.streetAddress 
End If 

'PLZ = postalCode   
If ActiveDocument.Bookmarks.Exists("AbsenderpostalCode") = True Then   
Selection.GoTo what:=wdGoToBookmark, Name:="AbsenderpostalCode"   
Selection.TypeText objUser.postalCode 
End If 

'Ort = l   
If ActiveDocument.Bookmarks.Exists("Absenderl") = True Then   
Selection.GoTo what:=wdGoToBookmark, Name:="Absenderl"   
Selection.TypeText objUser.l 
End If 

'Bundesland = st   
If ActiveDocument.Bookmarks.Exists("Absenderst") = True Then   
Selection.GoTo what:=wdGoToBookmark, Name:="Absenderst"   
Selection.TypeText objUser.st 
End If 

'Land = countryCode   
If ActiveDocument.Bookmarks.Exists("AbsendercountryCode") = True Then   
Selection.GoTo what:=wdGoToBookmark, Name:="AbsendercountryCode"   
Selection.TypeText objUser.countryCode 
End If 

'Mobiletelefon = mobile   
If ActiveDocument.Bookmarks.Exists("Absendermobile") = True Then   
Selection.GoTo what:=wdGoToBookmark, Name:="Absendermobile"   
Selection.TypeText objUser.mobile 
End If 

'Vorgesetzter = manager   
If ActiveDocument.Bookmarks.Exists("Absendermanager") = True Then   
Selection.GoTo what:=wdGoToBookmark, Name:="Absendermanager"   
Selection.TypeText objUser.Manager 
End If 

'Webadresse = wwwHomePage   
If ActiveDocument.Bookmarks.Exists("AbsenderwwwHomePage") = True Then   
Selection.GoTo what:=wdGoToBookmark, Name:="AbsenderwwwHomePage"   
Selection.TypeText objUser.wwwHomePage 
End If 

Set objUser = Nothing 
Set objSystemInfo = Nothing 
Else 

'Application.UserInitials   
'Application.UserName   
End If 
Sub testen()
'' testen Makro  
' Makro erstellt am 27.07.2005 von testen  
'  
Dim objADInfo As Object
Dim objLogonName As Object
Dim objPhone As Object
Dim objMail As Object
Dim strMail As String
Dim strTelephoneNumer As String
Dim strUserName As String
Dim strUserInitials As String

Set objADInfo = CreateObject("ADSystemInfo")  
Set objLogonName = GetObject("LDAP://" & objADInfo.UserName)  

strUserName = objLogonName.firstname & " " & objLogonName.lastname  
strTelephoneNumber = objtelephoneNumber
strMail = objMail

Application.UserName = strUserName
Application.UserInitials = strTelephoneNumber
Application.UserAddress = strMail

End Sub
Set objSystemInfo = CreateObject("ADSystemInfo")   
Set objUser = GetObject("LDAP://" & objSystemInfo.UserName)   
ActiveDocument.BookMarks("txtName").Range.Text = objUser.LastName   
ActiveDocument.BookMarks("txtVorname").Range.Text = objUser.FirstName   
ActiveDocument.BookMarks("txtTelefon").Range.Text = objUser.TelephoneNumber   
ActiveDocument.BookMarks("txtMail").Range.Text = objUser.EmailAddress   
ActiveDocument.BookMarks("txtAbteilung").Range.Text = objUser.Department  

Ich hoffe jemand weiss Rat bzw. kann es mal an seinem System testen.
Gruß
Update:
30.05.2007 00:19 Uhr
Ich habe den Quellcode in die Codeblöcke gepackt. Macht das Ganz einfach übersichtlicher...

@Dani
(Moderator)

Content-Key: 60129

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

Ausgedruckt am: 28.03.2024 um 13:03 Uhr

Mitglied: quaestor
quaestor 19.02.2008 um 19:06:46 Uhr
Goto Top
Gibt es hierzu eine Lösung?
Wir haben das gleich Problem bei uns.
Ein Hinweis auf ne Quelle würde mir schon genügen.
Danke
Mitglied: napperman
napperman 15.08.2008 um 08:55:12 Uhr
Goto Top
Ich hab irgendwo im Netz einen anderen Code gefunden. Den habe ich ein wenig umgebaut und als Makro
eingebunden. Das ganze habe ich Pfadabhängig gemacht, da ich nicht möchte, das die Vorlage überschrieben wird.
Außerdem ist das ein Makro dass beim öffnen automatisch läuft. Dies soll es aber nur an dieser Stelle. Hat der User seine Vorlage, soll er sie auf seinem Desktop oder sonstwo speichern:

Sub AutoOpen()

On Error Resume Next
Dim qQuery, objSysInfo, objuser
Dim firma, Name, EMail, Phone, Fax, web, position, Abteilung
If ThisDocument.Name = "Briefvorlage.doc" And _
ThisDocument.Path = "T:\Briefvorlage" _
Then
' Active Directory Informationen für den angemeldeten User lesen
Set objSysInfo = CreateObject("ADSystemInfo")
objSysInfo.RefreshSchemaCache
qQuery = "LDAP://" & objSysInfo.UserName
Set objuser = GetObject(qQuery)

'Variablen mit AD-Attributen füllen (es gibt da natürlich mehr Attribute FaxNumber usw.)
firma = objuser.company
Abteilung = objuser.physicalDeliveryOfficeName
Name = objuser.firstname & " " & objuser.lastname
Phone = objuser.TelephoneNumber
Fax = objuser.facsimileTelephoneNumber
EMail = objuser.mail
web = objuser.wwwHomePage
position = objuser.Title

smsEinfügen "smsAbteilung", Abteilung
smsEinfügen "smsTel", "tel: " & Phone
smsEinfügen "smsName", Name
smsEinfügen "smsweb", web
smsEinfügen "smsUnterschrift", Name
smsEinfügen "smsUnterschriftAbteilung", Abteilung
smsEinfügen "smsEmail", EMail
End If
End Sub


Public Sub smsEinfügen(Textmarke, Variable)
' Prozedur zum Einfügen des Wertes ("Variable") an der entsprechenden Textmarke
If ActiveDocument.Bookmarks.Exists(Textmarke) = True Then
Selection.GoTo What:=wdGoToBookmark, Name:=Textmarke
Selection.TypeText Variable
End If
End Sub
Mitglied: SteKoLos
SteKoLos 20.03.2013 um 21:16:04 Uhr
Goto Top
Hallo zusammen,

wir haben eine eingenständiges Addin unter http://www.ldap2doc.de erstellt.
Das Add-In Verbindet ganz einfach die Datenfelder aus dem Active Directoy mit Ihren Word Vorlagen.

Hier finden Sie auch unsere kostenlose Testversion!

Viele Grüße
SteKoLos