On Error Resume Next
Dim qQuery, objSysInfo, objuser
Dim FullName, EMail, Title, PhoneNumber, MobileNumber, FaxNumber, OfficeLocation, Department
Dim FolderLocation, HTMFileStringF, HTMFileStringA, StreetAddress, Town, State, Company
Dim ZipCode, PostOfficeBox, UserDataPath
Dim VersionOffice
VersionOffice= "11.0"
'MessageReponse = MsgBox("!! Procédure de configuration des Signatures automatisées pour le courier électronique Outlook 2003 !! ", 65,"Technologies S.R. Optisoft Inc. ")
' Lecture de LDAP(Active Directory) pour assignation des informations aux variables.
'====================================================================================
Set objSysInfo = CreateObject("ADSystemInfo")
Set objNetwork = CreateObject("Wscript.Network")
strUserPath = "LDAP://" & objSysInfo.UserName
Set objUser = GetObject(strUserPath)
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
' Cette section créer les fichier de signatures.
'==========================================================================
' Répertoire par défaut pour la localisation des signatures
' c:\documents ans setting\user\application data\Microsoft\signatures
'==========================================================================
Dim objShell, RegKey, RegKeyParm
Set objShell = CreateObject("WScript.Shell")
RegKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & VersioOffice & "\Common\General"
RegKey = RegKey & "\Signatures"
objShell.RegWrite RegKey , "Signatures"
UserDataPath = ObjShell.ExpandEnvironmentStrings("%appdata%")
FolderLocation = UserDataPath &"\Microsoft\signatures\"
HTMFileStringF = FolderLocation & "Signature1Francais.htm"
HTMFileStringA = FolderLocation & "Signature1Anglais.htm"
' Créer le dossier de destination pour éviter une erreur lorsque Outlook n'a jamais été ouvert
dim filesys, newfolder, newfolderpath
newfolderpath = FolderLocation
set filesys=CreateObject("Scripting.FileSystemObject")
If Not filesys.FolderExists(newfolderpath) Then
Set newfolder = filesys.CreateFolder(newfolderpath)
End If
CopyFichier "\\NOMSERVER\PATH\Gabarits_Materiel\Logos\logo_cmpny\*.*", FolderLocation
' Cette section construit les fichiers de signatures
' Signature1F pour Francais
' Signature1A pour Anglais
'===================================================
Dim objFSO
Dim objFile,afile
Dim aQuote
aQuote = chr(34)
' Cette section construit les fichier HTML
'==========================================================================
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Cette section créer la signature en Francais
'==========================================================================
' Fichier HTML
Set objFile = objFSO.CreateTextFile(Folderlocation & "Signature1F.htm",True)
objFile.Close
Set objFile = objFSO.OpenTextFile(Folderlocation & "Signature1F.htm", 2)
objfile.write "" & vbCrLf
objfile.write "Microsoft Office Outlook Signature" & vbCrLf
objfile.write "" & vbCrLf
objfile.write "" & vbCrLf
objfile.write "" & vbCrLf
objfile.write ""& vbCrLf
objfile.write "
" & vbCrLf
objfile.write FullName & "
" & vbCrLf
objfile.write title & "
" & vbCrLf
objfile.write "555.555.5555, poste " & PhoneNumber & "
" & vbCrLf
objfile.write "
" & vbCrLf
objfile.write "
" & vbCrLf
objfile.write "
" & vbCrLf
objfile.write "Company name" & "
" & vbCrLf
objfile.write "Définiation de la company
" & vbCrLf
objfile.write "siteweb.com : Blogue.siteweb.com " & vbCrLf
objfile.write "
" & vbCrLf
objfile.write "" & vbCrLf
objFile.Close
' Fichier TXT
Set objFile = objFSO.CreateTextFile(Folderlocation & "Signature1F.txt",True)
objFile.Close
Set objFile = objFSO.OpenTextFile(Folderlocation & "Signature1F.txt", 2)
objfile.write " " & vbCrLf
objfile.write " " & vbCrLf
objfile.write " " & vbCrLf
objfile.write FullName & vbCrLf
objfile.write title & vbCrLf
objfile.write "555.555.5555, poste " & PhoneNumber & vbCrLf
objfile.write "" & vbCrLf
objfile.write "Company name Inc." & vbCrLf
objfile.write "Spécialistes " & vbCrLf
objfile.write "http://siteweb.com " & vbCrLf
objfile.write " " & vbCrLf
objfile.write " " & vbCrLf
objfile.write " " & vbCrLf
objFile.Close
' Cette section créer la signature en Anglais
' ==========================================================================
' Fichier Html
Set objFile = objFSO.CreateTextFile(Folderlocation & "Signature1A.htm",True)
objFile.Close
Set objFile = objFSO.OpenTextFile(Folderlocation & "Signature1A.htm", 2)
objfile.write "" & vbCrLf
objfile.write "Microsoft Office Outlook Signature" & vbCrLf
objfile.write "" & vbCrLf
objfile.write "" & vbCrLf
objfile.write "" & vbCrLf
objfile.write ""& vbCrLf
objfile.write "
" & vbCrLf
objfile.write FullName & "
" & vbCrLf
objfile.write Department & "
" & vbCrLf
objfile.write "555.555.5555, Ext " & PhoneNumber & "
" & vbCrLf
objfile.write "" & vbCrLf
objfile.write "
" & vbCrLf
objfile.write "
" & vbCrLf
objfile.write "Company name inc" & "
" & vbCrLf
objfile.write "Specialists
" & vbCrLf
objfile.write "siteweb.com : Blog.siteweb.com " & vbCrLf
objfile.write "
" & vbCrLf
objfile.write "" & vbCrLf
objFile.Close
' Fichier TXT
Set objFile = objFSO.CreateTextFile(Folderlocation & "Signature1A.txt",True)
objFile.Close
Set objFile = objFSO.OpenTextFile(Folderlocation & "Signature1A.txt", 2)
objfile.write " " & vbCrLf
objfile.write " " & vbCrLf
objfile.write " " & vbCrLf
objfile.write FullName & vbCrLf
objfile.write Department & vbCrLf
objfile.write "514.844.0333, ext. " & PhoneNumber & vbCrLf
objfile.write "" & vbCrLf
objfile.write "Nom de la company Inc" & vbCrLf
objfile.write "Spécialité" & vbCrLf
objfile.write "http://siteweb.com " & vbCrLf
objfile.write " " & vbCrLf
objfile.write " " & vbCrLf
objfile.write " " & vbCrLf
objFile.Close
' =========================================================================================================
' Cette section Assigne la signature par défaut dans Outlook
' =========================================================================================================
Call SetDefaultSignature("Signature1F","")
' Configuration du type de format email à HTML
SetEmailFormatType("PLAIN")
Sub SetDefaultSignature(strSigName, 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(strSigName, 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 = "S.V.P. fermer Outlook avant " & _
"d exécuter ce programme."
MsgBox strMsg, vbExclamation, "SetDefaultSignature"
End If
End Sub
Public Function CopyFichier(SourceFile, DestinationFile)
on error resume next
Dim fso, f, file
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CopyFile SourceFile, DestinationFile
if err.number > 0 and err.number <> 70 then
MsgBox ("Erreur: " & CStr(Err.Number) & " " & Err.Description)
Err.Clear ' Clear the error.
end if
on error goto 0
end Function
Function IsOutlookRunning()
'Vérifie si Outlook est en opération
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
public Function SetEmailFormatType(Format)
' Configure le format des messages dans Outlook
' HTML = 131072
' HTML & Word To Edit = 131073
' Rich Text = 196610
' Rich Text & Word To Edit = 196609
' Plain Text = 65536
' Plain Text & Word To Edit = 65537
Dim objShell, RegKey, RegKeyParm
Set objShell = CreateObject("WScript.Shell")
RegKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & VersionOffice & "\Outlook\Options\Mail"
RegKey = RegKey & "\EditorPreference"
select case Format
Case "HTML"
objShell.RegWrite RegKey , 131072 , "REG_DWORD"
Case "RICHTEXT"
objShell.RegWrite RegKey , 196610 , "REG_DWORD"
Case "PLAIN"
objShell.RegWrite RegKey , 65537 , "REG_DWORD"
END select
End Function