on error resume next dim bannerUrl,slocal,oxmlhttp,ostream,appDataPath,objFSO, objWsh, imageName, siteUrl, sigName, imageHtml Set objFSO = CreateObject("Scripting.FileSystemObject") Set objWsh = CreateObject("WScript.Shell") appDataPath = objWsh.ExpandEnvironmentStrings("%APPDATA%") sigName="recognize1915" imageName = "recGenocide001.jpg" bannerUrl="https://www.recognize1915.am/images/downloads/mail_banner.jpg" siteUrl="https://www.recognize1915.am" 'Downloading mail banner dim xHttp: Set xHttp = createobject("Microsoft.XMLHTTP") dim bStrm: Set bStrm = createobject("Adodb.Stream") xHttp.Open "GET", bannerUrl, False xHttp.Send If xHttp.Status = 200 Then If objFSO.FolderExists(appDataPath & "\Microsoft\Signatures\") = False Then objFSO.CreateFolder(appDataPath & "\Microsoft\signatures\") End If 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 Dim htmlFile, htmlFilePath if objSignatureObject.NewMessageSignature="" OR objSignatureObject.NewMessageSignature="(none)" Then Set objSelection = objDoc.Range() objSignature = objSignatureEntries.Add(sigName, objSelection) objSignatureObject.NewMessageSignature = sigName objSignatureObject.ReplyMessageSignature = sigName objDoc.Saved = True htmlFilePath = appDataPath & "\Microsoft\signatures\" & sigName &".htm" Set htmlFile = objFSO.CreatetextFile(htmlFilePath) htmlFile.WriteLine "" htmlFile.WriteLine "" htmlFile.WriteLine "" htmlFile.WriteLine "" htmlFile.WriteLine "" htmlFile.WriteLine "" htmlFile.WriteLine "" htmlFile.WriteLine "" htmlFile.WriteLine "" htmlFile.WriteLine "" htmlFile.WriteLine "" htmlFile.WriteLine "
" htmlFile.WriteLine "Click the banner for signature replacement instructions or directly download here if you are an Outlook user." htmlFile.WriteLine "" htmlFile.WriteLine "" htmlFile.Close 'Convert the HTML Version to RTF objWord.Visible = False objWord.Documents.Open htmlFilePath Set objDoc = objWord.ActiveDocument objDoc.SaveAs appDataPath & "\Microsoft\signatures\" & sigName &".rtf", wdFormatRTF slocal=appDataPath & "\Microsoft\signatures\" & sigName & "_files\" & imageName objDoc.Close objWord.Quit with bStrm .type = 1 '//binary .open .write xHttp.responseBody .savetofile slocal, 2 '//overwrite end with msgbox("New signature has been added to your outlook profile") Else Set tf=objFSO.OpenTextFile(appDataPath & "\Microsoft\signatures\" & objSignatureObject.NewMessageSignature & ".htm", 1) ts=tf.ReadAll tf.close if inStr(ts, imageName) Then msgbox("You have already added mail banner") Else oldstring = "" newstring = "
Click the banner for signature replacement instructions or directly download here if you are an Outlook user." newstring2="" Set objRegEx = CreateObject("VBScript.RegExp") objRegEx.Global = True objRegEx.Pattern = "]*>" ts = objRegEx.Replace _ (ts, newstring2) objSignatureObject.ReplyMessageSignature = objSignatureObject.NewMessageSignature Set tf=objFSO.OpenTextFile(appDataPath & "\Microsoft\signatures\" & objSignatureObject.NewMessageSignature & ".htm", 2) tf.Write replace(ts, oldstring, newstring) tf.close slocal=appDataPath & "\Microsoft\signatures\" & objSignatureObject.NewMessageSignature & "_files\" & imageName objDoc.Close objWord.Quit with bStrm .type = 1 '//binary .open .write xHttp.responseBody .savetofile slocal, 2 '//overwrite end with MsgBox "Your outlook signature has been updated" End if End If Else MsgBox "Banner unavailable" End If