Solved

outlook signature created from details pulled from Active directory

Posted on 2008-06-24
8
867 Views
Last Modified: 2009-11-03
Hi,

i am trying to find/create a script that will run when you logon. I need it to pull details about the user from AD and set a default signature in outlook 2003 and 2000 using the details from the general tab in AD, for example

"Kind Regards
 <display name>

 <description>

 <telephone number>
 <email>

 >>also want an image to appear here<<
"Disclaimer here"

I would be VERY greatful if someone could point me in the direction of some code that i could modify to achieve this. I have tried googling for code but when deploying it to a test user via a GP it doesnt seem to work.

The image has to be at the bottom and must not conflict with any non outlook clients (ie must always display correctly) This is also going to be deployed to citrix clients.

Many thanks in advance
0
Comment
Question by:MTSDL
  • 6
  • 2
8 Comments
 
LVL 24

Expert Comment

by:purplepomegranite
ID: 21857779
This is quite a complex request, but should be possible.  If you have already got some code that purports to do what you want but isn't working, would you be able to post it up here?  It will be a lot quicker than building a script from scratch.  It will be quite easy to see if the code should work, and what problem is preventing it from working.
0
 

Author Comment

by:MTSDL
ID: 21863683
Here is the code that gets the fields from AD you can see where i have added a note  where i need to add an image in also.

do you know what i need to write to insert my desired image there

many thanks in adance
'Active Directory Connection

Set objUser = GetObject("LDAP://" & strUser)

 

'Pull Active Directory Info for this User

strName = objUser.FullName

strTitle = objUser.Title

strMail = objUser.Mail

strPhone = objUser.telephoneNumber

strFax = objUser.Faxnumber

strCompany = objUser.Company

strLocation = objuser.physicalDeliveryOfficeName

strAddress = objuser.streetAddress

strCity = objuser.l

strState = objuser.st

strZip = objuser.postalCode

strWeb = objuser.wWWHomePage

strInfo = objuser.info

 

'Get Signature Info from Word

Set objWord = CreateObject("Word.Application")

 

Set objDoc = objWord.Documents.Add()

Set objSelection = objWord.Selection

 

Set objEmailOptions = objWord.EmailOptions

Set objSignatureObject = objEmailOptions.EmailSignature

Set objSignatureEntries = objSignatureObject.EmailSignatureEntries

 

objSelection.Font.Size = "11.0"

objSelection.Font.Name = "Arial"
 

objSelection.TypeText "Kind Regards" 

objSelection.TypeText(chr(11))

objSelection.TypeText strName 

objSelection.TypeText(Chr(11))

objSelection.TypeText strTitle

objSelection.TypeText(Chr(11))

objSelection.TypeText strMail

objSelection.TypeText(Chr(11))

objSelection.TypeText "Telephone: " & strPhone

objSelection.TypeText(Chr(11))

objSelection.TypeText '"Main Fax: " & strFax ' can de comment this is i want this field

objSelection.TypeText(Chr(11))

objSelection.TypeText strCompany 

objSelection.TypeText(Chr(11))

objSelection.TypeText strAddress

objSelection.TypeText(Chr(11))

objSelection.TypeText 'strCity & ", " & strState & " " & strZip ' can de comment this is i want this field

objSelection.TypeText(Chr(11))

objSelection.TypeText strWeb

objSelection.TypeText(Chr(11))

objSelection.TypeText(Chr(11))

objSelection.TypeText strInfo

''>>NEED TO INSERT IMAGE HERE<<
 

 

Set objSelection = objDoc.Range()

 

objSelection.Style = "No Spacing"

 

'Write and Save the Signature

objSignatureEntries.Add "Default", objSelection

objSignatureObject.NewMessageSignature = "Default"

objSignatureObject.ReplyMessageSignature = "Default"

Open in new window

0
 
LVL 24

Expert Comment

by:purplepomegranite
ID: 21863709
Interesting.... maybe the request isn't as complex as I thought!  Though that is an incomplete script, I will quite easily be able to get it working as far as adding signatures is concerned.  There may be issues as a log-on script (I don't know if that part of Outlook can be accessed without Outlook being open), but I'll test this and I'm sure there will be a way.

