Подпись автоответ для простых текстовых писем

Question

В настоящее время я использую VBS для установки подписи HTML для новых писем / ответов. это сценарий

Я хочу установить txtreply.txt в качестве ответа по умолчанию на электронные письма txt. Я даже не могу выбрать файл из внешнего вида.

Option Explicit

On Error Resume Next


    Dim qQuery, objSysInfo, objuser, strComputer, objWMIService, colProcessList, objProcess
    Dim FullName, EMail, Title, PhoneNumber, MobileNumber, FaxNumber, OfficeLocation,                 Department, Firstname, Lastname, HeadNumber

    Dim web_address, web_address_pl, FolderLocation, HTMFileString,HTMFileString2,HTMFileString3         StreetAddress, Town, State, Company, gptw_link, gptw_img
    Dim ZipCode, PostOfficeBox, UserDataPath
    Dim linkedin_link, linkedin_img

    ' Closing outlook
    '==========================================================
    strComputer = "."
    Set objWMIService = GetObject("winmgmts:" _
        & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
    Set colProcessList = objWMIService.ExecQuery _
        ("SELECT * FROM Win32_Process WHERE Name = 'OUTLOOK.EXE'")
    For Each objProcess in colProcessList
        objProcess.Terminate()
    Next
    WScript.Sleep 1000

    ' Read LDAP(Active Directory)
    '==========================================================
    Set objSysInfo = CreateObject("ADSystemInfo")
    'objSysInfo.RefreshSchemaCache
    qQuery = "LDAP://" & objSysInfo.Username
    Set objuser = GetObject(qQuery)

    FullName = objuser.displayname
    Firstname = objuser.Firstname
    Lastname = objuser.Lastname
    EMail = objuser.mail
    Company = objuser.Company
    Title = objuser.title
    HeadNumber = ""
    PhoneNumber = objuser.TelephoneMobile
    FaxNumber = objuser.FaxNumber
    OfficeLocation = objuser.physicalDeliveryOfficeName
    StreetAddress = objuser.streetaddress
    PostofficeBox = objuser.postofficebox
    Department = objUser.Department
    ZipCode = objuser.postalcode
    Town = objuser.l
    MobileNumber = objuser.TelephoneMobile

    Dim objShell, RegKey, RegKeyParm
    Set objShell = CreateObject("WScript.Shell")
    RegKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Common\General"
    RegKey = RegKey & "\Signatures"
    objShell.RegWrite RegKey , "Signatures"
    UserDataPath = ObjShell.ExpandEnvironmentStrings("%appdata%")
    FolderLocation = UserDataPath &"\Microsoft\Signatures\"
    HTMFileString = FolderLocation & "Newmail.htm"
    HTMFileString2 = FolderLocation & "Reply.htm"
    HTMFileString3 = FolderLocation & "txtreply.txt."

    ' Ingen rettigheder for brugeren i at ændre signaturen.
    '==========================================================
    ' Outlook 2010
    objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\14.0\Common\MailSettings\NewSignature" , "Newmail"
    objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\14.0\Common\MailSettings\ReplySignature" , "Reply"
    objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\14.0\Outlook\Options\Mail\EnableLogging" , "0", "REG_DWORD"
    ' Outlook 2013
    objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\15.0\Common\MailSettings\NewSignature" , "Hartmanns"
    objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\15.0\Common\MailSettings\ReplySignature" , "Hartmanns_Reply"
    objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\15.0        \Outlook\Options\Mail\EnableLogging" , "0", "REG_DWORD"

    ' KOntroller om signatur biblioteket eksistere, opret hvis ikke
    '==========================================================
    Dim objFS1
    Set objFS1 = CreateObject("Scripting.FileSystemObject")
    If (objFS1.FolderExists(FolderLocation)) Then
    Else
        Call objFS1.CreateFolder(FolderLocation)
    End if

    ' Opret signatur filen
    '==========================================================
    Dim objFSO
    Dim objFile,objFile2,objFile3,afile
    Dim aQuote, aColon
    Dim objCitatFile, strText, arrCitat, x
    aQuote = chr(34)
    aColon = chr(58)

    ' Opbyg HTML fil struktur
    '==========================================================
    Set objFSO = CreateObject("Scripting.FileSystemObject")

    ' Slet andre signatur filer
    ' Disse filer er automatisk oprettet af Outlook 2003, 2007 & 2010
    '==========================================================
    Set AFile = objFSO.GetFile(Folderlocation&"Newmail.rtf")
    'aFile.Delete
    Set AFile = objFSO.GetFile(Folderlocation&"Newmail.txt")
    'aFile.Delete

    Set objFile = objFSO.CreateTextFile(HTMFileString,True)
    objFile.Close
    Set objFile = objFSO.OpenTextFile(HTMFileString, 2)

    objfile.write "<!DOCTYPE HTML PUBLIC " & aQuote & "-//W3C//DTD HTML 4.0 Transitional//EN" & aQuote & ">" & vbCrLf
    objfile.write "<HTML><HEAD><TITLE>" 

    the new mail content

    objfile.write "</body></HTML>" & vbCrLf

    objfile.Close

    ' Skriv besvar signatur
    ' =========================================================

    Set AFile = objFSO.GetFile(Folderlocation&"Reply.rtf")
    aFile.Delete
    Set AFile = objFSO.GetFile(Folderlocation&"Reply.txt")
    aFile.Delete

    Set objFile2 = objFSO.CreateTextFile(HTMFileString2,True)
    objFile2.Close
    Set objFile2 = objFSO.OpenTextFile(HTMFileString2, 2)

    objfile2.write "<!DOCTYPE HTML PUBLIC " & aQuote & "-//W3C//DTD HTML 4.0 Transitional//EN" &         aQuote & ">" & vbCrLf
    objfile2.write "<HTML>
    the reply email
    objfile2.write "</body></HTML>" & vbCrLf
    objfile2.close


    ' Skriv Plain tekst besvar signatur
    ' =========================================================
    Set AFile = objFSO.GetFile(Folderlocation&"txtreply.rtf")
    'aFile.Delete
    Set AFile = objFSO.GetFile(Folderlocation&"txtreply.htm")
    'aFile.Delete

    Set objFile3 = objFSO.CreateTextFile(HTMFileString3,True)
    objFile3.Close
    Set objFile3 = objFSO.OpenTextFile(HTMFileString3, 2)

    objfile3.write "<font size=3></font><br /><br />"

    objfile3.write "<font size=3><b></font></b><br>" 

    objfile3.write "<font size=3><b></b><br /></font>" 

    objfile3.write "<font size=3></font><br /><br /></font>"

    objfile3.write "<font size=3>Please consider the environment before printing this email or its attachments</font>"

    objfile3.close

    ' Læs outlook profilen og sæt signaturen  som default
    ' =========================================================

    Call SetDefaultSignature("newmail","")
    Call SetDefaultReplyForwardSignature("Reply","")

    Sub SetDefaultSignature(strSigName, strProfile)
        Dim objreg, strKeyPath, myArray, arrProfileKeys, subkey, strsubkeypath

        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\"
            ' Find profil navn, hvis ikke det er defineret
            If strProfile = "" Then
                objreg.GetStringValue HKEY_CURRENT_USER, _
                  strKeyPath, "DefaultProfile", strProfile
            End If
            ' Byg array fra signatur navne
            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
            Next
        'Else
        '    strMsg = "Please shut down Outlook before " & _
        '             "running this script."
        '    MsgBox strMsg, vbExclamation, "SetDefaultSignature"
        End If
       End Sub
       'Reply_Forward
       Sub SetDefaultReplyForwardSignature(strSigName, strProfile)
        Dim objreg, strKeyPath, myArray, arrProfileKeys, subkey, strsubkeypath

        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\"
                    ' Find profil navn, hvis ikke det er defineret
            If strProfile = "" Then
                objreg.GetStringValue HKEY_CURRENT_USER, _
                  strKeyPath, "DefaultProfile", strProfile
            End If
            ' Byg array fra signatur navne
            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, "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()

        Dim strQuery, colProcesses

        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, intLen, i
        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, strChar, strTemp, i
        For i = 1 To Len(Data)
            ' Konverter hver karakter (4) til hex ?#!" :)
            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

если я создаю текстовый файл в папке \Microsoft\Signatures, он отображается в Outlook, но я не могу создать файл с помощью сценария. Проблема в том, что мне нужно создать подпись.txt на 100 пользователей.