Solved

outlook signature created from details pulled from Active directory

Posted on 2008-06-24
8
878 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 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
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 

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
 

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

Creating Instructional Tutorials  

For Any Use & On Any Platform

Contextual Guidance at the moment of need helps your employees/users adopt software o& achieve even the most complex tasks instantly. Boost knowledge retention, software adoption & employee engagement with easy solution.

Question has a verified solution.

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

This article lists the top 5 free OST to PST Converter Tools. These tools save a lot of time for users when they want to convert OST to PST after their exchange server is no longer available or some other critical issue with exchange server or impor…
This article will help to fix the below error for MS Exchange server 2010 I. Out Of office not working II. Certificate error "name on the security certificate is invalid or does not match the name of the site" III. Make Internal URLs and External…
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…
Many of my clients call in with monstrous Gmail overloading issues with Outlook. A quick tip is to turn off the All Mail and Important folders from synching. Here is a quick video I made to show you how to turn off these and other folders in Gmail s…

623 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