VBScript email signature with external images, vcf card, registry edits

Hey!  So, I recently undertook an email signature project.  I had a heck of a time getting info needed from google, so I figure I'd post it here in case an others stumble across it.  Here's a brief list of what it does, if you need help with implementation leave a comment.  All disclaimers applied - I'M NOT RESPONSIBLE FOR ANYTHING THIS DOES TO  YOU, YOUR ENVIRONMENT, YOUR END USER, AND/OR ANYTHING, PERIOD.  We'll just stick with I'm very irresponsible and not responsible for anything :)

So, on to the script...  Just taking a moment to point out that this was written and tested with Outlook 2013 and created with Word 2013, the below script also requires that the PC is on a domain and using Active Directory.  First, It has SQL DB connectivity written into it so that top, middle, bottom notices (example: holiday notice, special hours, disclaimer) can be applied and maintained without having to edit the script (we have end users that just use a simple webpage to update this information).  I'm not going to add the SQL table information at this time; I figure if you're going to want to incorporate this type of functionality, you'll likely want to create you're own tables(s).  Next, the script creates and applies a vCard to the signature as an attachment (not a signature), this requires a little registry tweak, and the script takes care of that.  Also, there are added registry tweak to send the images as links (Outlook 2013 made this require a registry tweak to do).  Lastly, the script "defaults" outlooks stationary and font.  I'll briefly go over the constants...

LINK_TO_IMAGE:  this is when adding the image through word it adds the image as a link to file, rather than embedding it which it still kind of does if the next SAVE_TO_DOC isn't set to False.  With it as True, the image is saved in the signatureName_files folder and the htm version of the signature is linked to that image (rather than the one you will use that's out on the web).  SEND_AS_LINK is for the outlook registry tweak to actually send the image as a "link to the image".  Let pause for a moment and ask, why go to so much trouble to send images this way??  This answer is simple - if you're not actually sending an attachment, you don't want the email to indicate you've sent one.  It's annoying for people who manage their inboxes using the attachment flag and it's even more annoying for people who script attachment removal and worse could potentially get your email blocked by a business that doesn't let images through.  A link avoids all of this, if the receiver isn't allow internet, they get a little question mark or x'd image with NO attachments...  k, attachment rave; CHECK!  Back to constants...  ADD_VCARD, if you want a vCard to be sent out as an ATTACHMENT on EVERY email you send out, leave this as True.  Now the best part - MULTI_IMAGE...  K, so being the newbie dever I am and not really wanting to mess with resizing images on the fly I decided to figure out the least number of rows, lines, whatever you want to call them, in my signature - which was 5.  So I created an signature with 5 rows and sized our logos and images to look nice with 5 rows and saved them in a folder called "5" where we store our images on the web.  Next I figured out what's the most number of (we're going to call them rows from here on out) rows an end user could have in their signature - this number ended up being 9.  So, I created a signature with 9 rows and sized images to look nice with 9 rows and saved them in a folder called "9" where we store our images on the web...  Hopefully my redundant typing has assisted in try to show where I'm going...  If not...  Then I created a signature with 6, 7, 8, etc. rows and resized images respectively and put them in folders named "6", "7", "8", etc. where we store our images on the web...  The script then determines how many rows your signature is and links the correctly sized images to the signature...  If you're not a "newbie dever" then I'm sure you know how to easily resize images on the fly, and this would be the better solution...  However, my workaround is just as well (other than if we change the image I have to manually figure out and resize 5 flipping images and save them in their respective folders (5, 6, 7, 8, 9).  To just omit this whole resizing nonsense leave MULTI_IMAGE as False ...  DB just lets you omit the SQL connectivity part.  Leave it as False if you're not adding the backend SQL database.

Just figure I'd also point out that we changed domains; so there are a couple of Replace throughout the script where I would replace our old domain with our new domain - I realize I could've done this through AD, but it's only temporary so rather than modify all our users in AD I'm doing it in the script, which I'll remove when we're going to use our old domain again.  So, read through the script where everything is declared.  I'm more opt to sharing this only for others to piece meal as like I said looking up everything needed for this on the internet was tedious.

