SHARE
TWEET

Untitled

a guest Feb 3rd, 2011 4,617 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. ' Скрипт создания корпоративной подписи и наведения порядка в MS Outlook
  2. ' Работает в Outlook 2000 - 2010.
  3. ' Делает очень полезные вещи:
  4. ' - Выставляет имя отправителя почты из поля DisplayName в домене
  5. ' - Отключает HTML-просмотр писем и отправку писем в HTML.
  6. ' - Создаёт простую текстовую подпись и выставляет её для всех учеток.
  7. ' Если есть вопросы или жгучее желание дать мне денег\набить морду -
  8. ' моя электропочта artem@brodetskiy.net .
  9.  
  10. ' Конфигурационные параметры:
  11.  
  12. ' Название фирмы:
  13. prmOOO_Name =  "ООО ""Хабрафирма Интернейшнл"""
  14. ' Сайт фирмы:
  15. prmSite = "http:/www.habrahabr.ru"
  16.  
  17. ' Переменная BasePath определяет путь к файлам с данными пользователей.
  18. ' В случае, если её значение равняется ("") - данные пользователя берутся из домена
  19. ' Для доменной учетной записи используются поля DisplayName (Выводимое имя), mail (Эл. почта),
  20. ' telephoneNumber (Телефонный номер), title (Должность), mobile (Мобильный телефон);
  21. ' Для файлов используется построчное перечисление:
  22. ' 1 строка - ФИО,
  23. ' 2 строка - Должность
  24. ' 3 cтрока - e-mail
  25. ' 4 строка - служебный телефон
  26. ' 5 строка - мобильный телефон (необязательно).
  27. ' Полное имя файла должно выглядеть как BasePath\имя_компьютера\имя_пользователя.ini
  28. ' Например, \\server\UserData$\comp01\user04.ini (BasePath = "\\server\UserData$\")
  29. BasePath = ""
  30.  
  31.  
  32. 'BasePath = "\\habraserver\HabraSignatures$\"    
  33. 'BasePath = "h:\habrascript\habratest\"
  34.  
  35.  
  36. ' ==========================================================================================================================
  37. ' Секция подпрограмм:
  38. ' ==========================================================================================================================
  39.  
  40. ' Функция удаляет все файлы из папки.
  41. Sub ClearFolder(parmPath)
  42. Dim oSubDir, oSubFolder, oFile, n
  43.  
  44.    On Error Resume Next          
  45.    Set oSubFolder = fso.getfolder(parmPath)
  46.    For Each oFile In oSubFolder.Files    
  47.       If Err.Number <> 0 Then    
  48.          Err.Clear
  49.       Else
  50.              fso.DeleteFile oFile.Path, True
  51.       End If
  52.    Next
  53.    For Each oSubDir In oSubFolder.Subfolders
  54.       ClearFolder oSubDir.Path      
  55.    Next
  56.    On Error Goto 0              
  57. End Sub
  58.  
  59. ' Функция проверяет наличие значения в реестре
  60. Function KeyExists(key)
  61.             Dim key2
  62.             On Error Resume Next
  63.             key2 = WshShell.RegRead(key)
  64.             If Err.Number <> 0 Then
  65.                         KeyExists = False
  66.             Else
  67.                         KeyExists = True
  68.             End If
  69.             On Error GoTo 0
  70. End Function
  71.  
  72. ' Функция проверяет наличие ключа реестра
  73. Function RegistryKeyExists (RegistryKey)
  74.   If (Right(RegistryKey, 1) <> "\") Then
  75.     RegistryKeyExists = false
  76.   Else
  77.     On Error Resume Next
  78.     WshShell.RegRead RegistryKey
  79.     Select Case Err
  80.       Case 0:
  81.         RegistryKeyExists = true
  82.       Case &h80070002:
  83.  
  84.         ErrDescription = Replace(Err.description, RegistryKey, "")
  85.         Err.clear
  86.         WshShell.RegRead "HKEY_ERROR\"
  87.         If (ErrDescription <> Replace(Err.description, "HKEY_ERROR\", "")) Then
  88.           RegistryKeyExists = true
  89.         Else
  90.           RegistryKeyExists = false
  91.         End If      
  92.       Case Else:
  93.         RegistryKeyExists = false
  94.     End Select    
  95.     On Error Goto 0
  96.   End If
  97. End Function
  98.  
  99. ' Функция получает данные пользователя из LDAP
  100. Sub GetDomainCreds()
  101.         set LocalRoot = getObject("LDAP://RootDSE")
  102.         DefNC = LocalRoot.get("DefaultNamingContext")
  103.         strPathCopy = "<LDAP://" & DefNC & ">;"
  104.         strCriteria = "(&(objectCategory=person)(objectClass=user)(sAMaccountname="&strUser&"));"
  105.         strProperties = "DisplayName, mail, telephoneNumber, title, mobile;"
  106.         strScope = "Subtree"
  107.         set objConnect = CreateObject("ADODB.Connection")
  108.         objConnect.Provider = "ADsDSOObject"
  109.         objConnect.Open = "Active Directory Provider"
  110.         set objCommand = CreateObject("ADODB.Command")
  111.         set objCommand.ActiveConnection = objConnect
  112.         objCommand.CommandText = strPathCopy & strCriteria & strProperties & strScope
  113.         objCommand.Properties("Page Size") = 1000
  114.         objCommand.Properties("Size Limit") = 1
  115.         objCommand.Properties("Timeout") = 30
  116.         Set objRecordSet = objCommand.Execute
  117.        
  118.         strDisplayName = objRecordSet.Fields("DisplayName").Value
  119.        
  120.         strmail = objRecordSet.Fields("mail").Value & vbcrlf
  121.        
  122.         strtelephoneNumber = objRecordSet.Fields("telephoneNumber").Value
  123.        
  124.         if (strtelephoneNumber <> "") then strtelephoneNumber = strtelephoneNumber & vbcrlf
  125.         strtitle = objRecordSet.Fields("title").Value
  126.        
  127.         if (strtitle <> "") then
  128.                 strtitle = strtitle & " " & prmOOO_Name & vbcrlf
  129.         else  
  130.                 strtitle = prmOOO_Name & vbcrlf
  131.         end if
  132.        
  133.         strmobile = objRecordSet.Fields("mobile").Value
  134.         if (strmobile <> "") then strmobile = strmobile & " (моб.)"& vbcrlf
  135. End Sub
  136.  
  137. ' Функция получает данные пользователя из файла
  138. Sub GetFileCreds()
  139.         strFile = BasePath & strComputerName & "\" & strUser & ".ini"
  140.        
  141.         'Если нет файла конфигурации, а пользователь сидит с оутлуком - он будет отправлять без подписи, непорядок!
  142.         'Надо предупредить. К счастью, в домене такой проблемы не бывает.
  143.         if not fso.FileExists (strFile) then
  144.                 Wscript.Echo "У вас не установлена подпись в Outlook. Обратитесь к сисадмину, он поможет. "
  145.                 Wscript.Quit   
  146.         End If
  147.  
  148.         Set ts = fso.OpenTextFile(strFile, 1)
  149.         strDisplayName = ts.ReadLine()
  150.         strtitle = ts.ReadLine()
  151.         if (strtitle <> "") then
  152.                 strtitle = strtitle & " " & prmOOO_Name & vbcrlf
  153.         else  
  154.         strtitle = prmOOO_Name & vbcrlf
  155.         end if
  156.        
  157.         strmail = ts.ReadLine() & vbcrlf
  158.         strtelephoneNumber = ts.ReadLine()
  159.         if (strtelephoneNumber <> "") then strtelephoneNumber = strtelephoneNumber & vbcrlf
  160.         if not ts.AtEndOfStream then
  161.                 strmobile = ts.ReadLine()
  162.                         if (strmobile <> "") then strmobile = strmobile & " (моб.)"& vbcrlf
  163.         end if
  164.         ts.close
  165. End Sub
  166.  
  167.  
  168. ' ==========================================================================================================================
  169. ' Основная секция:
  170. ' ==========================================================================================================================
  171.  
  172. ' Определяем  переменные, в которых будем хранить данные пользователя
  173. Dim strDisplayName
  174. Dim strtitle
  175. Dim strtelephoneNumber
  176. Dim strmobile
  177. Dim strmail
  178.  
  179. ' Создаем нужные нам объекты
  180. Set WshNetwork = WScript.CreateObject("WScript.Network")
  181. set WshShell =  WScript.CreateObject("WScript.Shell")
  182. Set fso = WScript.CreateObject("Scripting.FileSystemObject")
  183.  
  184. ' Юзернейм, копьютернейм, имя папки Application Data (на висте\вин7 у неё другое название)
  185. strUser = WshNetwork.UserName
  186. strComputerName = WshNetwork.ComputerName
  187. Folder = WshShell.SpecialFolders("AppData")
  188.  
  189.  
  190.  
  191. ' Если у пользователя не стоит офис - он идёт лесом.
  192. if not RegistryKeyExists("HKEY_CURRENT_USER\Software\Microsoft\Office\")  then 
  193.         Wscript.Quit
  194.         End If
  195.        
  196.  
  197. ' Проверяем BasePath и решаем, откуда нам брать учетные данные
  198. If BasePath = "" then
  199.                 GetDomainCreds()
  200.                 else
  201.                 GetFileCreds()
  202.                 End If
  203.  
  204.  
  205.  
  206. ' Делаем подпись
  207. Signature = "------------------" & vbcrlf & "С уважением, " & vbcrlf &  strDisplayName  & vbcrlf & strtitle &   strtelephoneNumber & strmobile & strmail & prmSite
  208.  
  209.  
  210.  
  211. ' Подписи лежат в %APPDATA%\Microsoft\Signatures. Но если до этого никаких подписей не создавалось -
  212. ' этой папки может и не быть. Поэтому нужно создать.
  213. If Not fso.FolderExists(Folder & "\Microsoft") Then
  214. fso.CreateFolder(Folder & "\Microsoft")
  215. End If
  216. Folder = Folder & "\Microsoft"
  217.  
  218. If Not fso.FolderExists(Folder & "\Signatures") Then
  219. fso.CreateFolder(Folder & "\Signatures")
  220. End If
  221. Folder = Folder & "\Signatures\"
  222.  
  223. ' Удаляем все подписи из этой папки, в том числе и юзерские.
  224. ClearFolder(Folder)
  225.  
  226. ' Пишем подпись в текстовый файл.
  227. Set ts = fso.OpenTextFile(Folder + "sev.txt", 2, True)
  228. ts.WriteLine(Signature)
  229. ts.Close
  230.  
  231. ' Ставим аттрибут "только чтение", чтобы юзер сам её не отредактировал.
  232. Set ts = fso.GetFile(Folder + "sev.txt")
  233. ts.Attributes = 1
  234.  
  235. ' Копируем ещё с тремя именами. Вообще оутлук перечисляет только файлы .txt, но на всякий случай.
  236. fso.CopyFile Folder + "sev.txt", Folder + "sev.htm", OverwriteExistring
  237. fso.CopyFile Folder + "sev.txt", Folder + "sev.rtf", OverwriteExistring
  238. fso.CopyFile Folder + "sev.txt", Folder + "sev.html", OverwriteExistring
  239. ' Кстати, поскольку я использую только текстовые подписи, html у меня кривой получается.
  240. ' Туда неплохо бы добавить хотя бы теги <br>. Но мне это не надо.
  241.  
  242. ' Теперь нам нужно понять, с какой версией офиса мы работаем. Кое-где стоят одновременно несколько
  243. ' версий, поэтому перебрать нужно все. К счастью, названия ключей реестра не менялись, поэтому
  244. ' достаточно просто перебрать номера версий.
  245. Key1 = "HKEY_CURRENT_USER\Software\Microsoft\Office\"
  246. Key2 = ".0\Outlook\Options\"
  247. for i = 5 to 15  
  248.         if RegistryKeyExists (Key1 & i & Key2 ) <> 0 then
  249.                 'Текстовый формат сообщения по умолчанию
  250.                 WshShell.RegWrite Key1 & i & Key2 & "Mail\EditorPreference", "65536", "REG_DWORD"                      
  251.                 'Читать все письма как текст
  252.                 WshShell.RegWrite Key1 & i & Key2 & "Mail\ReadAsPlain", "1", "REG_DWORD"                       
  253.                 'В том числе, и подписанные цифровой подписью.
  254.                 WshShell.RegWrite Key1 & i & Key2 & "Mail\ReadSignedAsPlain", "1", "REG_DWORD"                 
  255.          End If
  256. next
  257.  
  258. ' Перечисляем все учетки и исправляем в них имена и дефолтные подписи
  259. ' Профили оутлука лежат здесь:
  260. strKeyPath = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles"
  261.  
  262. ' Нужно перечислить субключи реестра, здесь нужно немножко уличной магии
  263. const HKEY_CURRENT_USER = &H80000001
  264. strComputer = "."
  265. Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")
  266. oReg.EnumKey HKEY_CURRENT_USER, strKeyPath, ProfileList
  267.  
  268. ' Если профилей нет - обидно, идём лесом.
  269. If IsNull(ProfileList) then
  270.         Wscript.Quit
  271. End If
  272.  
  273. ' А вот если они есть - то нужно перебрать их все, вытащить из них учетные
  274. ' записи почты и навести в них "жыстачайшый парадак" (с)
  275. For Each Profile in ProfileList
  276.         ' И вновь уличная магия. Перечисляем субключи в профиле
  277.         Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")
  278.         ' 9375CFF0413111d3B88A00104B2A6676 - это имя субключа, в который пишет и читает Оутлук.
  279.         oReg.EnumKey HKEY_CURRENT_USER, strKeyPath & "\" & Profile &  "\9375CFF0413111d3B88A00104B2A6676", arrSubKeys
  280.         ' Если в этом ключе что-то есть, тогда это всё нужно перебрать
  281.         if not IsNull(arrSubKeys) then
  282.                 For Each subkey In arrSubKeys
  283.                         keytext = "HKEY_CURRENT_USER\" & strKeyPath & "\" & Profile &  "\9375CFF0413111d3B88A00104B2A6676\" &  subkey & "\"
  284.                         ' Если в этом ключе есть значение "Email" - это почтовый аккаунт! Начинаем исправлять
  285.                                 if KeyExists (keytext & "Email") then
  286.                                 ' Вообще там значения в юникоде написаны как REG_BINARY. Но и reg_sz прокатывает со свистом, если только англ. символы.
  287.                                 ' Имя пользователя
  288.                                         WshShell.RegWrite keytext & "Display Name", strDisplayName , "REG_SZ"          
  289.                                 ' Используем нашу подпись для новых писем
  290.                                         WshShell.RegWrite keytext & "New Signature", "sev", "REG_SZ"           
  291.                                 ' Используем нашу подпись для ответов на письма и форварда.
  292.                                         WshShell.RegWrite keytext & "Reply-Forward Signature", "sev", "REG_SZ"         
  293.                                 end if
  294.                 Next
  295.         End If
  296. Next
  297.  
  298. ' Ну типа всё.
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
Top