VBScript : Créer une signature personnalisée par utilisateur sous Outlook 2003/2007

Le script fait par Guillaume Maison que nous reprenons ici car le lien original n’existe plus

VBScript: Créer une signature personnalisée par utilisateur sous Outlook 2003/2007 sur SBS

Souvent, chaque utilisateur veut voir, dans sa signature, son nom, sa ligne directe, le nom de son poste, … Pour autant, il existe une charte graphique d’entreprise qui doit être commune à l’ensemble de ces signatures. Si chaque utilisateur crée sa propre signature, il faut alors qu’une personne vérifie chacune des signatures et la mette correctement en forme sur l’ensemble des postes. Cela peut devenir fastidieux, notamment si l’entreprise doit changer de signature en fonction d’événéments la concernant (présence sur un salon, présence de publicités pour de nouveaux produits, etc…).

Voici donc un petit script, qui fonctionne avec Outlook 2003 et Outlook 2007, en environnement Active Directory (donc également sur SBS), qui permet de personnaliser la signature, par utilisateur, tout en gardant la cohérence de la charte graphique d’entreprise.

[vb]
' VBScript: <Signatures.vbs>
' Author : Guillaume Maison
' Contact : gmaison@infopartner.biz
' Version 1.00
' Date : February 20 2008
' Based on the script <signatures.vbs> from Peter Aarts (peter.aarts@l1.nl) Version 2.04 - January 20, 2006
' REMARQUES :
' #############################################################################################
' ATTENTION  -  ATTENTION  -  ATTENTION  -  ATTENTION  -  ATTENTION  -  ATTENTION  -  ATTENTION
'
'       Ce script effectue des modifications dans la base de registre de Windows.
'       Il modifie certaines configurations par défaut et certaines valeurs de clés
'                Vous utilisez donc ce script à  vos risques et périls
'
' ATTENTION  -  ATTENTION  -  ATTENTION  -  ATTENTION  -  ATTENTION  -  ATTENTION  -  ATTENTION
' #############################################################################################
'       WARNING  -  WARNING  -  WARNING  -  WARNING  -  WARNING  -  WARNING  -  WARNING
'
'                       This script modifies keys and values in the registry
'                               it modifies the default configuration
'                            You're using this script at your own risks
'
'       WARNING  -  WARNING  -  WARNING  -  WARNING  -  WARNING  -  WARNING  -  WARNING
' #############################################################################################
'
' ToDO :
' -     At the end of the script, the function SetDefaultSignature sets some value in the Windows Messaging SubSystem
'       in the subkeys \9375CFF0413111d3B88A00104B2A6676 New Signature and Reply-to Signature. On Outlook 2007, it seems
'       not to work properly. In fact, it doesn't set the signature name within the signature settings form in Outlook.
'       But Outlook uses the correct signature... is it because there's no RTF or TXT file ?
'
'------------------------------------------------------------------------------------------------------------

' Algorithme du script
' 1. Déclaration des variables qui seront utilisée
' 2. Récupération des informations sur l'utilisateur courant
' 3. Récupération de l'emplacement de la signature
' 4. Copie des fichiers du modèle de signature vers l'emplacement cible
' 5. Modification des fichiers du modèle de signature avec les informations de l'utilisateur
' 6. Modification de la base de registre pour attribuer les signatures
'-------------------------------------------------------------------------------------------
' Script alorithm
' 1. Variable  declarations
' 2. AD User informations retrieving
' 3. Signature model location retrieving
' 4. Signature model files copy to destination directory
' 5. Signature model files modification with user informations
' 6. Registry modifications to set signatures for Outlook
'---------------------------------------------------------------------

'Option Explicit
On Error Resume Next

' 1. déclaration des variables
'    variable declarations
'-----------------------------
' Objets requête LDAP, réseau et utilisateur
' LDAP, network and user objects
Dim qQuery, objSysInfo, objuser
' Objet Outlook
' Outlook object
Dim Outlook

' Informations sur l'utilisateur
' user informations
Dim FullName, EMail, Title, PhoneNumber, MobileNumber, FaxNumber, OfficeLocation, Department
Dim web_address, StreetAddress, Town, State, Company
Dim ZipCode, PostOfficeBox