The script is poorly commented, but fairly easy to understand, hence why the limited commenting...  However, if you have any questions or better yet RECOMMEDATIONS (in regards to making it better - like the image resizing) please leave a comment!  Now time for the script....


Option Explicit
'On Error Resume Next
'Const LINK_TO_IMAGE add picture as "Link To File"
Const LINK_TO_IMAGE = True, SAVE_TO_DOC = False
'Const SEND_AS_LINK modifies DWORD value - 1 it doesn't, 0 it does
Const SEND_AS_LINK = 0
'Const add vCard
Const ADD_VCARD = True
'Const single image
Const MULTI_IMAGE = False
'Const for DB connectivity
Const DB = False
Dim strImageLocation
strImageLocation = "http://public site where images are stored/"
Dim strGroup
Dim dbDataSource, dbCatalog, dbUser, dbPassword, dbConnection, dbCommand, dbConnString, dbRecord, dbTable, dbField, sqlQuery
dbDataSource = "SQL Server"
dbCatalog = "SQL DB"
dbUser = "SQL User"
dbPassword = "SQL Password"
dbTable = "Message table"
Dim objAD, objUser
Set objAD = WScript.CreateObject("ADSystemInfo")
Set objUser = GetObject("LDAP://" & objAD.UserName)
Dim strName, strTitle, strDept, strCompany, strPhone, strMobile, strFax, strMail1, strMail2, strGroupEmail, strAddress, strTopMessage, strMiddleMessage, strBottomMessage
strName = Replace(Replace(objUser.FirstName & " " & objUser.Initials & " " & objUser.LastName," . "," "),"  "," ")
strTitle = objUser.Title
strDept = objUser.Department
strCompany = objUser.Company
strPhone = LCase(Replace(Replace(Replace(objUser.TelephoneNumber,"-","."),"(",""),")",""))
strMobile = LCase(Replace(Replace(Replace(objUser.Mobile,"-","."),"(",""),")",""))
strFax = LCase(Replace(Replace(Replace(objUser.FacsimileTelephoneNumber,"-","."),"(",""),")",""))
strMail1 = LCase(Replace(objUser.Mail,"old domain","new domain"))
strMail2 = ""
strGroupEmail = LCase(objUser.ExtensionAttribute1)
If Not strGroupEmail = "" Then strMail2 = Mid(strGroupEmail,InStrRev(strGroupEmail,"-")+1,Len(strGroupEmail)-InStrRev(strGroupEmail,"-")) & "@newdomain.com"
strAddress = objUser.StreetAddress & ", " & objUser.l & ", " & objUser.st & " " & objUser.PostalCode 
strTopMessage = ""
strMiddleMessage = ""
strBottomMessage = ""
strTopMessage = If DB Then getMsg(strGroupEmail,"TOP")
strMiddleMessage = If DB Then getMsg(strGroupEmail,"MIDDLE")
strBottomMessage = If DB Then getMsg(strGroupEmail,"BOTTOM")
Dim rowNumber
rowNumber = 5
If Not strDept = "" Then rowNumber = rowNumber + 1
If Not strMobile = "" Then rowNumber = rowNumber + 1
If Not strFax = "" Then rowNumber = rowNumber + 1
If Not strMail2 = "" Then rowNumber = rowNumber + 1
rowNumber = rowNumber & "/"
If Not MULTI_IMAGE Then rowNumber = ""
Dim imgLeftImage, imgRightImage, lnkLeftLink, lnkRightLink, icoPhone, icoMobile, icoFax, icoMail
imgLeftImage = strImageLocation & rowNumber & "your logo.jpg"
lnkLeftLink = "your website address"

Dim strText, strRng

