[Weman]

Вот код. В некоторых местах подтер используемые телефоны, адреса, имена доменов в целях анонимности.

Код:

On Error Resume Next

'Функция очистки телефонного номера от всех символов кроме цифр
    Function cleanPhoneNumber(ByVal num)

        Dim stringLen, newNum
        stringLen = Len(num) 

        If Not IsNull(num) Then
              For i = 1 to stringLen
                character = Mid(num, i, 1)
                If IsNumeric(character) Then
                      newNum = newNum & character
                End If
              Next
        Else
              newNum = null
        End If
        cleanPhoneNumber = newNum
      End Function
   
'Функция приведения номера к нужному формату
    Function formatPhoneNumber(ByVal num)

        Dim stringLen
        Dim firstNum
        Dim newNum
     
        If IsNull(num) Then num = ""
        num = CStr(num)
     
        stringLen = Len(num)
        firstNum = Left(num, 1)

        If IsNumeric(num) Then
            If stringLen = 11 AND (firstNum = "8" OR firstNum = "7") Then
                newNum = "+7 (" & Mid(num,2,3) & ") " & Mid(num,5,3) & "-" & Mid(num,8,2) & "-" & Mid(num,10,2)
            ElseIf stringLen = 11 AND firstNum = "3" Then
                newNum = "+7 (812) " & Mid(num,1,3) & "-" & Mid(num,4,2) & "-" & Mid(num,6,2) & " доб. " & Mid(num,8,4)
              ElseIf stringLen = 15 AND (firstNum = "8" OR firstNum = "7") Then
                newNum = "+7 (" & Mid(num,2,3) & ") " & Mid(num,5,3) & "-" & Mid(num,8,2) & "-" & Mid(num,10,2) & " доб. " & Mid(num,12,4)
            ElseIf stringLen = 7 Then
                newNum = "+7 (812) " & Mid(num,1,3) & "-" & Mid(num,3,2) & "-" & Mid(num,5,2)
              Else
                newNum = ""
              End If
        End If
     
        formatPhoneNumber = newNum
    End Function


Set objSysInfo = CreateObject("ADSystemInfo")
strUser = objSysInfo.UserName
Set objUser = GetObject("LDAP://" & strUser)
strRegard = "С Уважением,"

'Получаем полное имя
strName = objUser.FullName
'Должность
strTitle = objUser.Title
'Подразделение
'strDepartment = objUser.Department
'Компания
'strCompany = objUser.Company
'Адрес
strAddress = "СПб"
'Номер телефона
strPhone = objUser.telephoneNumber
'Сотовый
strMobile = objUser.mobile
'адрес электронной почты
strEmail = LCase(objuser.mail)
'WEB страница
'strWeb = objuser.wWWHomePage
strWeb = "http://.ru/"
'Логотипы
strLogo = "\scripts\_LogonScripts\Signature\logo_land.png"
'strFacebook = "\scripts\Signature\facebook.png"
'strVk = "\scripts\Signature\vk.png"
'strTwitter = "\scripts\Signature\twitter.png"

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.Font.Name = "Tahoma"
'Размер
objSelection.Font.Size = "10"
'Цвет
objSelection.Font.Color = RGB(89, 89, 89)
'Формат
'objSelection.ParagraphFormat.Space = 1
objSelection.ParagraphFormat.SpaceBefore = 1
objSelection.ParagraphFormat.SpaceBeforeAuto = False
objSelection.ParagraphFormat.SpaceAfter = 1
objSelection.ParagraphFormat.SpaceAfterAuto = False
'Разделительная черта
objSelection.TypeText "---"
objSelection.TypeText CHR(11)
'С уважением
objSelection.TypeText strRegard
objSelection.TypeText CHR(11)
'Вставляем полное имя
objSelection.TypeText strName
objSelection.TypeText CHR(11)
'Должность
objSelection.TypeText strTitle
objSelection.TypeText CHR(11)
'Компанию
'objSelection.TypeText strCompany
objSelection.TypeText "сети супермаркетов " & Chr(34) & "" & Chr(34)
objSelection.TypeText CHR(11)
'Адрес
objSelection.TypeText strAddress
objSelection.TypeText CHR(11)
'Телефон
If (strPhone <> "") then
strPhoneClean = cleanPhoneNumber(strPhone)
strPhoneFormated = formatPhoneNumber(strPhoneClean)
objSelection.TypeText "Тел.: " & strPhoneFormated
else objSelection.TypeText "Тел. +7 (812) "
End If
objSelection.TypeText CHR(11)
'Сотовый если есть
if (strMobile <> "") Then
strMobileClean = cleanPhoneNumber(strMobile)
strMobileFormated = formatPhoneNumber(strMobileClean)
objSelection.TypeText "Моб.: " & strMobileFormated
objSelection.TypeText CHR(11)
end if

'Вставляем адрес почты
objSelection.TypeText "e-mail: "
'Форматируем стили ссылок для адреса электронной почты и сайта
Set hyp = objSelection.Hyperlinks.Add(objSelection.range, "mailto:" & strEmail, , , strEmail)
hyp.Range.Font.Color = RGB(0,0,255)
hyp.Range.Font.Name = "Tahoma"
hyp.Range.Font.Size = "10"
objSelection.TypeText CHR(11)

'корпоративный сайт
objSelection.TypeText "web: "
Set hyp = objSelection.Hyperlinks.Add(objSelection.Range, strWeb, "", "", strWeb)
hyp.Range.Font.Color = RGB(192,0,0)
hyp.Range.Font.Name = "Tahoma"
hyp.Range.Font.Size = "10"
objSelection.ParagraphFormat.SpaceAfter=5

'Вставляем логотип компании

objSelection.TypeParagraph()
Set objLink = objSelection.Hyperlinks.Add(objSelection.InlineShapes.AddPicture(strLogo), strWeb,,,"")
objSelection.ParagraphFormat.SpaceAfter=1

'objSelection.TypeParagraph()

'Set objLink = objSelection.Hyperlinks.Add(objSelection.InlineShapes.AddPicture(strFacebook), "https://www.facebook.com/",,,"")
'Set objLink = objSelection.Hyperlinks.Add(objSelection.InlineShapes.AddPicture(strVK), "http://vk.com/",,,"2")
'Set objLink = objSelection.Hyperlinks.Add(objSelection.InlineShapes.AddPicture(strTwitter), "https://twitter.com/",,,"3")


Set objSelection = objDoc.Range()

objSignatureEntries.Add "Company Signature New", objSelection
objSignatureObject.NewMessageSignature = "Company Signature New"
'objSignatureObject.ReplyMessageSignature = "Company Signature"

objDoc.Saved = True
objDoc.Close
objWord.Quit