On Error Resume Next
Set objSysInfo = CreateObject("ADSystemInfo")
strUser = objSysInfo.UserName
Set objUser = GetObject("LDAP://" & strUser)
strName = objUser.cn
strTitle = objUser.Title
strDepartment = objUser.Department
strCompany = objUser.Company
strcountry = objuser.st
'Получаем почтовый индекс
strPostIndex = ObjUser.postalCode
'Город
strgorod = objuser.l
'strCity = objuser.l
'Улица
strStreet = objuser.streetAddress
strstreetAddress = objUser.streetAddress
strhomephone = objUser.homephone
strtelephoneNumber = objUser.telephoneNumber
strfacsimileTelephoneNumber = objUser.facsimileTelephoneNumber
strmobile = objUser.mobile
strEmail = objUser.emailaddress
strwWWHomePage = objUser.wWWHomePage
strLogo = "\\C:\scripts\id.gif"
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add()
Set objSelection = objWord.Selection
objSelection.Style = "No Spacing"
Set objEmailOptions = objWord.EmailOptions
Set objSignatureObject = objEmailOptions.EmailSignature
Set objSignatureEntries = objSignatureObject.EmailSignatureEntries
objSelection.Font.Name = "Calibri"
objSelection.Font.Size = "10"
objSelection.Font.Color = RGB(95,95,95)
'Best regards
objSelection.TypeText "С уважением,"
objSelection.TypeText(Chr(11))
'Name
objSelection.TypeText strName
objSelection.TypeText(Chr(11))
objSelection.TypeText(Chr(11))
'Title
objSelection.TypeText strTitle
objSelection.TypeText(Chr(11))
'Department
objSelection.TypeText strDepartment
objSelection.TypeText(Chr(11))
'Company
objSelection.Font.Bold = True
objSelection.TypeText strCompany
objSelection.Font.Bold = False
objSelection.TypeParagraph()
'Logo
Set objInlineShape = objSelection.InlineShapes.AddPicture(strLogo)
objInlineShape.AlternativeText = strCompany
'Город
objSelection.TypeText strcountry & " " & strPostIndex & ", г. " & strgorod & CHR(11)
objSelection.TypeText strstreet & CHR(11)
'homephone
objSelection.TypeText "тел: "
objSelection.TypeText strhomephone
'telephoneNumber
objSelection.TypeText " вн. "
objSelection.TypeText strtelephoneNumber
objSelection.TypeText(Chr(11))
'mobile
objSelection.TypeText "моб: "
objSelection.TypeText strmobile
objSelection.TypeParagraph()
'Email
set hyp = objSelection.Hyperlinks.Add(objSelection.Range,"mailto:" & strEmail & " ", , , strEmail)
hyp.Range.Font.Name = "Arial"
hyp.Range.Font.Size = "10"
hyp.Range.Font.Color = RGB(0,0,255)
objSelection.TypeText(Chr(11))
'URL
set hyp = objSelection.Hyperlinks.Add(objSelection.Range,strwWWHomePage,,strwWWHomePage, strwWWHomePage)
hyp.Range.Font.Name = "Arial"
hyp.Range.Font.Size = "10"
hyp.Range.Font.Color = RGB(0,0,255)
objSelection.TypeParagraph()
Set objLink = objSelection.Hyperlinks.Add(objInlineShape, strwWWHomePage,,,"")
objSelection.ParagraphFormat.SpaceAfter=1
Set objSelection = objDoc.Range()
objSignatureEntries.Add "Стандартная подпись", objSelection
objSignatureObject.NewMessageSignature = "Стандартная подпись"
objDoc.Saved = True
objWord.Quit
' Create Short Standard Signature
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add()
Set objSelection = objWord.Selection
objSelection.Style = "No Spacing"
Set objEmailOptions = objWord.EmailOptions
Set objSignatureObject = objEmailOptions.EmailSignature
Set objSignatureEntries = objSignatureObject.EmailSignatureEntries
objSelection.Font.Name = "Calibri"
objSelection.Font.Size = "10"
objSelection.Font.Color = RGB(95,95,95)
'Best regards
objSelection.TypeText "С уважением,"
objSelection.TypeText(Chr(11))
'Name
objSelection.TypeText strName
objSelection.TypeText(Chr(11))
Set objSelection = objDoc.Range()
objSignatureEntries.Add "Короткая Стандартная подпись", objSelection
objSignatureObject.ReplyMessageSignature = "Короткая Стандартная подпись"
objDoc.Saved = True
objWord.Quit