imgRightImage = strImageLocation & rowNumber & "optional right image"
lnkRightLink = "optional right link"
icoPhone = strImageLocation & "phone.ico"
icoMobile = strImageLocation & "mobile.ico"
icoFax = strImageLocation & "fax.ico"
icoMail = strImageLocation & "mail.ico"
Dim objWMI, objProcess, colProcesses, strSQL
Set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
strSQL = "SELECT * FROM Win32_Process WHERE Name='winword.exe'"
Set colProcesses = objWMI.ExecQuery(strSQL)
If colProcesses.Count > 0 Then
 WScript.Echo "Please save any open word documents BEFORE clicking OK on the message." & vbCrLf & _
     "The script will force close all open Word documents."
End If
Dim objWord, objDoc, objSel
Set objWord = WScript.CreateObject("Word.Application")
'objWord.Visible = True
Set objDoc = objWord.Documents.Add()
Set objSel = objWord.Selection
objSel.Style = "No Spacing"
With objSel
 .Font.Name = "Microsoft Sans Serif"
 .Font.Size = "12"
 .Font.Color = RGB(176,23,31)
 .Font.Italic = True
 .TypeText strTopMessage
 .InlineShapes.AddHorizontalLineStandard
 .Font.Italic = False
 .Font.Color = RGB(0,114,188)
 .EndKey 6, 0
End With
Dim objRange, objTable
Set objRange = objSel.Range
objDoc.Tables.Add objRange, 1, 3
Set objTable = objDoc.Tables(1)
With objTable
 .Spacing = 0
 .LeftPadding = 2
 .AutoFitBehavior(1)
End With
Dim objLeftImage, objRightImage
Set objLeftImage = objTable.Cell(1,1).Range.InlineShapes.AddPicture(imgLeftImage, LINK_TO_IMAGE, SAVE_TO_DOC)
objTable.Cell(1,1).Range.Hyperlinks.Add objLeftImage, lnkLeftLink
Set objRightImage = objTable.Cell(1,3).Range.InlineShapes.AddPicture(imgRightImage, LINK_TO_IMAGE, SAVE_TO_DOC)
objTable.Cell(1,1).Range.Hyperlinks.Add objRightImage, lnkRightLink
Dim rng
With objTable.Cell(1,2)
 Set rng = .Range
 rng.InsertAfter strName
 rng.InsertParagraphAfter
 rng.InsertAfter strTitle
 rng.InsertParagraphAfter
 If Not strDept = "" Then
  rng.InsertAfter strDept
  rng.InsertParagraphAfter
 End If
 rng.SetRange .Range.End -1, .Range.End -1
 rng.InlineShapes.AddPicture icoPhone, LINK_TO_IMAGE, SAVE_TO_DOC
 rng.SetRange .Range.End -1, .Range.End -1
 rng.InsertAfter " " & strPhone
 rng.InsertParagraphAfter
 If Not strMobile = "" Then
  rng.SetRange .Range.End -1, .Range.End -1
  rng.InlineShapes.AddPicture icoMobile, LINK_TO_IMAGE, SAVE_TO_DOC
  rng.SetRange .Range.End -1, .Range.End -1
  rng.InsertAfter " " & strMobile
  rng.InsertParagraphAfter
 End If
 If Not strFax = "" Then
  rng.SetRange .Range.End -1, .Range.End -1
  rng.InlineShapes.AddPicture icoFax, LINK_TO_IMAGE, SAVE_TO_DOC
  rng.SetRange .Range.End -1, .Range.End -1
  rng.InsertAfter " " & strFax
  rng.InsertParagraphAfter
 End if
 rng.SetRange .Range.End -1, .Range.End -1
 rng.InlineShapes.AddPicture icoMail, LINK_TO_IMAGE, SAVE_TO_DOC
 rng.SetRange .Range.End -1, .Range.End -1
 rng.InsertAfter " " & strMail1
 rng.InsertParagraphAfter
 If Not strMail2 = "" Then
  rng.SetRange .Range.End -1, .Range.End -1
  rng.InlineShapes.AddPicture icoMail, LINK_TO_IMAGE, SAVE_TO_DOC
  rng.SetRange .Range.End -1, .Range.End -1
  rng.InsertAfter " " & strMail2
  rng.InsertParagraphAfter
 End If
 rng.InsertAfter strAddress
 rng.InsertParagraphAfter
 rng.InsertAfter strMiddleMessage
