One of the most used services in a business environment is email.
Companies need to ensure that their image maintains the standard they choose, in both internal and external communications.
Then let’s use a VBScript to do a standard SIG and get the information from each user in Active Directory(AD).

This is an example of a Signature with the fields Full Name, Phone number, Email and Job Title from Active Directory.


So, how does the whole thing work? In the script we are going to create a word document and then “attach” to Outlook signature.
I have two setups for the color and size of the text.
On Error Resume Next Function orange(objSelection) With objSelection With .Font .Name = "Helvetica" .Size = 11 .Bold = False .Color = RGB(256,140,0) .Italic = False .Underline = False End With End With End Function Function black(objSelection) With objSelection With .Font .Name = "Helvetica" .Size = 10 .Bold = True .Color = RGB(0,0,0) .Italic = False .Underline = False End With End With End Function
Now, get the information from AD and pass it into variables.
Set objSysInfo = CreateObject("ADSystemInfo") strUser = objSysInfo.UserName Set objUser = GetObject("LDAP://" & strUser) With objUser strName = .FullName strTitle = .Title stradr = .streetAddress strpostal = .postalCode strl = .l strco = .co strcomp = .company strhome = .homePhone strIpPhone = .ipPhone strMobile = .Mobile strPhone = .TelephoneNumber strMail = .mail End With
Creating the word document.
In the full name field I used different font settings, which only happened in this field, so I inserted the settings manually instead of creating a function.
Set objword = CreateObject("Word.Application") With objword Set objDoc = .Documents.Add() Set objSelection = .Selection Set objEmailOptions = .EmailOptions End With Set objSignatureObject = objEmailOptions.EmailSignature Set objSignatureEntries = objSignatureObject.EmailSignatureEntries With objSelection .ParagraphFormat.Alignment = wdAlignParagraphLeft .ParagraphFormat.SpaceAfter = 0 .ParagraphFormat.SpaceBefore = 0 'NAME With .Font .Name = "Helvetica" .Size = 14 .weight = 1000 .Bold = True .Color = RGB(0,0,0) .Italic = False .Underline = False End With .TypeText strName .TypeText Chr(11) & Chr(6) ...
In the second field we first call the function with the settings we want, in this case the orange.
... 'JOB TITLE orange(objSelection) .TypeText strTitle & Chr(32) & Chr(11) & Chr(11) ...
The first two fields are inserted.
Now let’s insert the image. We have to wrap it so that we can insert the text in front of it.
... .InlineShapes.AddPicture "\\SYSPDC\wider\sig.png", True, True objDoc.InlineShapes(1).ConvertToShape objDoc.Shapes(1).WrapFormat.Type = 0 'Abaixo objDoc.Shapes(1).WrapFormat.Type = 0 'Ao Lado ...
To create the Social Banner we first insert the images and then the links.
. ... 'SOCIAL BANNER .TypeText Chr(32)& Chr(32) & Chr(11) & Chr(11) & Chr(11) .InlineShapes.AddPicture "\\192.168.2.11\shares_W\Sig\Social_Banner\linkedin.png", True, True .TypeText Chr (9) .InlineShapes.AddPicture "\\192.168.2.11\shares_W\Sig\Social_Banner\email.png", True, True .TypeText Chr (9) .InlineShapes.AddPicture "\\192.168.2.11\shares_W\Sig\Social_Banner\wiki.png", True, True .TypeText Chr (9) .InlineShapes.AddPicture "\\192.168.2.11\shares_W\Sig\Social_Banner\social.png", True, True .TypeText Chr (9) End With objDoc.Hyperlinks.Add objDoc.InlineShapes.Item(1),"https://www.linkedin.com/in/carlos-lobao" objDoc.Hyperlinks.Add objDoc.InlineShapes.Item(2),"mailto:[email protected]" objDoc.Hyperlinks.Add objDoc.InlineShapes.Item(3),"https://wiki.syslab.network" objDoc.Hyperlinks.Add objDoc.InlineShapes.Item(4),"https://www.syslab.network" ...
Lastly, we insert our signature in Outlook.
... Set objSelection = objDoc.Range() objSignatureEntries.Add "AD Signature", objSelection objSignatureObject.NewMessageSignature = "AD Signature" objSignatureObject.ReplyMessageSignature = "AD Signature" objDoc.Saved = True objword.Quit
Script
On Error Resume Next Function orange(objSelection) With objSelection With .Font .Name = "Helvetica" .Size = 11 .Bold = False .Color = RGB(256,140,0) .Italic = False .Underline = False End With End With End Function Function black(objSelection) With objSelection With .Font .Name = "Helvetica" .Size = 10 .Bold = True .Color = RGB(0,0,0) .Italic = False .Underline = False End With End With End Function Set objSysInfo = CreateObject("ADSystemInfo") strUser = objSysInfo.UserName Set objUser = GetObject("LDAP://" & strUser) With objUser strName = .FullName strTitle = .Title stradr = .streetAddress strpostal = .postalCode strl = .l strco = .co strcomp = .company strhome = .homePhone strIpPhone = .ipPhone strMobile = .Mobile strPhone = .TelephoneNumber strMail = .mail End With Set objword = CreateObject("Word.Application") With objword Set objDoc = .Documents.Add() Set objSelection = .Selection Set objEmailOptions = .EmailOptions End With Set objSignatureObject = objEmailOptions.EmailSignature Set objSignatureEntries = objSignatureObject.EmailSignatureEntries With objSelection .ParagraphFormat.Alignment = wdAlignParagraphLeft .ParagraphFormat.SpaceAfter = 0 .ParagraphFormat.SpaceBefore = 0 'NAME With .Font .Name = "Helvetica" .Size = 14 .weight = 1000 .Bold = True .Color = RGB(0,0,0) .Italic = False .Underline = False End With .TypeText strName .TypeText Chr(11) & Chr(6) 'JOB TITLE orange(objSelection) .TypeText strTitle & Chr(32) & Chr(11) & Chr(11) .InlineShapes.AddPicture "\\SYSPDC\wider\sig.png", True, True objDoc.InlineShapes(1).ConvertToShape objDoc.Shapes(1).WrapFormat.Type = 0 'Abaixo objDoc.Shapes(1).WrapFormat.Type = 0 'Ao Lado 'main black(objSelection) .TypeText ("SysLab: ") orange(objSelection) .TypeText ("Projecto pessoal de Sistemas Informáticos") .TypeText Chr(11) 'mobile If (strMobile = Empty) Then .TypeText Chr(32) Else black(objSelection) .TypeText ("Tel: ") 'Mobilephone orange(objSelection) .TypeText Chr(32)& strMobile & Chr(11) End If 'Email black(objSelection) .TypeText ("Email: ") orange(objSelection) .TypeText strMail & Chr(32) & Chr(11) & Chr(6) 'General Phone If (strhome <> Empty) Then black(objSelection) .TypeText ("Main: ") & Chr(32)& Chr(32) orange(objSelection) .TypeText strhome & Chr(32)& Chr(32) End If 'Direct Phone If (strIpPhone <> Empty) Then black(objSelection) .TypeText ("Direct: ") & Chr(32)& Chr(32) orange(objSelection) .TypeText strIpPhone End If 'SOCIAL BANNER .TypeText Chr(32)& Chr(32) & Chr(11) & Chr(11) & Chr(11) .InlineShapes.AddPicture "\\192.168.2.11\shares_W\Sig\Social_Banner\linkedin.png", True, True .TypeText Chr (9) .InlineShapes.AddPicture "\\192.168.2.11\shares_W\Sig\Social_Banner\email.png", True, True .TypeText Chr (9) .InlineShapes.AddPicture "\\192.168.2.11\shares_W\Sig\Social_Banner\wiki.png", True, True .TypeText Chr (9) .InlineShapes.AddPicture "\\192.168.2.11\shares_W\Sig\Social_Banner\social.png", True, True .TypeText Chr (9) End With objDoc.Hyperlinks.Add objDoc.InlineShapes.Item(1),"https://www.linkedin.com/in/carlos-lobao" objDoc.Hyperlinks.Add objDoc.InlineShapes.Item(2),"mailto:[email protected]" objDoc.Hyperlinks.Add objDoc.InlineShapes.Item(3),"https://wiki.syslab.network" objDoc.Hyperlinks.Add objDoc.InlineShapes.Item(4),"https://www.syslab.network" Set objSelection = objDoc.Range() objSignatureEntries.Add "AD Signature", objSelection objSignatureObject.NewMessageSignature = "AD Signature" objSignatureObject.ReplyMessageSignature = "AD Signature" objDoc.Saved = True objword.Quit
Troubleshooting
If there are users connected to the network via VPN, verify if their communication with the AD is correct. Communication with AD does not work correctly, only through IP is the DNS required.
If you run the script and the changes don’t happen run in CMD
gpupdate
Finally, delete the files from C:\Users\USER\AppData\Roaming\Microsoft\Signatures and run the script again.

The script is available in the Download menu.
Like!! I blog frequently and I really thank you for your content. The article has truly peaked my interest.