Go Premium for a chance to win a PS4. Enter to Win


VBScript: OLEDB Persistence Provider Error.

Posted on 2008-10-16
Medium Priority
Last Modified: 2013-11-29
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

Question by:TawneyFollett

Accepted Solution

TawneyFollett earned 0 total points
ID: 22818642
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

Free Tool: Path Explorer

An intuitive utility to help find the CSS path to UI elements on a webpage. These paths are used frequently in a variety of front-end development and QA automation tasks.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Wouldn't it be nice if objects in Active Directory automatically moved into the correct Organizational Units? This is what AutoAD aims to do and as a plus, it automatically creates Sites, Subnets, and Organizational Units.
Unable to change the program that handles the scan event from a network attached Canon/Brother printer/scanner. This means you'll always have to choose which program handles this action, e.g. ControlCenter4 (in the case of a Brother).
With the advent of Windows 10, Microsoft is pushing a Get Windows 10 icon into the notification area (system tray) of qualifying computers. There are many reasons for wanting to remove this icon. This two-part Experts Exchange video Micro Tutorial s…
This is used to tweak the memory usage for your computer, it is used for servers more so than workstations but just be careful editing registry settings as it may cause irreversible results. I hold no responsibility for anything you do to the regist…

885 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question