End With
txtFormat(strName)
txtFormat(strTitle)
txtFormat(strDept)
txtFormat(strPhone)
txtFormat(strMobile)
txtFormat(strFax)
txtFormat(strMail1)
txtFormat(strMail2)
txtFormat(strAddress)
txtFormat(strMiddleMessage)
With objSel
 .EndKey 6, 0
 .Font.Size = 8
 .TypeText strBottomMessage
 .EndKey 6, 0
End With
Dim objEmail, objSignature, objEntries
Set objEmail = objWord.EmailOptions
Set objSignature = objEmail.EmailSignature
Set objEntries = objSignature.EmailSignatureEntries
objEntries.Add "ADSignature", objDoc.Range()
objSignature.NewMessageSignature = "ADSignature"
objSignature.ReplyMessageSignature = "ADSignature"
With objDoc
 .Saved = True
 .Close 0
End With
objWord.Quit
For Each objProcess In colProcesses
 objProcess.Terminate()
Next
Dim WshShell, WshEnvironment, objFSO, strFileName, objVCF
Set WshShell = WScript.CreateObject("WScript.Shell")
Set WshEnvironment = WshShell.Environment("process")
strFileName = WshEnvironment("USERPROFILE") & "\Application Data\Microsoft\Signatures\ADSignature_files\" & objUser.LastName & ", " & objUser.FirstName
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists(strFileName & ".vcf") Then objFSO.DeleteFile strFileName & ".vcf"
Set objVCF = objFSO.CreateTextFile(strFileName & ".vcf")
With objVCF
 .WriteLine "BEGIN:VCARD"
 .WriteLine "VERSION:2.1"
 .WriteLine "N;LANGUAGE=en-us:" & objUser.LastName & ";" & objUser.FirstName
 .WriteLine "FN:" & strName
 .WriteLine "ORG:" & strCompany & ";" & strDept
 .WriteLine "TITLE:" & strTitle
 .WriteLine "TEL;WORK;VOICE:" & strPhone
 If Not strMobile = "" Then .WriteLine "TEL;CELL;VOICE:" & strMobile
 If Not strFax = "" Then .WriteLine "TEL;WORK;FAX:" & strFax
 .WriteLine "ADR;WORK;PREF:;;" & objUser.StreetAddress & ";" & objUser.l & ";" & objUser.st & ";" & objUser.PostalCode & ";Canada"
 .WriteLine "LABEL;WORK;PREF;ENCODING=QUOTED-PRINTABLE:=0D=0A" & objUser.StreetAddress & "=0D=0A" & objUser.l & ", " & objUser.st & " " & objUser.PostalCode & ", Canada"
 .WriteLine "URL;WORK:" & lnkLeftLink
 .WriteLine "EMAIL;PREF;INTERNET:" & strMail1
 If Not strMail2 = "" Then .WriteLine "EMAIL;INTERNET:" & strMail2
 .WriteLine "END:VCARD"
End With
Dim regVCF_KEY, regVCF_SK, regSendPicture
regVCF_KEY = "HKCU\Software\Microsoft\Office\15.0\Outlook\Signatures\"
regVCF_SK = "HKCU\Software\Microsoft\Office\15.0\Outlook\Signatures\ADSignature"
If ADD_VCARD Then 
 WshShell.RegWrite regVCF_KEY, ""
 WshShell.RegWrite regVCF_SK, "AdSignature_files\" & objUser.LastName & ", " & objUser.FirstName & "","REG_SZ"
Else
 WshShell.RegDelete regVCF_SK
 WshShell.RegDelete regVCF_KEY
