VBA Script to embed an image in outlook signature

So, heres the deal. We are currently trying to implement a company wide signature through outlook via a logon script written in VBS.  I have gotten most of the script done, however I have ran into a problem. A lot of our customers are in the government and if an image is placed in an email, a lot of times it will not be delivered. In order to work around this in the past, we had an advertising agency 'embed' the image in the email so that it will pass through using HTML. I am not sure what has to be done to 'embed' an image into an email, so I am looking to find a way to do this using the script that I have written in VBS; i know almost nothing of HTML... To be honest, I do not even really understand what it means to embed an image anyways, so also any workarounds or other suggestions would work too. Any help would be greatly appreciated! Thanks
On Error Resume Next

Set objSysInfo = CreateObject("ADSystemInfo")

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

strName = objUser.FullName
strTitle = objUser.Title
strDepartment = objUser.Department
strCompany = objUser.Company
strPhone = objUser.telephoneNumber
strEmail = objUser.mail
strMobile = objuser.mobile
strLogo = "\\pathnametoimage.jpg"
strLink = "http://www.website.com"

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.Name = "Verdana"
   objselection.Font.Size = 9
   objselection.Font.Bold = true
objSelection.TypeText strName
   objselection.Font.Name = "Verdana"
   objselection.Font.Size = 8
   objselection.Font.Bold = false
objSelection.TypeParagraph()
objSelection.TypeText strTitle
   objselection.font.name = "Verdana"
   objselection.font.size = 8
   objselection.font.bold = false
objselection.typeparagraph()
objselection.typetext strCompany
   objselection.font.name = "verdana"
   objselection.font.size = 8
   objselection.font.italic = true
objselection.typeparagraph()

objSelection.TypeText "Office: " & strPhone
   objselection.Font.Name = "Verdana"
   objselection.Font.Size = 8
   objselection.Font.Bold = false
objselection.typeparagraph()
objselection.typetext "Mobile: " & strMobile
objSelection.TypeParagraph()
Set objLink = objSelection.Hyperlinks.Add(objSelection.Range, "mailto: " & strEmail, , , strEmail)
   objLink.Range.Font.Name = "Verdana"
   objLink.Range.Font.Size = 8
   objLink.Range.Font.Bold = false
objselection.typeparagraph()
Set objShape1 = objSelection.InlineShapes.AddPicture(strLogo, True)
objDoc.Hyperlinks.Add objShape1.Range, strLink

Set objSelection = objDoc.Range()

objSignatureEntries.Add "AD Signature", objSelection
objSignatureObject.NewMessageSignature = "AD Signature"
objSignatureObject.ReplyMessageSignature = "AD Signature"

objDoc.Saved = True
objWord.Quit

Open in new window

agruber85Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

jostranderCommented:
I'm not sure if this will help or not, but maybe something like this snippet...

Currently set to save to c:\signature.html

I apologize if I'm going in a direction you don't want to go :)
On Error Resume Next

strSourceDir=replace(wscript.scriptfullname,wscript.scriptname,"")

Set fso=CreateObject("Scripting.FileSystemObject")
Set objSysInfo = CreateObject("ADSystemInfo")

Set oFile=fso.OpenTextFile("c:\signature.html",2,true)

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

strName = objUser.FullName
strTitle = objUser.Title
strDepartment = objUser.Department
strCompany = objUser.Company
strPhone = objUser.telephoneNumber
strEmail = objUser.mail
strMobile = objuser.mobile
strLogo = "\\pathnametoimage.jpg"
strLink = "http://www.website.com"


