title image


Smiley Re: Dateiinfo für Worddokumente
Wenn ihr in der Firma an einem Windows2000/2003 Server mit ActiveDirectory angebunden seid, könnte auch folgende Lösung bestimmt interessant sein







' nachfolgenden Code in die Normal.dot in ein gesondertes Modul schreiben - der Code



Dim oRootDSE

Dim oConnection

Dim adoRecordset



Sub FileNew()



' Fängt den Aufruf Datei|Neu ab und hängt den Aufruf zum Makro Dokumenteigenschaften an

' das mit OK bestätigte Schließen des DateiNeu-Dialoges direkt an und steht somit für

' alle über diesen Dialog erzeugten Vorlagen zur Verfügung (außer der Standarddokumentvorlage normal.dot)



    On Error Resume Next

    

    Dim Dlg

    

    Set Dlg = Dialogs(wdDialogFileNew)

    If Dlg.Show = 0 Then Exit Sub

    

    If LCase(ActiveDocument.AttachedTemplate) <> "normal.dot" Then _

        Call Dokumenteigenschaften

    

End Sub



Sub Dokumenteigenschaften()



    Dim strAutor

    Dim strFirma

    Dim strUserADsPath

    

    Dim blnADConnect

    

    If MsgBox("Dokumenteigenschaften schreiben", 32 + 4 + 0, "1Frage:") <> 6 Then Exit Sub

        

    strUserADsPath = ADUserPath(LogedOnUser)

    

    If Len(strUserADsPath) > 0 Then

   

        StatusBar = "Benutzerdaten wurden im ActiveDirectory gefunden"

    

        Set objUser = GetObject(adoRecordset.Fields("adspath"))

        

        strAutor = objUser.FullName

        strFirma = objUser.department & vbCrLf & _

                   objUser.street & vbCrLf & _

                   Trim(postalCode & " " & objUser.l) & vbCrLf & _

                   objUser.c



        ActiveDocument.BuiltInDocumentProperties(wdPropertyAuthor).Value = strAutor

        ActiveDocument.BuiltInDocumentProperties(wdPropertyCompany).Value = strFirma

        

        Set objUser = Nothing

    

    End If

   

    Set oRootDSE = Nothing

    Set oConnection = Nothing

    Set adoRecordset = Nothing

   

End Sub



Private Function ADUserPath(strUserName)



    On Error Resume Next

    

    StatusBar = "Verbindung zum ActiveDirectory wird hergestellt"

    

    Set oRootDSE = GetObject("LDAP://RootDSE")

    strDNSDomain = oRootDSE.Get("defaultNamingContext")

    

    If IsEmpty(strDNSDomain) Then

        StatusBar = "keine Domäne gefunden - Daten können nicht ermittelt werden"

        Exit Function

    End If

    

    'Verbindung öffnen

    Set oConnection = CreateObject("ADODB.Connection")

    oConnection.Provider = "ADsDSOObject"

    oConnection.Open "ADs Provider"

    

    Set adoRecordset = oConnection.Execute("<LDAP://" & varDomainNC & ">;(&(objectClass=User)(cn=" & strUserName & "));adspath;subtree")

    ADUserPath = adoRecordset.Fields("adspath")

    

    On Error GoTo 0



End Function



Sub Test()



    MsgBox LogedOnUser

    

End Sub

Private Function LogedOnUser()



    Set WshNetwork = CreateObject("Wscript.Network")

    strResult = WshNetwork.UserName

    Set WshNetwork = Nothing

    LogedOnUser = strResult

    

End Function





Code eingefügt mit Syntaxhighlighter 2.5




 
Gruß Martin




eMail und OfficeLine




geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: