Новый участник
Сообщения: 46
Благодарности: 1
|
Профиль
|
Отправить PM
| Цитировать
Вот код. В некоторых местах подтер используемые телефоны, адреса, имена доменов в целях анонимности.
Код:  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
|
