Скрипт создания корпоративной подписи и наведения порядка в MS Outlook

outlook_ADsign.vbs

' Скрипт создания корпоративной подписи и наведения порядка в MS Outlook
' Работает в Outlook 2000 - 2010.
' Делает очень полезные вещи:
' - Выставляет имя отправителя почты из поля DisplayName в домене
' - Отключает HTML-просмотр писем и отправку писем в HTML.
' - Создаёт простую текстовую подпись и выставляет её для всех учеток.
' Если есть вопросы или жгучее желание дать мне денег\набить морду - 
' моя электропочта [email protected] . 

' Конфигурационные параметры: 

' Название фирмы:
prmOOO_Name =  "ООО ""Хабрафирма Интернейшнл"""
' Сайт фирмы:
prmSite = "http:/www.habrahabr.ru"

' Переменная BasePath определяет путь к файлам с данными пользователей. 
' В случае, если её значение равняется ("") - данные пользователя берутся из домена
' Для доменной учетной записи используются поля DisplayName (Выводимое имя), mail (Эл. почта), 
' telephoneNumber (Телефонный номер), title (Должность), mobile (Мобильный телефон);
' Для файлов используется построчное перечисление:
' 1 строка - ФИО, 
' 2 строка - Должность
' 3 cтрока - e-mail
' 4 строка - служебный телефон
' 5 строка - мобильный телефон (необязательно).
' Полное имя файла должно выглядеть как BasePath\имя_компьютера\имя_пользователя.ini
' Например, \\server\UserData$\comp01\user04.ini (BasePath = "\\server\UserData$\")
BasePath = ""


'BasePath = "\\habraserver\HabraSignatures$\"    
'BasePath = "h:\habrascript\habratest\"


' ==========================================================================================================================
' Секция подпрограмм:
' ==========================================================================================================================

' Функция удаляет все файлы из папки.
Sub ClearFolder(parmPath) 
Dim oSubDir, oSubFolder, oFile, n 
 
   On Error Resume Next          
   Set oSubFolder = fso.getfolder(parmPath) 
   For Each oFile In oSubFolder.Files    
      If Err.Number <> 0 Then    
         Err.Clear 
      Else
             fso.DeleteFile oFile.Path, True 
      End If 
   Next 
   For Each oSubDir In oSubFolder.Subfolders 
      ClearFolder oSubDir.Path       
   Next 
   On Error Goto 0               
End Sub

' Функция проверяет наличие значения в реестре
Function KeyExists(key)
            Dim key2
            On Error Resume Next
            key2 = WshShell.RegRead(key)
            If Err.Number <> 0 Then
                        KeyExists = False
            Else
                        KeyExists = True
            End If
            On Error GoTo 0
End Function