End If
regSendPicture = "HKCU\Software\Microsoft\Office\15.0\Outlook\Options\Mail\Send Pictures With Document"
WshShell.RegWrite regSendPicture, SEND_AS_LINK, "REG_DWORD"
Dim WMIUser, strDomainName, strUserName, WshNetwork, strWMISID
Set WshNetwork = WScript.CreateObject("WScript.Network")
strDomainName = WshNetwork.UserDomain 
strUserName = WshNetwork.UserName
Set WMIUser = GetObject("winmgmts:{impersonationLevel=impersonate}!/root/cimv2:Win32_UserAccount.Domain='" & strDomainName & "',Name='" & strUserName & "'")
strWMISID = WMIUser.SID
Dim strTempFile, regFile
strTempFile = WshShell.ExpandEnvironmentStrings("%temp%\Outlook.reg")
If objFSO.FileExists(strTempFile) Then objFSO.DeleteFile strTempFile
Set regFile = objFSO.CreateTextFile(strTempFile,True)
With regFile
 .WriteLine "Windows Registry Editor Version 5.00"
 .WriteLine ""
 .WriteLine "[HKEY_USERS\" & strWMISID & "\Software\Microsoft\Office\15.0\Common\MailSettings]"
 .WriteLine Chr(34) & "Template" & Chr(34) & "=hex(2):00,00"
 .WriteLine Chr(34) & "MarkCommentsWith" & Chr(34) & "=hex:00,00"
 .WriteLine Chr(34) & "NewTheme" & Chr(34) & "=" & Chr(34) & Chr(34)
 .Close
End With
WshShell.Run "regedit /S " & strTempfile & "", 0, True
objFSO.DeleteFile strTempFile
Set objFSO = Nothing
Set WshShell = Nothing
WScript.Quit
Sub txtFormat(strText)
 Set strRng = objDoc.Content
 With strRng.Find
  .Text = strText
  Do
   .Execute
   If .Found Then
    With strRng
     If strText = strName Then
      .Font.Size = 14
      .Font.Bold = True
      .Font.Color = RGB(0,0,0)
     ElseIf strText = strTitle Then
      .Font.Size = 8
     ElseIf strText = strDept Then
      .Font.Size = 8
     ElseIf strText = strPhone Then
      .Font.Size = 10
      .Font.Bold = True
     ElseIf strText = strMobile Then
      .Font.Size = 10
      .Font.Bold = True
     ElseIf strText = strFax Then
      .Font.Size = 10
      .Font.Bold = True
     ElseIf strText = strMail1 Then
      .Font.Size = 12
     ElseIf strText = strMail2 Then
      .Font.Size = 12
     ElseIf strText = strAddress Then
      .Font.Size = 7
     ElseIf strText = strMiddleMessage Then
      .Font.Size = 9
      .Font.Bold = True
      .Font.Italic = True
     End If
    End With
   End If
  Loop While .Found
 End With
End Sub
Function getMsg(strGroup, dbField)
 sqlQuery = "SELECT esigMsg FROM wdbEsigMes WHERE esigTopBottom='" & dbField & "' AND esigGroup IN('ALL','" & strGroup & "') AND ((esigStartDate < GetDate() AND esigEndDate > GetDate()) Or esigStartDate IS NULL) ORDER BY esigGroup, esigPriority"
 Set dbConnection = CreateObject("ADODB.Connection")
 Set dbCommand = CreateObject("ADODB.Command")
 dbConnString = "Provider=SQLOLEDB;Data Source=" & dbDataSource & ";Initial Catalog=" & dbCatalog & ";User ID=" & dbUser & ";Password=" & dbPassword & ""
  dbConnection.Open dbConnString
  dbCommand.ActiveConnection = dbConnection
  dbCommand.CommandText = sqlQuery
  Set dbRecord = dbCommand.Execute()
  If dbRecord.EOF Then
   getMsg = ""
  Else
   Do While Not dbRecord.EOF
    getMsg = dbRecord(0)
    dbRecord.MoveNext
   Loop
  End If
  Set dbConnection = Nothing
  Set dbCommand = Nothing
End Function