Word Vorlage - Daten aus Active Directory ziehen

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