' Функция проверяет наличие ключа реестра
Function RegistryKeyExists (RegistryKey)
  If (Right(RegistryKey, 1) <> "\") Then
    RegistryKeyExists = false
  Else
    On Error Resume Next
    WshShell.RegRead RegistryKey
    Select Case Err
      Case 0:
        RegistryKeyExists = true
      Case &h80070002:

        ErrDescription = Replace(Err.description, RegistryKey, "")
        Err.clear
        WshShell.RegRead "HKEY_ERROR\"
        If (ErrDescription <> Replace(Err.description, "HKEY_ERROR\", "")) Then
          RegistryKeyExists = true
        Else
          RegistryKeyExists = false
        End If      
      Case Else:
        RegistryKeyExists = false
    End Select    
    On Error Goto 0
  End If
End Function

' Функция получает данные пользователя из LDAP
Sub GetDomainCreds()
	set LocalRoot = getObject("LDAP://RootDSE") 
	DefNC = LocalRoot.get("DefaultNamingContext") 
	strPathCopy = "<LDAP://" & DefNC & ">;" 
	strCriteria = "(&(objectCategory=person)(objectClass=user)(sAMaccountname="&strUser&"));" 
	strProperties = "DisplayName, mail, telephoneNumber, title, mobile;" 
	strScope = "Subtree" 
	set objConnect = CreateObject("ADODB.Connection") 
	objConnect.Provider = "ADsDSOObject" 
	objConnect.Open = "Active Directory Provider" 
	set objCommand = CreateObject("ADODB.Command") 
	set objCommand.ActiveConnection = objConnect 
	objCommand.CommandText = strPathCopy & strCriteria & strProperties & strScope 
	objCommand.Properties("Page Size") = 1000 
	objCommand.Properties("Size Limit") = 1 
	objCommand.Properties("Timeout") = 30 
	Set objRecordSet = objCommand.Execute 
	
	strDisplayName = objRecordSet.Fields("DisplayName").Value
	
	strmail = objRecordSet.Fields("mail").Value & vbcrlf
	
	strtelephoneNumber = objRecordSet.Fields("telephoneNumber").Value 
	
	if (strtelephoneNumber <> "") then strtelephoneNumber = strtelephoneNumber & vbcrlf
	strtitle = objRecordSet.Fields("title").Value 
	
	if (strtitle <> "") then 
		strtitle = strtitle & " " & prmOOO_Name & vbcrlf 
	else  
		strtitle = prmOOO_Name & vbcrlf 
	end if
	
	strmobile = objRecordSet.Fields("mobile").Value 
	if (strmobile <> "") then strmobile = strmobile & " (моб.)"& vbcrlf
End Sub

' Функция получает данные пользователя из файла
Sub GetFileCreds()
	strFile = BasePath & strComputerName & "\" & strUser & ".ini"
	
	'Если нет файла конфигурации, а пользователь сидит с оутлуком - он будет отправлять без подписи, непорядок!
	'Надо предупредить. К счастью, в домене такой проблемы не бывает.
	if not fso.FileExists (strFile) then
		Wscript.Echo "У вас не установлена подпись в Outlook. Обратитесь к сисадмину, он поможет. "
		Wscript.Quit	
	End If

	Set ts = fso.OpenTextFile(strFile, 1)
	strDisplayName = ts.ReadLine()
	strtitle = ts.ReadLine()
	if (strtitle <> "") then 
		strtitle = strtitle & " " & prmOOO_Name & vbcrlf 
	else  
	strtitle = prmOOO_Name & vbcrlf 
	end if
	
	strmail = ts.ReadLine() & vbcrlf
	strtelephoneNumber = ts.ReadLine() 
	if (strtelephoneNumber <> "") then strtelephoneNumber = strtelephoneNumber & vbcrlf
	if not ts.AtEndOfStream then
		strmobile = ts.ReadLine()
			if (strmobile <> "") then strmobile = strmobile & " (моб.)"& vbcrlf
	end if
	ts.close
End Sub


' ==========================================================================================================================
' Основная секция:
' ==========================================================================================================================

' Определяем  переменные, в которых будем хранить данные пользователя
Dim strDisplayName
Dim strtitle
Dim strtelephoneNumber
Dim strmobile
Dim strmail

' Создаем нужные нам объекты
Set WshNetwork = WScript.CreateObject("WScript.Network") 
set WshShell =  WScript.CreateObject("WScript.Shell") 
Set fso = WScript.CreateObject("Scripting.FileSystemObject")

' Юзернейм, копьютернейм, имя папки Application Data (на висте\вин7 у неё другое название)
strUser = WshNetwork.UserName 
strComputerName = WshNetwork.ComputerName
Folder = WshShell.SpecialFolders("AppData") 



' Если у пользователя не стоит офис - он идёт лесом.
if not RegistryKeyExists("HKEY_CURRENT_USER\Software\Microsoft\Office\")  then	
	Wscript.Quit
	End If
	

' Проверяем BasePath и решаем, откуда нам брать учетные данные
If BasePath = "" then
		GetDomainCreds()
		else
		GetFileCreds()
		End If



' Делаем подпись
Signature = "------------------" & vbcrlf & "С уважением, " & vbcrlf &  strDisplayName  & vbcrlf & strtitle &   strtelephoneNumber & strmobile & strmail & prmSite



' Подписи лежат в %APPDATA%\Microsoft\Signatures. Но если до этого никаких подписей не создавалось - 
' этой папки может и не быть. Поэтому нужно создать. 
If Not fso.FolderExists(Folder & "\Microsoft") Then 
fso.CreateFolder(Folder & "\Microsoft")
End If
Folder = Folder & "\Microsoft"

If Not fso.FolderExists(Folder & "\Signatures") Then 
fso.CreateFolder(Folder & "\Signatures")
End If
Folder = Folder & "\Signatures\"

' Удаляем все подписи из этой папки, в том числе и юзерские. 
ClearFolder(Folder) 

' Пишем подпись в текстовый файл.
Set ts = fso.OpenTextFile(Folder + "sev.txt", 2, True) 
ts.WriteLine(Signature)
ts.Close

' Ставим аттрибут "только чтение", чтобы юзер сам её не отредактировал.
Set ts = fso.GetFile(Folder + "sev.txt")
ts.Attributes = 1

' Копируем ещё с тремя именами. Вообще оутлук перечисляет только файлы .txt, но на всякий случай.
fso.CopyFile Folder + "sev.txt", Folder + "sev.htm", OverwriteExistring
fso.CopyFile Folder + "sev.txt", Folder + "sev.rtf", OverwriteExistring
fso.CopyFile Folder + "sev.txt", Folder + "sev.html", OverwriteExistring
' Кстати, поскольку я использую только текстовые подписи, html у меня кривой получается. 
' Туда неплохо бы добавить хотя бы теги <br>. Но мне это не надо.

' Теперь нам нужно понять, с какой версией офиса мы работаем. Кое-где стоят одновременно несколько
' версий, поэтому перебрать нужно все. К счастью, названия ключей реестра не менялись, поэтому
' достаточно просто перебрать номера версий.
Key1 = "HKEY_CURRENT_USER\Software\Microsoft\Office\"
Key2 = ".0\Outlook\Options\"
for i = 5 to 15  
	if RegistryKeyExists (Key1 & i & Key2 ) <> 0 then
		'Текстовый формат сообщения по умолчанию
		WshShell.RegWrite Key1 & i & Key2 & "Mail\EditorPreference", "65536", "REG_DWORD"			
		'Читать все письма как текст
		WshShell.RegWrite Key1 & i & Key2 & "Mail\ReadAsPlain", "1", "REG_DWORD"			
		'В том числе, и подписанные цифровой подписью. 
		WshShell.RegWrite Key1 & i & Key2 & "Mail\ReadSignedAsPlain", "1", "REG_DWORD"			
	 End If
next

' Перечисляем все учетки и исправляем в них имена и дефолтные подписи
' Профили оутлука лежат здесь:
strKeyPath = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles"

' Нужно перечислить субключи реестра, здесь нужно немножко уличной магии
const HKEY_CURRENT_USER = &H80000001
strComputer = "."
Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")
oReg.EnumKey HKEY_CURRENT_USER, strKeyPath, ProfileList 

' Если профилей нет - обидно, идём лесом. 
If IsNull(ProfileList) then 
	Wscript.Quit
End If

' А вот если они есть - то нужно перебрать их все, вытащить из них учетные 
' записи почты и навести в них "жыстачайшый парадак" (с)
For Each Profile in ProfileList
	' И вновь уличная магия. Перечисляем субключи в профиле
	Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")
	' 9375CFF0413111d3B88A00104B2A6676 - это имя субключа, в который пишет и читает Оутлук. 
	oReg.EnumKey HKEY_CURRENT_USER, strKeyPath & "\" & Profile &  "\9375CFF0413111d3B88A00104B2A6676", arrSubKeys
	' Если в этом ключе что-то есть, тогда это всё нужно перебрать
	if not IsNull(arrSubKeys) then
		For Each subkey In arrSubKeys
			keytext = "HKEY_CURRENT_USER\" & strKeyPath & "\" & Profile &  "\9375CFF0413111d3B88A00104B2A6676\" &  subkey & "\"
			' Если в этом ключе есть значение "Email" - это почтовый аккаунт! Начинаем исправлять
				if KeyExists (keytext & "Email") then
				' Вообще там значения в юникоде написаны как REG_BINARY. Но и reg_sz прокатывает со свистом, если только англ. символы.
				' Имя пользователя
					WshShell.RegWrite keytext & "Display Name", strDisplayName , "REG_SZ"		
				' Используем нашу подпись для новых писем
					WshShell.RegWrite keytext & "New Signature", "sev", "REG_SZ"		
				' Используем нашу подпись для ответов на письма и форварда.
					WshShell.RegWrite keytext & "Reply-Forward Signature", "sev", "REG_SZ"		
				end if
		Next
	End If
Next

' Ну типа всё.