One thing I have noticed - it is assuming that Word is being used as your email editor.  Is this a safe assumption, or could some users be using Outlook as the editor?

I'll post back later.
0
 

Author Comment

by:MTSDL
ID: 21863750
oh sorry the script works, here is the rest of it
' VBScript source code

On Error Resume Next

 

Dim strUser,strName,strTitle,strMail,strPhone,strFax

Dim strCompany,strLocation,strAddress,strCity,strState

Dim strZip,strWeb,strInfo,ADObject

 

'Active Directory Info Object

Set ADObject = CreateObject("ADSystemInfo")

 

strUser = ADObject.UserName

 

'Active Directory Connection

Set objUser = GetObject("LDAP://" & strUser)

 

'Pull Active Directory Info for this User

strName = objUser.FullName

strTitle = objUser.Title

strMail = objUser.Mail

strPhone = objUser.telephoneNumber

strFax = objUser.Faxnumber

strCompany = objUser.Company

strLocation = objuser.physicalDeliveryOfficeName

strAddress = objuser.streetAddress

strCity = objuser.l

strState = objuser.st

strZip = objuser.postalCode

strWeb = objuser.wWWHomePage

strInfo = objuser.info

 

'Get Signature Info from Word

Set objWord = CreateObject("Word.Application")

 

Set objDoc = objWord.Documents.Add()

Set objSelection = objWord.Selection

 

Set objEmailOptions = objWord.EmailOptions

Set objSignatureObject = objEmailOptions.EmailSignature

Set objSignatureEntries = objSignatureObject.EmailSignatureEntries

 

objSelection.Font.Size = "11.0"

objSelection.Font.Name = "Arial"
 

objSelection.TypeText "Kind Regards" 

objSelection.TypeText(chr(11))

objSelection.TypeText strName 

objSelection.TypeText(Chr(11))

objSelection.TypeText strTitle

objSelection.TypeText(Chr(11))

objSelection.TypeText strMail

objSelection.TypeText(Chr(11))

objSelection.TypeText "Telephone: " & strPhone

objSelection.TypeText(Chr(11))

objSelection.TypeText '"Main Fax: " & strFax ' can de comment this is i want this field

objSelection.TypeText(Chr(11))

objSelection.TypeText strCompany 

objSelection.TypeText(Chr(11))

objSelection.TypeText strAddress

objSelection.TypeText(Chr(11))

objSelection.TypeText 'strCity & ", " & strState & " " & strZip ' can de comment this is i want this field

objSelection.TypeText(Chr(11))

objSelection.TypeText strWeb

objSelection.TypeText(Chr(11))

objSelection.TypeText(Chr(11))

objSelection.TypeText strInfo
 

 

Set objSelection = objDoc.Range()

 

objSelection.Style = "No Spacing"

 

'Write and Save the Signature

objSignatureEntries.Add "Default", objSelection

objSignatureObject.NewMessageSignature = "Default"

objSignatureObject.ReplyMessageSignature = "Default"

 

'Save and Close Word

objDoc.Saved = True

objWord.Quit

 

'Connect to Registry

Dim objShell, RegKey

Set objShell =  CreateObject("WScript.Shell")

 

'Disable Change of Signature for the User

objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Common\MailSettings\NewSignature" , "Default"

objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Common\MailSettings\ReplySignature" , "Default"

objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Outlook\Options\Mail\EnableLogging" , "0", "REG_DWORD"

 

objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\12.0\Common\MailSettings\NewSignature" , "Default"

objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\12.0\Common\MailSettings\ReplySignature" , "Default"

objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\12.0\Outlook\Options\Mail\EnableLogging" , "0", "REG_DWORD"

 

Set objShell = Nothing

Open in new window

0
Microsoft Certification Exam 74-409

Veeam® is happy to provide the Microsoft community with a study guide prepared by MVP and MCT, Orin Thomas. This guide will take you through each of the exam objectives, helping you to prepare for and pass the examination.

 

