Vbs - Attribute des Eingeloggten Users aus AD auslesen, laut vorlage in Outlook Sig übernehmen

 Const ForReading = 1, ForWriting = 2 

option explicit

'Laden der zu benötigten Variablen  
dim WshShell
dim strSig, objDomain, strActiveUser, objObject, objUser, OU, strFileName, strUserName
dim strFiles(), strItem, strClnReplacement, strFile, strSigName
dim objFSO, objFile, objWord, objEmailOptions, objSignatureObject
redim strFiles(2)

'Laden des Eingeloggten Users  
set WshShell = WScript.CreateObject("WScript.Shell")  
strUserName = WshShell.ExpandEnvironmentStrings("%USERNAME%")  
'Echo wurde zu Testzwecken deklariert und kann auskommentiert werden  
WScript.Echo strUserName

'Definition der Vorlagendateien  
strFiles(0) = "C:\Users\ViktorHim\Desktop\Sig\Signature_test.htm"  
strFiles(1) = "C:\Users\ViktorHim\Desktop\Sig\Signature_test.rtf"  
strFiles(2) = "C:\Users\ViktorHim\Desktop\Sig\Signature_test.txt"  


'Platzhalter in allen Dateien gegen personalisierte Werte austauschen  
for each strFile in strFiles
	Const ForReading = 1
    set objFSO = CreateObject("Scripting.FileSystemObject")  
    set objFile = objFSO.OpenTextFile(strFile, 1)

    'Einlesen des Dateiinhaltes in die Variable strSig  
    strSig = objFile.ReadAll
    objFile.Close
	
    for each strItem in ReturnArrayOfPlaceholders(strFile)
        '"Reinigung" des Placeholders (entfernen von den Steuerzeichen @_ und _@) um den AD-Feldnamen  
        'in Reinform zu gewinnnen.  
        'Bsp.: aus @_givenName_@ wird givenName  
        strClnReplacement=Replace(strItem,"@_","")  
        strClnReplacement=Replace(strClnReplacement,"_@","")  
        if len(strClnReplacement) > 0 then
          'Ersetzen des Placeholders durch die personalisierten AD Daten  
          'Bsp.: @_givenName_@ wird zu Mustermann  
          strSig = Replace(strSig, strItem, GetADData(strClnReplacement, strUserName))
        end if
    Next
	
    
	'Den Namen der Signatur merken  
    strSigName = objFSO.GetBaseName(strFile)
	
    'Wegschreiben der personalisierten Signatur in eine Datei  
    set objFSO = CreateObject("Scripting.FileSystemObject")  
    strFileName = WshSysEnv & "MicrosoftSignatures" & strFile  
	strFileName = "C:\Users\%USERNAME%\AppData\Roaming\Microsoft\Signatures" & strUserName.Username & "\Anwendungsdaten\Microsoft\Signatures\" & strFile  
    set objFile = objFSO.CreateTextFile(strFileName, true)
    objFile.Write strSig    
    objFile.Close
next


'neue Signatur in Outlook aktivieren  
Set objWord = CreateObject("Word.Application")  
Set objEmailOptions = objWord.EmailOptions
Set objSignatureObject = objEmailOptions.EmailSignature
objSignatureObject.NewMessageSignature = strSigName
objSignatureObject.ReplyMessageSignature = strSigName
objWord.Quit


'------------------------Funktionen---------------------------------  


'Diese Funktion gibt alle Placeholder einer übergebenen Datei in einem Array zurück  

Function ReturnArrayOfPlaceholders(strFile)
    Dim strReplacements(),i,strSigLine, intPos, intPosSpace,strItem, objFSO_Func, objFile_Func
    ReDim strReplacements(50)
    i = 0
    Set objFSO_Func = CreateObject("Scripting.FileSystemObject")  
    Set objFile_Func = objFSO.OpenTextFile(strFile)
    Do Until objFile_Func.AtEndOfStream
      strSigLine = objFile_Func.ReadLine
      intPos = 0
      intPos = InStr(strSigLine, "@_")  
      Do While intPos > 0
          intPosSpace = InStr(intPos, strSigLine, "_@")  
          strItem = Mid(strSigLine, intPos, intPosSpace - intPos + 2)
          strReplacements(i) = strItem
          intPos = InStr(intPos + 1, strSigLine, "@_")  
          i = i + 1
      Loop
    Loop
    objFile_Func.Close
    ReDim Preserve strReplacements(i)
    ReturnArrayOfPlaceholders = strReplacements
End Function


'Diese Funktion gibt für den übergebenen sAMAccountName den Inhalt des  
'übergebenen AD-Feldes (strADFieldName) zurück.  
'strADFieldname kann jedes Feld des Userobjektes im AD sein.   

Function GetADData(strADFieldName, strUserName)
    Dim objConnection, objCommand, objRecordSet
    'Wie viele Ebenen im AD gesucht werden soll  
    Const ADS_SCOPE_SUBTREE = 2
    
	'Verbindung zu AD herstellen  
	Set objConnection = CreateObject("ADODB.Connection")  
	Set objCommand = CreateObject("ADODB.Command")  
	objConnection.Open "Provider=ADsDSOObject;"  
	objCommand.ActiveConnection = objConnection
	objCommand.CommandText = "SELECT " & strADFieldName & " FROM " & _  
	"'LDAP://OU=Irrenhau,OU=da,DC=was,DC=com' " & _  
	"WHERE samAccountName = '" & strUserName & "'"  
	objCommand.Properties("SearchScope") = ADS_SCOPE_SUBTREE  
	Set objRecordSet = objCommand.Execute
	GetADData = objRecordSet.Fields(strADFieldName)
	End Function