' Locatisations de répertoire
' folder locations
Dim FolderLocation, UserDataPath

' Chaîne réutilisable
' reusable strings
Dim StrSignatureName                ' Signature Name

' Version d'outlook
' Outlook version
dim outlookver

' Divers
' Various
dim CheckTime


' Initialisation de variables - les changements doivent être faits ici sur cette variable
' Variables initialisation - changes have to be made here on this variable.
'--------------------------------------
StrSignatureName = "nomsignature"
'--------------------------------------

' En premier, obtenir la version d'outlook
' First, get outlook version
'--------------------------------------------------
set outlook = createobject("outlook.application")
outlookver = Left(outlook.version, InStr(outlook.version, ".")-1)
set Outlook = nothing

' Petite boucle basée sur le temps pour attendre la fermeture d'outlook
' Small time-based loop to wait for outlook to quit
'----------------------------------------------------------------------------

CheckTime = timer
while (timer - checktime) < 10
        ' on ne fait rien, on attend juste que Outlook se termine...
        ' do nothing, jsut waiting for toulook to quit
Wend


' On récupère les informations utilisateurs de l'AD par l'intermédiaire d'une requête LDAP
' Cela suppose tout d emême d'avoir correctement renseigné les informations de la fiche utilisateur.
' Dans le cas d'un Windows SBS 2003, il est possible de paramétrer certains champs par défaut
' dans le modèle utilisateur avant la création des utilisateurs
' We get back all the user informations from the AD through a LDAP query.
' It supposes that all the user informations are correctly entered in the AD.
' With a Windows SBS 2003, there's the possibility to pre fill some fields in the Default User Model
'---------------------------------------------------------------------------------------------------
Set objSysInfo = CreateObject("ADSystemInfo")
objSysInfo.RefreshSchemaCache
qQuery = "LDAP://" & objSysInfo.Username
Set objuser = GetObject(qQuery)

FullName = objuser.displayname
EMail = objuser.mail
Company = objuser.Company
Title = objuser.title
PhoneNumber = objuser.TelephoneNumber
FaxNumber = objuser.FaxNumber
OfficeLocation = objuser.physicalDeliveryOfficeName
StreetAddress = objuser.streetaddress
PostofficeBox = objuser.postofficebox
Department = objUser.Department
ZipCode = objuser.postalcode
Town = objuser.l
MobileNumber = objuser.TelephoneMobile
web_address = objUser.wWWHomePage

' On crée ici les signatures
' A partir d'ici, toute la méthode n'est pas supportée par Microsoft.
'
' We create now the signatures
' from here, the methods used are not supported by Microsoft...
'---------------------------------------------------------------------
Dim objShell, RegKey, RegKeyParm
Set objShell = CreateObject("WScript.Shell")

' Modification du chemin contenant la signature dans la base de registre basée sur la version d'outlook
' Modification of the registry key value setting the signature path, Outlook version-based
RegKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\"&OutlookVer&".0\Common\General\Signatures"
objShell.RegWrite RegKey , StrSignatureName

' Création du chemin local contenant les signatures
' signature local path creation
'--------------------------------------------------
UserDataPath = ObjShell.ExpandEnvironmentStrings("%appdata%")
FolderLocation = UserDataPath &"\Microsoft\"&StrSignatureName&"\"

' On précise ici les signatures (Nouveau message et Réponse)
' Setting new message and reply-to message signature
'-----------------------------------------------------------
objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\"&outlookVer&".0\Common\MailSettings\NewSignature" , strSignatureName
objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\"&OutlookVer&".0\Common\MailSettings\ReplySignature" , strSignatureName
objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\"&OutlookVer&".0\Outlook\Options\Mail\EnableLogging" , "0", "REG_DWORD"

' on vérifie si le chemin local des signatures existe. sinon on le crée
' Verifying that the local path to the signature exists... else creating
'-----------------------------------------------------------------------
Dim objFS1
Set objFS1 = CreateObject("Scripting.FileSystemObject")
If (objFS1.FolderExists(FolderLocation)) Then
Else
Call objFS1.CreateFolder(FolderLocation)
End if

