none
VBS email signature scrpting issues RRS feed

  • Question

  • Hi,

    My company name is changing and we need to change the logon script we are using to create signatures.  I am a novice when it comes to scripting, but nonetheless I have been tasked with spearheading this change.

    I modified the script we have but the new email signature the marketing group provided has multiple fonts and sizes and inline bullets.

    I am trying to get the bullets to show up where they are in the marketing materials as well as some guidance on the best way to to incorporate internet source images for links to FB, Twitter and Instagram.

    the code I have

    On Error Resume Next
    
    
    
    
    Dim qQuery, objSysInfo, objuser
    Dim FullName, EMail, Title, PhoneNumber, MobileNumber, FaxNumber, OfficeLocation, Department
    Dim web_address, FolderLocation, HTMFileString, StreetAddress, Town, State, Company
    Dim ZipCode, PostOfficeBox, UserDataPath, LogoPath,LogoPath1, LogoLink,LogoLink1
    Dim MyString
    
    Set objSysInfo = CreateObject("ADSystemInfo")
    objSysInfo.RefreshSchemaCache
    qQuery = "LDAP://" & objSysInfo.Username
    Set objuser = GetObject(qQuery)
    
    LogoPath = "http://Static.wixstatic.com/media/c8cfd6_fd013b7c20464e0d9f1dfe50441017f7%7Emv2.png/v1/fill/w_32%2Ch_32%2Clg_1%2Cusm_0.66_1.00_0.01/c8cfd6_fd013b7c20464e0d9f1dfe50441017f7%7Emv2.png"
    LogoLink = "http://www.sga.net"
    
    FullName = objuser.displayname
    EMail = objuser.mail
    Company = objuser.Company
    Title = objuser.title
    PhoneNumber = objuser.TelephoneNumber
    FaxNumber = objuser.FaxNumber
    OfficeLocation = objuser.physicalDeliveryOfficeName
    StreetAddress = objuser.streetaddress
    PostofficeBox = objuser.postofficebox
    Department = objUser.Department
    ZipCode = objuser.postalcode
    State = objuser.st
    City = objuser.l
    MobileNumber = objuser.TelephoneMobile
    
    Dim objShell, RegKey03, RegKey07, RegKey10, RegKey14, RegKey16, RegKeyParm
    Set objShell = CreateObject("WScript.Shell")
    RegKey03 = "HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Common\General"
    RegKey07 = "HKEY_CURRENT_USER\Software\Microsoft\Office\12.0\Common\General"
    RegKey10 = "HKEY_CURRENT_USER\Software\Microsoft\Office\14.0\Common\General"
    RegKey14 = "HKEY_CURRENT_USER\Software\Microsoft\Office\15.0\Common\General"
    RegKey16 = "HKEY_CURRENT_USER\Software\Microsoft\Office\16.0\Common\General"
    
    RegKey16 = RegKey16 & "\Signatures"
    RegKey14 = RegKey14 & "\Signatures"
    RegKey10 = RegKey10 & "\Signatures"
    RegKey07 = RegKey07 & "\Signatures"
    RegKey03 = RegKey03 & "\Signatures"
    
    objShell.RegWrite RegKey03 , "AD_Sig"
    objShell.RegWrite RegKey07 , "AD_Sig"
    objShell.RegWrite RegKey10 , "AD_Sig"
    objShell.RegWrite RegKey14 , "AD_Sig"
    objShell.RegWrite RegKey16 , "AD_Sig"
    
    
    UserDataPath = ObjShell.ExpandEnvironmentStrings("%appdata%")
    FolderLocation = UserDataPath &"\Microsoft\AD_Sig\"
    
    HTMFileString = FolderLocation & Company & ".htm"
    RTFFileString = FolderLocation & Company & ".rtf"
    TXTFileString = FolderLocation & Company & ".txt"
    
    objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Common\MailSettings\NewSignature" , Company
    objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Common\MailSettings\ReplySignature" , Company
    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" , Company
    objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\12.0\Common\MailSettings\ReplySignature" , Company
    objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\12.0\Outlook\Options\Mail\EnableLogging" , "0", "REG_DWORD"
    objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\14.0\Common\MailSettings\NewSignature" , Company
    objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\14.0\Common\MailSettings\ReplySignature" , Company
    objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\14.0\Outlook\Options\Mail\EnableLogging" , "0", "REG_DWORD"
    objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\15.0\Common\MailSettings\NewSignature" , Company
    objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\15.0\Common\MailSettings\ReplySignature" , Company
    objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\15.0\Outlook\Options\Mail\EnableLogging" , "0", "REG_DWORD"
    objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\16.0\Common\MailSettings\NewSignature" , Company
    objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\16.0\Common\MailSettings\ReplySignature" , Company
    objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\16.0\Outlook\Options\Mail\EnableLogging" , "0", "REG_DWORD"
    
    
    Dim objFS1
    Set objFS1 = CreateObject("Scripting.FileSystemObject")
    If (objFS1.FolderExists(FolderLocation)) Then
    Else
    	Call objFS1.CreateFolder(FolderLocation)
    End If
    
    Dim objFSO
    Dim objFile,afile
    Dim aQuote
    aQuote = Chr(34)
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    Set AFile = objFSO.GetFile(HTMFileString)
    aFile.Delete
    Set AFile = objFSO.GetFile(RTFFileString)
    aFile.Delete
    Set AFile = objFSO.GetFile(TXTFileString)
    aFile.Delete
    
    Set objFile = objFSO.CreateTextFile(HTMFileString,True)
    objFile.Close
    Set objFile = objFSO.OpenTextFile(HTMFileString, 2)
    
    'objfile.write "____________________________________________________________</br>" &vbCrLF
    
    '  changing the font size for name for the new email signature - '
    
    'this is a place holder for the logo, waitingfor url
    'objfile.write
    
    objfile.write "</div><div style='font-size:12pt; font-family: Avant Garde, Avantgarde, Century Gothic, CenturyGothic, AppleGothic, sans-serif; color: #D3222A; Font-weight: bold; font-style: oblique'>" &vbCrLF
    objfile.write FullName 
    
    
    
    objfile.write "</div><div style='font-size:9pt; font-family: Avant Garde, Avantgarde, Century Gothic, CenturyGothic, AppleGothic, sans-serif; color: #000000'>" &vbCrLF
    
    'removing company section
    'objfile.write "</div><div style='font-size:10pt;  font-family: arial; color: #1F497D; font-weight: bold'>" &vbCrLF
    'objfile.write Company & "<br>" &vbCrLF
    'objfile.write "</div><div style='font-size:9pt;  font-family: arial; color: #1F497D;'>" &vbCrLF
    
    If Title <> "" Then
    	objfile.write Title & "<br>" &vbCrLF
    'deleting this section
    'Else
    '	objfile.write "<br><br>" &vbCrLF
    End If
    
    If Department <> "" Then
    	objfile.write  Department & "<br>" &vbCrLF
    End If
    objfile.write StreetAddress & "& #8226; Or & bull; &nbsp;" & City & ", " & State & " " & ZipCode & "<br>" &vbCrLF
    objfile.write "Direct: " & OfficeLocation &  "& #8226; Or & bull; &nbsp;" 
    If PhoneNumber>0 Then
    	objfile.write "Mobile: " & PhoneNumber & " <br>" &vbCrLF
    End If
    objfile.write Email & "<br>" &vbCrLF
    objfile.write MyString = "800.555.5555" & "<br>" &vbCrLF
    objfile.write web_address = "http://InProduction.net" & "<br>" &vbCrLF
    
    'removing the line below
    'objfile.write "<div><a href='" & LogoLink & "'><img alt='SGA Logo'  src='" & LogoPath & "' width='110' height='44'></a>"
    
    'objfile.write "<a href="https://twitter.com/SGA_1974"><img width="20" height="20" nosend="1" alt="Twitter" src="http://www.sga.net/images/files/image/twittericon.png" /></a>&nbsp;" &
    		'<a href="https://www.facebook.com/SGAproductionservices?fref=ts"><img width="20" height="20" style="padding:0px" nosend="1" alt="Facebook" src="http://www.sga.net/images/files/image/facebookicon.png" /></a>	
    	
    
    
    objfile.write "</div>" &vbCrLF
     
    objFile.Close
    
    Set objFile = objFSO.CreateTextFile(RTFFileString,True)
    objFile.Close
    Set objFile = objFSO.OpenTextFile(RTFFileString, 2)
     
    objfile.write "{\rtf1\ansi\ansicpg1252\deff0"
    objfile.write "{\fonttbl"
    objfile.write "{\f0\fswiss\fcharset0\fprq2\fttruetype Arial;}"
    objfile.write "{\f1\fswiss\fcharset0\fprq2\ftnil Webdings;}}"
    objfile.write "{\colortbl"
    objfile.write "\red0\green0\blue0;"
    objfile.write "\red255\green255\blue255;"
    objfile.write "\red0\green0\blue128;"
    objfile.write "\red0\green128\blue0;}"
    objfile.write "\kerning0\cf0\ftnbj\fet2\ftnstart1\ftnnar\aftnnar\ftnstart1\aftnstart1\aenddoc\revprop3{\info\uc1}\deftab720\viewkind1\paperw12240\paperh15840\margl1440\margr1440\widowctrl"
    objfile.write "\sectd\sbknone\colsx360\pgncont\ltrsect"
    objfile.write "\pard\plain\ltrpar\ql\s31\itap0{\s31\cf2\f0\fs24\b\lang1033{\*\listtag0}\ltrch " & FullName  & "}{\s31\cf2\f0\fs24\b\lang1033{\*\listtag0}\par}"
    objfile.write "\pard\plain\ltrpar\ql\s31\itap0{\s31\cf2\f0\fs24\b\lang1033{\*\listtag0}\ltrch " & Title  & "}{\s31\cf0\cf2\f0\fs24\b\lang1033{\*\listtag0}\par}"
    objfile.write "\pard\plain\ltrpar\ql\s31\itap0{\s31\cf2\f0\fs24\b\lang1033{\*\listtag0}\ltrch " & Company  & "}{\s31\cf0\cf2\f0\fs24\b\lang1033{\*\listtag0}\par}"
    objfile.write "\pard\plain\ltrpar\ql\s31\itap0{\s31\cf0\f0\fs20\b\lang1033{\*\listtag0}\ltrch Office: " & OfficeLocation  & "}{\s31\cf0\f0\fs20\b\lang1033{\*\listtag0}\par}"
    If PhoneNumber  > 0 Then
    	objfile.write "\pard\plain\ltrpar\ql\s31\itap0{\s31\cf0\f0\fs20\b\lang1033{\*\listtag0}\ltrch Cell: " & PhoneNumber  & "}{\s31\cf0\f0\fs20\b\lang1033{\*\listtag0}\par}"
    End If
    If FaxNumber > 0 Then
    objfile.write "\pard\plain\ltrpar\ql\s31\itap0{\s31\cf0\f0\fs20\b\lang1033{\*\listtag0}\ltrch Fax: " & FaxNumber  & "}{\s31\cf0\f0\fs20\b\lang1033{\*\listtag0}\par}"
    End If
     
    objFile.Close
    
    Set objFile = objFSO.CreateTextFile(TXTFileString,True)
    objFile.Close
    Set objFile = objFSO.OpenTextFile(TXTFileString, 2)
     
    objfile.write FullName & vbCrLf
    objfile.write Title & vbCrLf
    objfile.write Company & vbCrLf
    If Not isEmpty(OfficeLocation) Then
    	objfile.write "Phone: " & OfficeLocation & vbCrLf
    End If
    If FaxNumber > 0 Then
    	objfile.write "Fax: " & FaxNumber & vbCrLf
    End If
    If PhoneNumber > 0 Then
    	objfile.write "Cell: " & PhoneNumber  & vbCrLf
    End If
    
    objfile.write vbCrLf
    objFile.Close
    
    Call SetDefaultSignature(Company,"")
    
    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\"
    If strProfile = "" Then
    objreg.GetStringValue HKEY_CURRENT_USER, _
    strKeyPath, "DefaultProfile", strProfile
    End If
    myArray = StringToByteArray(strSigName, True)
    strKeyPath = strKeyPath & strProfile & _
    "\9375CFF0413111d3B88A00104B2A6676"
    objreg.EnumKey HKEY_CURRENT_USER, strKeyPath, _
    arrProfileKeys
    For Each subkey In arrProfileKeys
    strsubkeypath = strKeyPath & "\" & subkey
    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)
    Dim strAll
    For i = 1 To Len(Data)
    
    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

    I have double checked AD and the street addr is correct.

    thank you in advance for your help.


    • Edited by schwa1970 Thursday, August 10, 2017 1:21 PM
    • Moved by Steve Fan Friday, August 11, 2017 5:52 AM
    Thursday, August 10, 2017 1:18 PM

All replies

  • Hi,

    Welcome to the Microsoft Office for IT Professionals Outlook forum. This forum is for general questions and feedback related to Microsoft Outlook. Since your questions is more related to VBS, I'll move it to a more appropriate forum:

    https://social.msdn.microsoft.com/Forums/en-us/home?forum=isvvba

    The reason why we recommend posting appropriately is you will get the most qualified pool of respondents, and other partners who read the forums regularly can either share their knowledge or learn from your interaction with us. Thank you for your understanding.

    Regards,

    Steve Fan


    Please remember to mark the replies as answers if they helped.

    If you have feedback for TechNet Subscriber Support, contact tnmff@microsoft.com.

    Friday, August 11, 2017 5:46 AM