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
No comments :
Post a Comment