' On crée le fichier de signature
' The next section builds the signature file
'-------------------------------------------
Dim objFSO
Dim objFile,afile, SignFoll, Folcoll, SubFoll
Dim aQuote
aQuote = chr(34)

' Adaptation du modèle
' This section builds the HTML file version
'-------------------------------------------
Set objFSO = CreateObject("Scripting.FileSystemObject")

' on efface toutes les signatures présente dans le chemin local des signatures
' Deletion of all the signature files that may be present in the local signature folder
'------------------------------------------------------------------------------------
objFSO.DeleteFile(Folderlocation & "*.*")

' suppresion de tout répertoire dans ce dossier
' deletion of any folder int the local signature folder
'------------------------------------------------------
set SignFoll = objFSO.GetFolder(FolderLocation)
Set folcoll = SignFoll.SubFolders
For Each subfol in Folcoll
        subFol.Delete true
Next

Set objFile = objFSO.CreateTextFile(FolderLocation&"\"&strSignatureName&".htm",True)
objFile.Close
Set objFile = objFSO.OpenTextFile(FolderLocation&"\"&strSignatureName&".htm", 2)

' Signature en code HTML. Vous pouvez modifier à  loisir ce code pour l'adapter selon vos besoins
' HTML Coded signature. You can change at will this code to customize it according to your needs
'--------------------------------------
dest_sign = "<!DOCTYPE HTML PUBLIC " & aQuote & "-//W3C//DTD HTML 4.0 Transitional//EN" & aQuote & ">" & vbCrLf
dest_sign = dest_sign & "<html>"
dest_sign = dest_sign & "<head>"
dest_sign = dest_sign & "</head>"
dest_sign = dest_sign & "<body>"
dest_sign = dest_sign & "<style>"
dest_sign = dest_sign & "<!--"
dest_sign = dest_sign & ".username {"
dest_sign = dest_sign & "        font-family: Arial;"
dest_sign = dest_sign & "        font-weight: bold;"
dest_sign = dest_sign & "        font-size: 1.15em;"
dest_sign = dest_sign & "}"
dest_sign = dest_sign & ""
dest_sign = dest_sign & ".company {"
dest_sign = dest_sign & "        font-family: Arial;"
dest_sign = dest_sign & "        font-weight: bold;"
dest_sign = dest_sign & "        font-size: 1.27em;"
dest_sign = dest_sign & "        color:#943634;"
dest_sign = dest_sign & "}"
dest_sign = dest_sign & ".phone {"
dest_sign = dest_sign & "        font-family: Arial;"
dest_sign = dest_sign & "        font-size: 0.88em;"
dest_sign = dest_sign & ""
dest_sign = dest_sign & "}"
dest_sign = dest_sign & ".address {"
dest_sign = dest_sign & "        font-family: Arial;"
dest_sign = dest_sign & "        font-size: 0.88em;"
dest_sign = dest_sign & "        color: darkred;"
dest_sign = dest_sign & "}"
dest_sign = dest_sign & "-->"
dest_sign = dest_sign & "</style>"
dest_sign = dest_sign & "--"
dest_sign = dest_sign & "<div class="&aQuote&"username"&aQuote&">"&Fullname&"</div>"
dest_sign = dest_sign & "<div class="&aQuote&"company"&aQuote&">"&Company&"</div>"
dest_sign = dest_sign & "<div class="&aQuote&"address"&aQuote&">"&streetAddress&" - "&ZipCode&" "&Town&"</div>"
dest_sign = dest_sign & "<div class="&aQuote&"phone"&aQuote&">Tél. : "&PhoneNumber&" / "&mobileNumber&" - Fax : "&FaxNumber&"</div>"

' ici on insère une balise de lien internet en fonction du site web
dest_sign = dest_sign & "<div class="&aQuote&"web"&aQuote&"><a href="&aQuote&"http://"&web_address&aQuote&">"&web_address&"</a></div>"

' Aujourd'hui, pour insérer une image, il faut préciser une balise de type IMG avec une source de type http
' today, to insert an image, you need to use an img tag with a 'http' src type
' dest_sign = dest_sign & "<img src="&aQuote&"http://www.google.fr/intl/fr_fr/images/logo.gif"&aQuote&">"

dest_sign = dest_sign & "</body>"
dest_sign = dest_sign & "</html>"

' Fin de la personnalisation
' end of customization
'--------------------------------------

objFile.write dest_sign
objFile.Close

'---------------------------------------------------------------------
' Cette section prend le profil courant d'Outlook et y place le nom de la signature par défaut
' This section readsout the current Outlook profile and then sets the name of the default Signature
'---------------------------------------------------------------------

' Use this version to set all accounts in the default mail profile to use a previously created signature
Call SetDefaultSignature(StrSignatureName,"")

' Use this version (and comment the other) to modify a named profile.
' Call SetDefaultSignature  ("Signature Name", "Profile Name")


' WScript.Echo "fin du script"

Sub SetDefaultSignature(strSignName, strProfile)
        Const HKEY_CURRENT_USER = &H80000001
        strComputer = "."

        If Not IsOutlookRunning Then
                Set objreg = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")
                strKeyPath = "Software\Microsoft\Windows NT\" & "CurrentVersion\Windows " & "Messaging Subsystem\Profiles\"
                ' get default profile name if none specified
                If strProfile = "" Then
                        objreg.GetStringValue HKEY_CURRENT_USER, strKeyPath, "DefaultProfile", strProfile
                End If
                ' build array from signature name
                myArray = StringToByteArray(strSignName, True)
                strKeyPath = strKeyPath & strProfile & "\9375CFF0413111d3B88A00104B2A6676"

                objreg.EnumKey HKEY_CURRENT_USER, strKeyPath, arrProfileKeys
                For Each subkey In arrProfileKeys
                        strsubkeypath = strKeyPath & "\" & subkey
                        objreg.SetBinaryValue HKEY_CURRENT_USER, strsubkeypath, "New Signature", myArray
                        objreg.SetBinaryValue HKEY_CURRENT_USER, strsubkeypath, "Reply-Forward Signature", myArray
                Next
        Else
                strMsg = "Please shut down Outlook before " & "running this script."
                MsgBox strMsg, vbExclamation, "SetDefaultSignature"
        End If
End Sub

Function IsOutlookRunning()
        strComputer = "."
        strQuery = "Select * from Win32_Process " & "Where Name = 'Outlook.exe'"
        Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
        Set colProcesses = objWMIService.ExecQuery(strQuery)
        For Each objProcess In colProcesses
                If UCase(objProcess.Name) = "OUTLOOK.EXE" Then
                        IsOutlookRunning = True
                Else
                        IsOutlookRunning = False
                End If
        Next
End Function

Public Function StringToByteArray (Data, NeedNullTerminator)
        Dim strAll
        strAll = StringToHex4(Data)
        If NeedNullTerminator Then
                strAll = strAll & "0000"
        End If
        intLen = Len(strAll) \ 2
        ReDim arr(intLen - 1)
        For i = 1 To Len(strAll) \ 2
                arr(i - 1) = CByte ("&H" & Mid(strAll, (2 * i) - 1, 2))
        Next
        StringToByteArray = arr
End Function

Public Function StringToHex4(Data)
        ' Input: normal text
        ' Output: four-character string for each character,
        ' e.g. "3204" for lower-case Russian B,
        ' "6500" for ASCII e
        ' Output: correct characters
        ' needs to reverse order of bytes from 0432
        Dim strAll
        For i = 1 To Len(Data)
                ' get the four-character hex for each character
                strChar = Mid(Data, i, 1)
                strTemp = Right("00" & Hex(AscW(strChar)), 4)
                strAll = strAll & Right(strTemp, 2) & Left(strTemp, 2)
        Next
        StringToHex4 = strAll
End Function

Attention :il semblerait qu’une fois le script exécuté, si aucune signature n’était choisie dans Outlook, elle n’apparaîtra pas. Il faut donc choisir la signature sur le poste la première fois. Ensuite, si la signature est modifiée, elle sera impactée automatiquement sur tous les utilisateurs.