'Подпись для писем, берет параметры из AD
On Error Resume Next

Set objSysInfo = CreateObject("ADSystemInfo")

strUser = objSysInfo.UserName
Set objUser = GetObject("LDAP://" & strUser)

strZpov = "С уважением,"
strDev =

"---------------------------------------------------------------------------------------------------------------------------------------------------------

-------------------------------------------------------------------------------------------------------------------------------------------"
strPostIndex = ObjUser.postalCode
strName = objUser.FullName
strTitle = objUser.Title
strDepartment = objUser.Department
strCompany = objUser.Company
strPhone = objUser.telephoneNumber
strweb = objuser.wWWHomePage
strgorod = objuser.l
strstreet = objuser.streetAddress
strfax = objuser.facsimileTelephoneNumber
strICQ = objUser.pager
strIntPhone = objuser.ipPhone
strMobile = objUser.mobile
strEmail = objuser.mail
strLogo = "\\server\logo.jpg"

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.ParagraphFormat.Space1
objSelection.Font.Size = "11"
objSelection.Font.Name = "Calibri"
objselection.font.color = RGB(0, 90, 139)
objSelection.TypeText strZpov & CHR(11)
objSelection.TypeText strName & CHR(11)
objSelection.Font.Size = "2"
objSelection.TypeText strDev & CHR(11)
objSelection.Font.Size = "11"
objSelection.TypeText strTitle & CHR(11)
if (strDepartment<>"") then objSelection.TypeText strDepartment & CHR(11)
objSelection.TypeText strCompany & CHR(11)
if (strPhone<>"") then objSelection.TypeText "Тел.: XXX-XXX вн." & strPhone & CHR(11)
if (strIntPhone<>"") then objSelection.TypeText "Тел.: " & strIntPhone & CHR(11)
if (strstrIntPhone<>"") then objSelection.TypeText "" & strIntPhone & CHR(11)
if (strfax<>"") then objSelection.TypeText "Факс: " & strfax & CHR(11)
if (strMobile<>"") then objSelection.TypeText "Моб.: " & strMobile & CHR(11)
objSelection.TypeText strPostIndex & ", г. " & strgorod & ", ул. " & strstreet & CHR(11)
if (strICQ<>"") then objSelection.TypeText "ICQ: " & strICQ & CHR(11)
Set hyp = objSelection.Hyperlinks.Add(objSelection.Range, strWeb, "", "", strWeb)
hyp.Range.Font.Size = "11"
hyp.Range.Font.Name = "Calibri"
hyp.Range.Font.color = RGB(0, 90, 139)
objSelection.TypeText CHR(11)
objSelection.TypeText CHR(11)
objSelection.InlineShapes.AddPicture(strLogo)

Set objSelection = objDoc.Range()
objSignatureEntries.Add "AD Signature", objSelection
objSignatureObject.NewMessageSignature = "AD Signature"
objSignatureObject.ReplyMessageSignature = "AD Signature"

objDoc.Saved = True
objDoc.Close
objWord.Quit