vbscript connecting to AD with alternate credential​s and build outlook signature question

Hello, I am trying to pass alternate AD credentials in a script and display user attributes (ie displayname, department, title).

I want to prompt for a username and password and then I want the script to display the attributes of that user back.  As of now, I just get an empty white popup box.  I do know that it is authenticating back to the domain controller as I see it in the event logs .

Ultimately what I want to do is build an Outlook signature based off of the returned values.  I can build the signature with no problems if the user is logged into the domain, However, most of my users log into the workstation only thus why I have to use alternate credentials and prompt for a username.

Here is what I have so far.  Any help is greatly appreciated.

 Option Explicit

Dim objRootDSE, strDNSDomain, adoCommand, adoConnection
Dim strBase, strFilter, strAttributes, strQuery, adoRecordset
Dim strDN, strUser, strPassword, objNS, strServer, strFullName
DIM objSysInfo, objUser, objRoot


strAttributes = "sAMAccountName,sn,givenName,title,department"
                                
Const ADS_SECURE_AUTHENTICATION = &H1
Const ADS_SERVER_BIND = &H200

' Specify a server (Domain Controller).
strServer = "wwfdc.wwf.local"

' Specify or prompt for credentials.
strUser = InputBox("Username")
strPassword = InputBox("Password")

' Determine DNS domain name. Use server binding and alternate
' credentials. The value of strDNSDomain can also be hard coded.
Set objNS = GetObject("LDAP:")
Set objRootDSE = objNS.OpenDSObject("LDAP://" & strServer & "/RootDSE", _
     strUser, strPassword, _
     ADS_SERVER_BIND Or ADS_SECURE_AUTHENTICATION)
strDNSDomain = objRootDSE.Get("defaultNamingContext")

' Use ADO to search Active Directory.
' Use alternate credentials.
Set adoCommand = CreateObject("ADODB.Command")
Set adoConnection = CreateObject("ADODB.Connection")
adoConnection.Provider = "ADsDSOObject"
adoConnection.Properties("User ID") = strUser
adoConnection.Properties("Password") = strPassword
adoConnection.Properties("Encrypt Password") = True
adoConnection.Properties("ADSI Flag") = ADS_SERVER_BIND _
     Or ADS_SECURE_AUTHENTICATION
adoConnection.Open "Active Directory Provider"
Set adoCommand.ActiveConnection = adoConnection

This is the script that works but the user has to be logged into the domain:

On Error Resume Next
Const WdLineBreak = 6
Dim intLen
Set objSysInfo = CreateObject("ADSystemInfo")
strUser = objSysInfo.UserName
Set objUser = GetObject("LDAP://" & strUser)
strName = objUser.FirstName & " " & objUser.LastName
strTitle = objUser.Title
strDepartment = objUser.department
strAddress = objUser.streetAddress
strCity = objUser.physicalDeliveryOfficeName
strState = objUser.st
strZip = objUser.postalCode
strCompany = objUser.Company
strDirect = objUser.homePhone
strFax = objUser.faxNumber
strEmail = objUser.mail
strPhone = objuser.telephoneNumber
strMobile = objuser.mobile

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.ParagraphFormat.SpaceAfter = 0

objSelection.Font.Size = "13.5"
objSelection.Font.Name = "Franklin Gothic Medium"
objSelection.TypeText strName
objSelection.Font.Size = "10"
objSelection.InsertBreak WdLineBreak
objSelection.TypeText strTitle
objSelection.InsertBreak WdLineBreak
objSelection.Font.Size = "10"
objSelection.TypeText strDepartment
objSelection.Font.Size = "9"
objSelection.InsertBreak WdLineBreak
objSelection.TypeText "City of NYC"
objSelection.InsertBreak WdLineBreak
objSelection.TypeText "P.O. Box 11111"
objSelection.InsertBreak WdLineBreak
objSelection.TypeText strAddress & "("&strZip&")"
objSelection.InsertBreak WdLineBreak
objSelection.TypeText "NYC, NY 11111"
objSelection.InsertBreak WdLineBreak
objSelection.TypeText "o: " & strPhone
objSelection.InsertBreak WdLineBreak
objSelection.TypeText strMobile
objSelection.InsertBreak WdLineBreak
objSelection.TypeText strFax
objSelection.InsertBreak WdLineBreak
objSelection.InsertBreak WdLineBreak
objSelection.TypeText strEmail
objSelection.InsertBreak WdLineBreak
objSelection.Hyperlinks.Add objSelection.Range, " " & strWWW & " ", , , strWWW, "_blank"

Set objSelection = objDoc.Range(objSelection.End-intLen,objSelection.End)
objSelection.Font.Name = "Franklin Gothic Medium"
objSelection.Font.Size = "9"
Set objSelection = objDoc.Range()

objSignatureEntries.Add "AD New Message", objSelection
objSignatureObject.NewMessageSignature = "AD New Message"
objDoc.Saved = True
objWord.Quit

On Error Resume Next
Set objSysInfo = CreateObject("ADSystemInfo")
strUser = objSysInfo.UserName
Set objUser = GetObject("LDAP://" & strUser)
strName = objUser.FirstName & " " & objUser.LastName
strTitle = objUser.Title
strCompany = objUser.Company
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.Size = "13.5"
objSelection.Font.Name = "Franklin Gothic Medium"
objSelection.TypeText strName
objSelection.Font.Size = "10"
objSelection.InsertBreak WdLineBreak
objSelection.TypeText strTitle
objSelection.InsertBreak WdLineBreak
objSelection.Font.Size = "10"
objSelection.TypeText strDepartment
objSelection.Font.Size = "9"
objSelection.InsertBreak WdLineBreak
objSelection.TypeText "City of NYC"
objSelection.InsertBreak WdLineBreak
objSelection.TypeText "P.O. Box 11111"
objSelection.InsertBreak WdLineBreak
objSelection.TypeText strAddress & "("&strZip&")"
objSelection.InsertBreak WdLineBreak
objSelection.TypeText "NYC, NY 11111"
objSelection.InsertBreak WdLineBreak
objSelection.TypeText "o: " & strPhone
objSelection.InsertBreak WdLineBreak
objSelection.TypeText strMobile
objSelection.InsertBreak WdLineBreak
objSelection.TypeText strFax
objSelection.InsertBreak WdLineBreak
objSelection.InsertBreak WdLineBreak
objSelection.TypeText strEmail
objSelection.InsertBreak WdLineBreak
objSelection.Hyperlinks.Add objSelection.Range, " " & strWWW & " ", , , strWWW, "_blank"
Set objSelection = objDoc.Range()
objSignatureEntries.Add "AD Reply", objSelection
objSignatureObject.ReplyMessageSignature = "AD Reply"
objDoc.Saved = True
objWord.Quit