On Error Resume Next
Set objSysInfo = CreateObject("ADSystemInfo")
strUser = objSysInfo.UserName
Set objUser = GetObject("LDAP://" & strUser)
strName = objUser.FullName
strSN = objUser.sn
strmobile = objUser.mobile
strTitle = objUser.Title
strDepartment = objUser.Department
strCompany = objUser.Company
strPhone = objUser.telephoneNumber
strGivenName = objUser.givenname
strMail = objUser.mail
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add()
Set objSelection = objWord.Selection
Set objEmailOptions = objWord.EmailOptions
Set objSignatureObject = objEmailOptions.EmailSignature
Set objSignatureEntries = objSignatureObject.EmailSignatureEntries
objSelection.TypeText "Kind Regards,"
objSelection.TypeParagraph()
objSelection.TypeParagraph()
objSelection.TypeText strGivenName & " " & strSN
objSelection.TypeParagraph()
objSelection.TypeText strTitle
objSelection.TypeParagraph()
objSelection.TypeParagraph()
'objSelection.TypeText strDepartment
'objSelection.TypeParagraph()
objSelection.TypeText strCompany
objSelection.TypeParagraph()
objSelection.TypeText "P: " & strPhone
objSelection.TypeParagraph()
objSelection.TypeText "M: " & strmobile
objSelection.TypeParagraph()
objSelection.TypeText strmail
Set objSelection = objDoc.Range()
[color:#CC0000]objSignatureEntries.Add "AD Signature", objSelection[/color]
objSignatureObject.NewMessageSignature = "AD Signature"
objSignatureObject.ReplyMessageSignature = "AD Signature"
objDoc.Saved = True
objWord.Quit