• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 1506
  • Last Modified:

VBScript: OLEDB Persistence Provider Error.

I am not a vbscript developer, I have a bare understanding of the language and what it does from knowledge of other languages (php, sql, xhtml, javascript etc).  I have found a vbscript online that connects to active directory and pulls down information into an xml file and saves it as html.

I have implemented this script for 10 other servers and terminal servers that all work correctly.  However this is the first time doing it on a 64bit Windows Server 2003.  All others have been 32 bit.

The script is not exactly as it was how I found it, I have modified it and added to it to meet my needs including some code that I wrote of my own (From basic vbscript understanding)

I am getting these errors:

Microsoft OLEDB Persistence Provider: Requested conversion is not supported.


Script: scriptname
Line: 53
Char: 1
Error: Requested conversion is not supported.
Code: 80040E1D
Source: Microsoft OLEDB Persistence Provider

Line 53 is this line:
rsAD.Save xml, adPersistXML

I've attached the entire code.  The issue is not with the XML file - the HTML file saves correctly but all the active directory information that should be there, is not there.  

The script works fine on a 32bit server.  

I have tried executing the script with both \system32\cscript and \syswow64\cscript
Const adPersistXML = 1
Const ForWriting = 2
'on error resume next
Dim WshShell, WshNet, rsAD, Com, ConAD, f
'We need to get details from attributes that are only available from the LDAP provider
'We cannot assume that the AdsSecurity.DLL is available on the client to retrieve our DN
'What we do know, is who we are (samaccountname) and that must be unique within a domain
Set WshNet = WScript.CreateObject("WScript.Network")
sUsername = WshNet.UserName
'Wscript.Network knows the Netbios Domain, but we might not know our DNS domainname
sPrefix = "LDAP://"
Set cont = GetObject(sPrefix & "rootdse")
sDN = cont.get("defaultnamingcontext")
'Alright - we are now prep'd to do a little search to get our adspath...
'We will open an ADO connection to AD
Set conAD = CreateObject( "ADODB.Connection" )
Set com = CreateObject( "ADODB.Command" )
'set the provider
conAD.Provider = "ADSDSOObject"
' Open a connection object
conAD.Open "Active Directory Provider"
Set Com.ActiveConnection = conADa
'what do we want to find - well our details...
sFilter = "(samaccountname=" & sUsername & ")"
'what do we need to know?
sAttributes = "givenname,sn,telephoneNumber,mail,streetAddress,l,st,postalCode,co,mobile,company,facsimileTelephoneNumber,title,department,wWWHomePage,ipphone,postOfficeBox"
'build the command string
Com.CommandText = "<" & sPrefix & sDN & ">;" & sFilter & ";" & sAttributes
' Set some preferences for search
Com.Properties( "Page Size" ) = 512
Com.Properties( "TimeOut" ) = 30 ' seconds
'Execute the query to get our objects from Active Directory.
Set rsAD = CreateObject("ADODB.Recordset")
Set rsAD = Com.Execute
If (Err.Number <> 0) Then
    WScript.Echo Err.Number, "on Execute"
End If
'WScript.Echo "LDAP user objects:" & rsAD.RecordCount
Set xml = CreateObject("Microsoft.XMLDOM")
rsAD.Save xml, adPersistXML
XML.async = False
Set xsl = CreateObject("Microsoft.XMLDOM")
XSL.async = False
'Load the XSL file. We keep it in the same path as the script, but it could be stored anyway. e.g. Webserver
XSL.load "\\king2003\netlogon\DeploySignatures\signature.xml"
XSL.preserveWhiteSpace = True
'Lets Save the signature file to disk to the profile - we are aiming for the Outlook signature path
Set WshShell = CreateObject("Wscript.Shell")
sUserProfile = WshShell.ExpandEnvironmentStrings("%appdata%")
sSignaturePath= sUserProfile & "\Microsoft\Signatures\"
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(sUserProfile & "\Microsoft") = False Then
      Set f = fso.CreateFolder(sUserProfile & "\Microsoft")
End If
If fso.FolderExists(sUserProfile & "\Microsoft\Signatures") = False Then
      Set f = fso.CreateFolder(sUserProfile & "\Microsoft\Signatures")
End If
sOutputfile = sSignaturePath & sUsername & ".htm"
Set FSO = CreateObject("Scripting.Filesystemobject")
Set f = fso.OpenTextFile(sOutputFile,ForWriting,True)
f.Write xml.transformNode(xsl)
'Make it the default signature, if no signature is set.
'Is not dependant on any specific Office Version
'Outlook needs to be CLOSED - so ensure this script is run before outlook is loaded.
Call SetDefaultSignature(sUsername, "")
	Dim objFSO
	Dim strNWStatLoc
	Dim strLocStatLoc
	Set objFSO = CreateObject("Scripting.FileSystemObject")
	strNWStatLoc = "\\king2003\netlogon\DeploySignatures\logo.gif"
	strLocStatLoc = sUserProfile & "\Microsoft\Signatures\"
	objFSO.CopyFile strNWStatLoc, strLocStatLoc, True
	Set objFSO = Nothing
Sub SetDefaultSignature(strSigName, strProfile)
    Const HKEY_CURRENT_USER = &H80000001
    strComputer = "."
        Set objreg = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")
        strKeyPath = "Software\Microsoft\Windows NT\" & "CurrentVersion\Windows " & "Messaging Subsystem\Profiles\"
        ' get default profile name if none specified
        If strProfile = "" Then
            objreg.GetStringValue HKEY_CURRENT_USER, _
              strKeyPath, "DefaultProfile", strProfile
        End If
        ' build array from signature name
        myArray = StringToByteArray(strSigName, True)
        strKeyPath = strKeyPath & strProfile & "\9375CFF0413111d3B88A00104B2A6676"
        objreg.EnumKey HKEY_CURRENT_USER, strKeyPath, arrProfileKeys
        For Each subkey In arrProfileKeys
            strsubkeypath = strKeyPath & "\" & subkey
            'On Error Resume Next
            objreg.SetBinaryValue HKEY_CURRENT_USER, strsubkeypath, "New Signature", myArray
            objreg.SetBinaryValue HKEY_CURRENT_USER, strsubkeypath, "Reply-Forward Signature", myArray
End Sub
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))
    StringToByteArray = arr
End Function
Public Function StringToHex4(Data)
    ' Input: normal text
    ' Output: four-character string for each character,
    '         e.g. "3204" for lower-case Russian B,
    '        "6500" for ASCII e
    ' Output: correct characters
    ' needs to reverse order of bytes from 0432
    Dim strAll
    For i = 1 To Len(Data)
        ' get the four-character hex for each character
        strChar = Mid(Data, i, 1)
        strTemp = Right("00" & Hex(AscW(strChar)), 4)
        strAll = strAll & Right(strTemp, 2) & Left(strTemp, 2)
    StringToHex4 = strAll
End Function

Open in new window

1 Solution
TawneyFollettAuthor Commented:
I Found the solution to my problem, it was that I added postOfficeBox to the attribute list and it doesn't seem to like it (This is odd though as I've added ipphone and l without any issues)

Featured Post

Become an Android App Developer

Ready to kick start your career in 2018? Learn how to build an Android app in January’s Course of the Month and open the door to new opportunities.

Tackle projects and never again get stuck behind a technical roadblock.
Join Now