Solved

outlook signature created from details pulled from Active directory

Posted on 2008-06-24
8
866 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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Find Ransomware Secrets With All-Source Analysis

Ransomware has become a major concern for organizations; its prevalence has grown due to past successes achieved by threat actors. While each ransomware variant is different, we’ve seen some common tactics and trends used among the authors of the malware.

 

Author Comment

by:MTSDL
Comment Utility
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
Comment Utility
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
Comment Utility
but many users will be using outlook as editor
0
 

Accepted Solution

by:
MTSDL earned 0 total points
Comment Utility
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

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

Suggested Solutions

Check out this infographic on what you need to make a good email signature that will work perfectly for your organization.
Sometimes Outlook might have problems sending a message. There may be various causes- corrupted PST, AV scanner etc. The message, instead of going to the Sent Items folder, sits in the Outbox indefinitely. To remove it you can use a free tool cal…
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
To add imagery to an HTML email signature, you have two options available to you. You can either add a logo/image by embedding it directly into the signature or hosting it externally and linking to it. The vast majority of email clients display l…

772 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

10 Experts available now in Live!

Get 1:1 Help Now