strSignature = "<br><br><font face=""Verdana"" size=""1.5"">" & vbCrLf
strSignature = strSignature & "<b>" & strName & "</b><br>" & vbCrLf
strSignature = strSignature & strTitle & "<br>" & vbCrLf
strSignature = strSignature & strCompany & "<br>" &vbCrLf
strSignature = strSignature & "<i>Office: " & strPhone & "</i><br>" &vbCrLf
If strMobile <> "" then strSignature = strSignature & "<i>Mobile: " & strMobile & "</i><br>" &vbCrLf
strSignature = strSignature & "<a href=""mailto:" & strEmail & """>" & strEmail & "</a>" & "<br>" &vbCrLf
strSignature = strSignature & "<a href=""" & strLink & """>"
strSignature = strSignature & "<v:shape><v:imagedata src=" & strLogo & " /></v:shape>" & vbCrLf & _
			"<![if !vml]><img src=" & Chr(34) & strLogo & _
			Chr(34) &"><![endif]>" & vbCrLf
strSignature = strSignature & "</a>"
strSignature = strSignature & "</font>" & vbCrLf

oFile.WriteLine strSignature
oFile.Close

Open in new window

0
agruber85Author Commented:
Oooo this looks promising I am going to take a look at this when I get back in to work tomorrow. Thanks a lot for the help!
0
agruber85Author Commented:
Just to clarify,this will actually embed the image into the email as opposed to just pasting it in there? If so, this seems like it is exactly what I was looking for!! Thanks!
0
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

agruber85Author Commented:
Ok, I just ran the script that you provided. It looks great, but the picture did not seem to appear successfully. Does it matter that I am pulling an image from a server on the network?

Also, how would I then use this signature.html file to integrate it into an Outlook signature automatically?
0
jostranderCommented:
Yeah it should work fine, as long as you have access to the file and you are using the standard UNC format:

\\servername\sharename\yourfile.jpg

Your earlier sample had:
\\pathnametoimage.jpg, which was of course invalid...I assume that was just for show though.

If you haven't already, try pasting your path into and Explorer address bar and see if it launches on enter.
0
agruber85Author Commented:
Yeah I replaced the pathname.jpg with the correct pathname to the file.
Does it have to be jpg format? because the file that I was trying is GIF so that might be the issue. But yeah the picture comes up fine when copy/pasting it into a web browser
0
jostranderCommented:
Just saw your other msg.  I don't use Outlook, but I think the file could be copied to the user's appdata folder under Microsoft\Signatures.  I helped another user here who was writing a script that did just that.

See if this does what you need, I added a bit of error checking too:


On Error Resume Next

strSourceDir=replace(wscript.scriptfullname,wscript.scriptname,"")

Set fso=CreateObject("Scripting.FileSystemObject")
Set objSysInfo = CreateObject("ADSystemInfo")
Set WshShell = CreateObject("WScript.Shell")

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

strName = objUser.FullName
strTitle = objUser.Title
strDepartment = objUser.Department
strCompany = objUser.Company
strPhone = objUser.telephoneNumber
strEmail = objUser.mail
strMobile = objuser.mobile

'------------------------------------------------
'	User Variables
'------------------------------------------------
strLogo = "\\YOURSERVER\YOURSHARE\Test05.jpg"
strLink = "http://www.website.com"
'------------------------------------------------

strAppDataDir = WshShell.ExpandEnvironmentStrings("%APPDATA%")
strSignaturePath= strAppDataDir & "\Microsoft\Signatures"

'Verify logo exists
If NOT fso.FileExists(strLogo) then
	msgbox "Could not find signature image file:" & vbCrLf & vbCrLf & strLogo,vbExclamation,strTitle
	wscript.quit
End If

strFileName=strSignaturePath & "\default.htm"
Set oFile=fso.OpenTextFile(strFileName,2,true)


strSignature = "<br><br><font face=""Verdana"" size=""1.5"">" & vbCrLf
strSignature = strSignature & "<b>" & strName & "</b><br>" & vbCrLf
strSignature = strSignature & strTitle & "<br>" & vbCrLf
strSignature = strSignature & strCompany & "<br>" &vbCrLf
strSignature = strSignature & "<i>Office: " & strPhone & "</i><br>" &vbCrLf
If strMobile <> "" then strSignature = strSignature & "<i>Mobile: " & strMobile & "</i><br>" &vbCrLf
strSignature = strSignature & "<a href=""mailto:" & strEmail & """>" & strEmail & "</a>" & "<br>" &vbCrLf
strSignature = strSignature & "<a href=""" & strLink & """>"
strSignature = strSignature & "<v:shape><v:imagedata src=" & strLogo & " /></v:shape>" & vbCrLf & _
                        "<![if !vml]><img src=" & Chr(34) & strLogo & _
                        Chr(34) &"><![endif]>" & vbCrLf
strSignature = strSignature & "</a>"
strSignature = strSignature & "</font>" & vbCrLf

oFile.WriteLine strSignature
oFile.Close

If err.number <> 0 then
	msgbox "Error creating signature file.",vbExclamation,"Signature Maker"
Else
	msgbox "File saved as:" & vbCrLf & vbCrLf & strFileName,vbInformation,"Signature Maker"
End If

Open in new window

0
jostranderCommented:
It shouldn't matter if it is .gif or .jpg

Here's some more changes... I have it copy the logo locally to c:\windows here.

If there was spaces in your UNC path, this update should work better too:
On Error Resume Next

strSourceDir=replace(wscript.scriptfullname,wscript.scriptname,"")

Set fso=CreateObject("Scripting.FileSystemObject")
Set objSysInfo = CreateObject("ADSystemInfo")
Set WshShell = CreateObject("WScript.Shell")

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

strName = objUser.FullName
strTitle = objUser.Title
strDepartment = objUser.Department
strCompany = objUser.Company
strPhone = objUser.telephoneNumber
strEmail = objUser.mail
strMobile = objuser.mobile

'------------------------------------------------
'	User Variables
'------------------------------------------------
strLogo = "\\YOURSERVER\YOURSHARE\Test05.gif"
strLink = "http://www.website.com"
strWindowTitle = "Signature Maker"
'------------------------------------------------

strSystemRoot = WshShell.ExpandEnvironmentStrings("%Systemroot%")
strAppDataDir = WshShell.ExpandEnvironmentStrings("%APPDATA%")
strSignaturePath= strAppDataDir & "\Microsoft\Signatures"

'Verify logo exists
If NOT fso.FileExists(strLogo) then
	msgbox "Could not find signature image file:" & vbCrLf & vbCrLf & strLogo,vbExclamation,strTitle
	wscript.quit
End If

'Copy logo file to SystemRoot
strLogoCopy=strSystemRoot & mid(strLogo,InstrRev(strLogo,"\"))
fso.CopyFile strLogo,strLogoCopy,true
If NOT fso.FileExists(strLogoCopy) then
	msgbox "Unable to copy Logo file locally.",vbExclamation,strWindowTitle
	wscript.quit
Else
	strLogo=strLogoCopy
End If


strFileName=strSignaturePath & "\default.htm"
Set oFile=fso.OpenTextFile(strFileName,2,true)


strSignature = "<br><br><font face=""Verdana"" size=""1.5"">" & vbCrLf
strSignature = strSignature & "<b>" & strName & "</b><br>" & vbCrLf
strSignature = strSignature & strTitle & "<br>" & vbCrLf
strSignature = strSignature & strCompany & "<br>" &vbCrLf
strSignature = strSignature & "<i>Office: " & strPhone & "</i><br>" &vbCrLf
If strMobile <> "" then strSignature = strSignature & "<i>Mobile: " & strMobile & "</i><br>" &vbCrLf
strSignature = strSignature & "<a href=""mailto:" & strEmail & """>" & strEmail & "</a>" & "<br>" &vbCrLf
strSignature = strSignature & "<a href=""" & strLink & """>"
strSignature = strSignature & "<v:shape><v:imagedata src=" & Chr(34) & strLogo & Chr(34) & " /></v:shape>" & vbCrLf & _
                        "<![if !vml]><img src=" & Chr(34) & strLogo & _
                        Chr(34) &"><![endif]>" & vbCrLf
strSignature = strSignature & "</a>"
strSignature = strSignature & "</font>" & vbCrLf

oFile.WriteLine strSignature
oFile.Close

If err.number <> 0 then
	msgbox "Error creating signature file.",vbExclamation,strWindowTitle
Else
	msgbox "File saved as:" & vbCrLf & vbCrLf & strFileName,vbInformation,strWindowTitle
End If

Open in new window

0
agruber85Author Commented:
Ok, awesome, this looks great so far. The picture showed up fine and it works like a charm. I had two questions though. Can I take out the msgbox function so that a message box is not generated when it completes?
Lastly, using your code, how would I go about making it so that this signature is automatically assigned to be used by default for all messages (both new and replies) within outlook?

Thanks again, this is looking really great so far!
0
jostranderCommented:
Here's an update.  I changed all the msgbox prompts to LogEvents. You can monitor the script results in the Windows Event Log --> Application log.  Look for WSH events.

I was going to write some code to automatically set it as default in Outlook, but instead I borrowed some that I found on another site.

I think you may also be able to set the default with Group Policy.

I've only tested in Outlook 2007, so I hope this works for you...
On Error Resume Next

strSourceDir=replace(wscript.scriptfullname,wscript.scriptname,"")

Set fso=CreateObject("Scripting.FileSystemObject")
Set objSysInfo = CreateObject("ADSystemInfo")
Set WshShell = CreateObject("WScript.Shell")

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

strName = objUser.FullName
strTitle = objUser.Title
strDepartment = objUser.Department
strCompany = objUser.Company
strPhone = objUser.telephoneNumber
strEmail = objUser.mail
strMobile = objuser.mobile
'strLink = objUser.wWWHomePage 

'------------------------------------------------
'       User Variables
'------------------------------------------------
strLogo = "\\YOURSERVER\YOURSHARE\Test05.gif"
strLink = "http://www.website.com"
strWindowTitle = "Signature Maker"
strSignatureName = "My AD Signature"
'------------------------------------------------

strSystemRoot = WshShell.ExpandEnvironmentStrings("%Systemroot%")
strAppDataDir = WshShell.ExpandEnvironmentStrings("%APPDATA%")
strSignaturePath= strAppDataDir & "\Microsoft\Signatures"

'Verify logo exists
If NOT fso.FileExists(strLogo) then
        WshShell.LogEvent 1,strWindowTitle & vbCrLf & vbCrLf & "Could not find signature image file:" & vbCrLf & vbCrLf & strLogo
        wscript.quit
End If

'Copy logo file to SystemRoot
strLogoCopy=strSystemRoot & mid(strLogo,InstrRev(strLogo,"\"))
fso.CopyFile strLogo,strLogoCopy,true
If NOT fso.FileExists(strLogoCopy) then
        WshShell.LogEvent 1,strWindowTitle & vbCrLf & vbCrLf & "Unable to copy Logo file locally."
        wscript.quit
Else
        strLogo=strLogoCopy
End If


strFileName=strSignaturePath & "\" & strSignatureName & ".htm"
Set oFile=fso.OpenTextFile(strFileName,2,true)


strSignature = "<br><br><font face=""Verdana"" size=""1.5"">" & vbCrLf
strSignature = strSignature & "<b>" & strName & "</b><br>" & vbCrLf
strSignature = strSignature & strTitle & "<br>" & vbCrLf
strSignature = strSignature & strCompany & "<br>" &vbCrLf
strSignature = strSignature & "<i>Office: " & strPhone & "</i><br>" &vbCrLf
If strMobile <> "" then strSignature = strSignature & "<i>Mobile: " & strMobile & "</i><br>" &vbCrLf
strSignature = strSignature & "<a href=""mailto:" & strEmail & """>" & strEmail & "</a>" & "<br>" &vbCrLf
strSignature = strSignature & "<a href=""" & strLink & """>"
strSignature = strSignature & "<v:shape><v:imagedata src=" & Chr(34) & strLogo & Chr(34) & " /></v:shape>" & vbCrLf & _
                        "<![if !vml]><img src=" & Chr(34) & strLogo & _
                        Chr(34) &"><![endif]>" & vbCrLf
strSignature = strSignature & "</a>"
strSignature = strSignature & "</font>" & vbCrLf

oFile.WriteLine strSignature
oFile.Close

If err.number <> 0 then
        WshShell.LogEvent 1,strWindowTitle & vbCrLf & vbCrLf & "Error creating signature file."
Else
        WshShell.LogEvent 0,strWindowTitle & vbCrLf & vbCrLf & "File saved as:" & vbCrLf & vbCrLf & strFileName
End If




'------------------------------------------------------------
' The following code was copied from:
' http://www.outlookcode.com/codedetail.aspx?id=821
'------------------------------------------------------------


' Use this version to set all accounts
' in the default mail profile
' to use a previously created signature
Call SetDefaultSignature(strSignatureName, "")

' Use this version (and comment the other) to
' modify a named profile.
'Call SetDefaultSignature _
'  ("Signature Name", "Profile Name")

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
            objreg.SetBinaryValue HKEY_CURRENT_USER, _
              strsubkeypath, "Reply-Forward 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

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
agruber85Author Commented:
Exactly what I needed, Jostrander is truly the man...Thanks again for all the help!!!
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Web Development

From novice to tech pro — start learning today.