' #Subfunction# '=============================================================================== ' ' Name...........: AD_Data_and_Replace_Text() ' Description ...: Ruft die Daten des aktuellen Benutzers aus dem Active Directory ab und ' setzt diese in das Dokument ein. Dies geschieht über Suchen & Ersetzen, ' xLNx im Text des Dokumentes wird z.B. durch dem in AD hinterlegten ' Nachnamen ersetzt - egal wie oft im Dokument das Schlüsselwort vorkommt. ' Formatierungen bleiben dabei erhalten, das Schlüsselwort wird auch in ' der Kopf- und Fußzeile gefunden und ersetzt. ' Syntax.........: AD_Data_and_Replace_Text() ' Parameters ....: keine ' Return values .: keine ' Author ........: Bernhard Linz / Bernhard.Linz@datagroup.de / admin@znil.net ' Modified.......: ' Remarks .......: ' Related .......: ' Link ..........: http://znil.net (Bereich Office / Word) ' Sub AD_Data_and_Replace_Text() '=============================================================================== 'In den nachfolgenden Variablen werden die Informationen aus dem Active Directory über den aktuellen Benutzer gespeichert. 'In der strReplacementText wird der dazu passende Suchtext gespeichert. Das wir dafür 2 Arrays nehmen hat den Grund 'das wir so für das Suchen & Ersetzen mit Schleifen arbeiten können - sonst wäre der Quelltext sehr lang geworden wobei 'immer wieder das selbe wiederholt worden wäre. 'Um das ganze zu Erweitern müssen also unten in den Variablenzuweisungen einfach die weiteren Felder fortlaufend hinzugefügt 'werden - und hier oben die Gesamtanzahl angepasst werden. Da wir bei 0 anfangen zu zählen sind also 0 bis 25 = 26 insgesammt. 'Also immer einen mehr als der letzte Eintrag Const AnzahlElemente As Integer = 26 Dim strObject(AnzahlElemente) As String Dim strReplacementText(AnzahlElemente) As String '=============================================================================== ' Allgemeine Variablen Dim Zaehler As Integer Dim oStory As Range '=============================================================================== 'Variablen für Active Directory-Abfrage Dim varQuery As String Dim objSystemInfo As Object Dim objBenutzer As Object '=============================================================================== ' Active Directory Informationen des angemeldeten Benutzers lesen Set objSystemInfo = CreateObject("ADSystemInfo") varQuery = "LDAP://" & objSystemInfo.UserName ' mit Nachfolgender Zeile haben wir einen Zeiger auf das AD-Objekt des Benutzer's damit können wir alle AD-Felder abfragen Set objBenutzer = GetObject(varQuery) '=============================================================================== 'Setzen der Suchtexte '=============================================================================== '0. First Name strObject(0) = objBenutzer.givenName strReplacementText(0) = "xFNx" '1. Last Name strObject(1) = objBenutzer.sn strReplacementText(1) = "xLNx" '2. Initialien strObject(2) = objBenutzer.initials strReplacementText(2) = "xINx" '3. User Logon Name strObject(3) = objBenutzer.sAMAccountName strReplacementText(3) = "xLogonNamex" '4. Display Name strObject(4) = objBenutzer.DisplayName strReplacementText(4) = "xDisplayNamex" '5. Description strObject(5) = objBenutzer.Description strReplacementText(5) = "xDescriptionx" '6. Job Title strObject(6) = objBenutzer.Title strReplacementText(6) = "xJobTitlex" '7. Department strObject(7) = objBenutzer.department strReplacementText(7) = "xDepartmentx" '8. Company strObject(8) = objBenutzer.company strReplacementText(8) = "xCompanyx" '9. Office strObject(9) = objBenutzer.PhysicalDeliveryOfficeName strReplacementText(9) = "xOfficex" '10. Telephone Number strObject(10) = objBenutzer.telephoneNumber strReplacementText(10) = "xTelOfficex" '11. Home Number strObject(11) = objBenutzer.homePhone strReplacementText(11) = "xTelHomex" '12. Mobile Number strObject(12) = objBenutzer.mobile strReplacementText(12) = "xTelMobilex" '13. Fax Number strObject(13) = objBenutzer.facsimileTelephoneNumber strReplacementText(13) = "xTelFAXx" '14. Pager Number strObject(14) = objBenutzer.pager strReplacementText(14) = "xTelPagerx" '15. Email strObject(15) = objBenutzer.mail strReplacementText(15) = "xEMAILx" '16. Web-Page strObject(16) = objBenutzer.wWWHomepage strReplacementText(16) = "xWWWx" '17. Street strObject(17) = objBenutzer.streetAddress strReplacementText(17) = "xSTREETx" '18. P.O. Box strObject(18) = objBenutzer.postOfficeBox strReplacementText(18) = "xPOx" '19. Zip strObject(19) = objBenutzer.postalCode strReplacementText(19) = "xZIPx" '20. City strObject(20) = objBenutzer.l strReplacementText(20) = "xCITYx" '21. State strObject(21) = objBenutzer.st strReplacementText(21) = "xSTATEx" '22. Country strObject(22) = objBenutzer.CO strReplacementText(22) = "xCOUNTRYx" '23. IP-Telephone strObject(23) = objBenutzer.ipPhone strReplacementText(23) = "xTelIPx" '24. Notes strObject(24) = objBenutzer.info strReplacementText(24) = "xNOTESx" '25. EmployeeID strObject(25) = objBenutzer.employeeID strReplacementText(25) = "xEmployeeIDx" '=============================================================================== 'Suchen und Ersetzen! '=============================================================================== Application.ScreenUpdating = False For Zaehler = 0 To (AnzahlElemente - 1) Step 1 'Einmal für jedes Schlüsselwort .... For Each oStory In ActiveDocument.StoryRanges 'und noch einmal für jeden Dokumentenbereich 'Sonst geht es nicht mit Kopf- und Fußzeile oStory.Find.ClearFormatting oStory.Find.Replacement.ClearFormatting With oStory.Find .Text = strReplacementText(Zaehler) .Replacement.Text = strObject(Zaehler) .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = True .MatchWholeWord = True .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With oStory.Find.Execute Replace:=wdReplaceAll 'Hauptbereich ist abgefrühstückt - nun die restlichen Bereiche While Not (oStory.NextStoryRange Is Nothing) Set oStory = oStory.NextStoryRange oStory.Find.ClearFormatting oStory.Find.Replacement.ClearFormatting With oStory.Find .Text = strReplacementText(Zaehler) .Replacement.Text = strObject(Zaehler) .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = True .MatchWholeWord = True .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With oStory.Find.Execute Replace:=wdReplaceAll Wend Next Next Zaehler Application.ScreenUpdating = True End Sub