If xResult = 6 Then
    strUserMail = InputBox("Укажите адрес эл. почты:", "Текст заголовка")
    If Len(strUserMail) > 0 Then
        On Error Resume Next
        strUserName =split(strUserMail,"@")(1)
          objTrans.Set ADS_NAME_TYPE_NT4, strNetBIOSDomain & "\" & strUserName 
          strTemp = objTrans.Get(ADS_NAME_TYPE_1179)
        If Err.Number = 0 Then
            strForwardingAddress = strTemp
        Else
            Err.Clear
        End If
        On Error GoTo 0
    End If
End If

'...
Set objWShell = CreateObject("WScript.Shell")
xResult = objWShell.Popup("Будете указывать свой адрес эл. почты?", 30, "Текст заголовка", 4 + 32)
Set objWShell = Nothing
If xResult = 6 Then
    strUserMail = InputBox("Укажите адрес эл. почты:", "Текст заголовка")
    If Len(strUserMail) > 0 Then
        Set objConnection = CreateObject("ADODB.Connection")
        objConnection.Provider = "ADsDSOObject"
        objConnection.Open "Active Directory Provider"
        Set objCommand = CreateObject("ADODB.Command")
        Set objCommand.ActiveConnection = objConnection
        objCommand.CommandText = "SELECT distinguishedName FROM 'LDAP://" & strDNSDomain & _
                                "' WHERE objectCategory='Person' And objectClass='User' And mail='" & _
                                strUserMail & "'"
        objCommand.Properties("Page Size") = 1000
        objCommand.Properties("Timeout") = 30 
        objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE 
        Set objRSet = objCommand.Execute
        Select Case objRSet.RecordCount
            Case 0: MsgBox "Указанный адрес не найден.", vbExclamation
            Case 1
                objRSet.MoveFirst
                strForwardingAddress = objRSet.Fields("distinguishedName").Value
            Case Else: MsgBox "Указанный адрес не уникален.", vbExclamation
        End Select
        Set objRSet = Nothing
        Set objCommand = Nothing
        objConnection.Close
        Set objConnection = Nothing
    End If
End If
'...

Строка: 38
Символ: 9
Ошибка: указанный домен не существует или к нему невозможно подключиться.
Код: 8007054В
Источник: (null)

Set objFSO = CreateObject("Scripting.FileSystemObject")
set WshShell = WScript.CreateObject("WScript.Shell")
Set objNetwork = CreateObject("Wscript.Network")
strName = objNetwork.UserName

Set objRootDSE = GetObject("LDAP://RootDSE")

strDNSDomain = objRootDSE.Get("defaultNamingContext")
Const ADS_NAME_INITTYPE_DOMAIN = 1
Const ADS_NAME_TYPE_NT4 = 3
Const ADS_NAME_TYPE_1179 = 1
Set objTrans = CreateObject("NameTranslate")
objTrans.Init ADS_NAME_TYPE_NT4, strDNSDomain
objTrans.Set ADS_NAME_TYPE_1179, strDNSDomain
strNetBIOSDomain = objTrans.Get(ADS_NAME_TYPE_NT4)
strNetBIOSDomain = Left(strNetBIOSDomain, Len(strNetBIOSDomain) - 1)
objTrans.Init ADS_NAME_INITTYPE_DOMAIN, strNetBIOSDomain
objTrans.Set ADS_NAME_TYPE_NT4, strNetBIOSDomain & "\" & strName 
strUserDN = objTrans.Get(ADS_NAME_TYPE_1179)
Set objUser = GetObject("LDAP://" & strUserDN)


strForwardingAddress = "CN=Admintest,OU=Test,DC=domain,DC=biz"



Const ADS_NAME_TYPE_USER_PRINCIPAL_NAME = 9
objTrans.Init ADS_NAME_INITTYPE_DOMAIN, strNetBIOSDomain
Set objWShell = CreateObject("WScript.Shell")
xResult = objWShell.Popup("Будете указывать свой адрес эл. почты?", 30, "Текст заголовка", 4 + 32)
Set objWShell = Nothing
If xResult = 6 Then
    strUserMail = InputBox("Укажите адрес эл. почты:", "Текст заголовка")
    If Len(strUserMail) > 0 Then
        On Error Resume Next
        objTrans.Set ADS_NAME_TYPE_USER_PRINCIPAL_NAME, strUserMail
        strTemp = objTrans.Get(ADS_NAME_TYPE_1179)
        If Err.Number = 0 Then
            strForwardingAddress = strTemp
        Else
            Err.Clear
        End If
        On Error GoTo 0
    End If
End If

WScript.Echo strTemp

objUser.altRecipient = strForwardingAddress
objUser.deliverAndRedirect = TRUE
objUser.SetInfo


WScript.Echo "Переадресация установлена"

Const ADS_NAME_TYPE_USER_PRINCIPAL_NAME = 9
'...
objTrans.Init ADS_NAME_INITTYPE_DOMAIN, strNetBIOSDomain
'...
Set objWShell = CreateObject("WScript.Shell")
xResult = objWShell.Popup("Будете указывать свой адрес эл. почты?", 30, "Текст заголовка", 4 + 32)
Set objWShell = Nothing
If xResult = 6 Then
    strUserMail = InputBox("Укажите адрес эл. почты:", "Текст заголовка")
    If Len(strUserMail) > 0 Then
        On Error Resume Next
        objTrans.Set ADS_NAME_TYPE_USER_PRINCIPAL_NAME, strUserMail
        strTemp = objTrans.Get(ADS_NAME_TYPE_1179)
        If Err.Number = 0 Then
            strForwardingAddress = strTemp
        Else
            Err.Clear
        End If
        On Error GoTo 0
    End If
End If