Solved

VBScript: OLEDB Persistence Provider Error.

Posted on 2008-10-16
3
1,443 Views
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.

and

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 XML,XSL, FSO

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

 

 

	'Cleanup

	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

        Next

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))

    Next

    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)

    Next

    StringToHex4 = strAll

End Function

Open in new window

0
Comment
Question by:TawneyFollett
3 Comments
 
LVL 1

Accepted Solution

by:
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)
0

Join & Write a Comment

Resolve DNS query failed errors for Exchange
Restoring deleted objects in Active Directory has been a standard feature in Active Directory for many years, yet some admins may not know what is available.
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…
Get a first impression of how PRTG looks and learn how it works.   This video is a short introduction to PRTG, as an initial overview or as a quick start for new PRTG users.

746 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

Need Help in Real-Time?

Connect with top rated Experts

9 Experts available now in Live!

Get 1:1 Help Now