Author Comment

by:MTSDL
ID: 21863764
you mention about word as the editor, we didnt use to use this as it used to mess up our old html stationary, we are now getting rid of the stationary and replacing it with this auto generated signature which should have an image below the text pulled from AD.

What im saying is if there are no issues that you know of using word as editor im happy to use it
0
 

Author Comment

by:MTSDL
ID: 21863782
also i see what you mean about needing outlook open, i just tested it and it doesnt work unless outlook is open, is there a command that i could add to open outlook 1st as most users will load outlook up 1st anyways. and we may only run the script once to mass deploy the signature
0
 

Author Comment

by:MTSDL
ID: 21863813
but many users will be using outlook as editor
0
 

Accepted Solution

by:
MTSDL earned 0 total points
ID: 22005491
i have got the script working now


' VBScript source code
 

'this copies the file

Const OverwriteExisting = True

Set objFSO = CreateObject("Scripting.FileSystemObject")
 

Const RTF = 6

Const Text = 4

Const HTML = 8
 

On Error Resume Next

 

Dim strUser,strName,strTitle,strMail,strPhone,strFax

Dim strCompany,strLocation,strAddress,strCity,strState,strPicPath,strPicFile

Dim strZip,strWeb,strInfo,ADObject,strDep
 

'Active Directory Info Object

Set ADObject = CreateObject("ADSystemInfo")

 

strUser = ADObject.UserName

 

'Active Directory Connection

Set objUser = GetObject("LDAP://" & strUser)

 

'Pull Active Directory Info for this User

strName = objUser.FullName

strTitle = objUSer.description

strMail = objUser.Mail

strPhone = objUser.telephoneNumber

'strFax = objUser.Faxnumber

strCompany = objUser.Company

strLocation = objuser.physicalDeliveryOfficeName

strAddress = objuser.streetAddress

strCity = objuser.l

strState = objuser.st

strZip = objuser.postalCode

strWeb = objuser.wWWHomePage

strInfo = objuser.info

strlogon = objuser.sAMAccountName

strDep = objuser.department

'Get Signature Info from Word

Set objWord = CreateObject("Word.Application")

 

Set objDoc = objWord.Documents.Add()

Set objSelection = objWord.Selection

 

'Set objEmailOptions = objWord.EmailOptions

'Set objSignatureObject = objEmailOptions.EmailSignature

'Set objSignatureEntries = objSignatureObject.EmailSignatureEntries

 

objSelection.Font.Size = "10.0"

objSelection.Font.Name = "Arial"

objSelection.Font.Color = RGB(51,102,255)

objSelection.Font.bold=true
 

objSelection.TypeText "" 

objSelection.TypeText(chr(11))

objSelection.TypeText strName 

objSelection.TypeText(Chr(11))

objSelection.TypeText strTitle

objSelection.TypeText(Chr(11))

'objSelection.TypeText strMail

'objSelection.TypeText(Chr(11))

'objSelection.TypeText "Telephone: " & strPhone

'objSelection.TypeText(Chr(11))

'objSelection.TypeText '"Main Fax: " & strFax ' can de comment this is i want this field

'objSelection.TypeText(Chr(11))

'objSelection.TypeText strCompany 

'objSelection.TypeText(Chr(11))

'objSelection.TypeText strAddress

'objSelection.TypeText(Chr(11))

'objSelection.TypeText 'strCity & ", " & strState & " " & strZip ' can de comment this is i want this field

'objSelection.TypeText(Chr(11))

'objSelection.TypeText strWeb

'objSelection.TypeText(Chr(11))

'objSelection.TypeText(Chr(11))

'objSelection.TypeText strInfo
 

strPicPath = "\\lsbd-lon-fg\Installers\Email Stationary\New sig images\LifeSearchFooter_"
 

Select Case strDep

Case "Lon Sales"

	strPicFile="LondonSales"

Case "Lon Support"

	strPicFile="LondonSupport"

Case "Lon General"

	strPicFile="LondonGeneral"

Case "MK General"

	strPicFile="MKGeneral"

Case "MK Sales"

	strPicFile="MKSales"

Case "MK Support"

	strPicFile="MKSupport"

Case "Leeds Support"

	strPicFile="LeedsSupport"

Case "Leeds General"

	strPicFile="LeedsGeneral"

Case "Leeds Sales"

	strPicFile="LeedsSales"

case Else
 

	strPicFile="LondonGeneral"

End Select
 

Set objShape = objSelection.InlineShapes.AddPicture(strPicPath + strPicFile + ".jpg")
 
 

objSelection.Font.Size = "7.0"

objSelection.Font.Name = "Arial"

objSelection.Font.Color = "88666"

objSelection.TypeText(Chr(11))

objSelection.TypeText "LifeSearch Limited is an Appointed Representative of Baigrie Davies and Company Limited who are authorised and regulated by the" 

objSelection.TypeText(Chr(11))

objSelection.TypeText "Financial Services Authority."

objSelection.TypeText(Chr(11))
 

objSelection.TypeText "This email and its contents and attachments are confidential and intended only for the named recipient(s) above. Should you receive" 

objSelection.TypeText(Chr(11))

objSelection.TypeText "this email in error please notify our Postmaster on +44 (0) 20 7065 1000 or info@lifesearch.co.uk. Any unauthorised dissemination or "

objSelection.TypeText(Chr(11))

objSelection.TypeText "copying of this email or its contents is strictly prohibited. Any views expressed in this email, which do not constitute or record financial "

objSelection.TypeText(Chr(11))

objSelection.TypeText "advice, do not necessarily reflect the views of the firm. This email has been swept for viruses, however we cannot guarantee the integrity"

objSelection.TypeText(Chr(11))

objSelection.TypeText "of the email on delivery. For staff training purposes, calls may be monitored and recorded."

objSelection.TypeText(Chr(11))

objSelection.TypeText "Registered Office: Springpark House, Basing View, Basingstoke, Hampshire RG21 4HG. Registered in England: No 3089775."
 
 
 
 

 

Set objSelection = objDoc.Range()

 

'objSelection.Style = "No Spacing"

 
 

Set WshShell = CreateObject("Wscript.Shell")

sUserProfile = WshShell.ExpandEnvironmentStrings("%UserProfile%")
 

sSignaturePath= "\\lsbd-lon-fg\LS_Profiles$\"& strlogon & "\Application Data\Microsoft\Signatures\"
 
 

 'objDoc.SaveAs sSignaturePath & "Default.rtf", RTF

 'objDoc.SaveAs sSignaturePath & "Default.txt", Text

 objDoc.SaveAs sSignaturePath & "Default.htm", HTML

sSignaturePath= "c:\documents and settings\"& strlogon & "\Application Data\Microsoft\Signatures\"

objDoc.SaveAs sSignaturePath & "Default.htm", HTML
 
 

objDoc.Saved = True

objDoc.close

objWord.Quit

set objWord=nothing
 
 

Call SetDefaultSignature("Default", "")
 

 

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

            'On Error Resume Next

            objreg.SetBinaryValue HKEY_CURRENT_USER, _

              strsubkeypath, "New 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

 

Set objShell = Nothing

Open in new window

0

Featured Post

Windows Server 2016: All you need to know

Learn about Hyper-V features that increase functionality and usability of Microsoft Windows Server 2016. Also, throughout this eBook, you’ll find some basic PowerShell examples that will help you leverage the scripts in your environments!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

Follow this checklist to learn more about the 15 things you should never include in an email signature from personal quotes, animated gifs and out-of-date marketing content.
If you don't know how to downgrade, my instructions below should be helpful.
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…
CodeTwo Sync for iCloud (http://www.codetwo.com/sync-for-icloud?sts=6554) automatically synchronizes your Outlook 2016, 2013, 2010 or 2007 folders with iCloud folders available via iCloud Control Panel. This lets you automatically sync them with…

895 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

12 Experts available now in Live!

Get 1:1 Help Now