Help with VBS script to pull data and make into XML for Dayforce import

[jscharfenberg]

Hey all,

I'm very new to VBS and i am having a hard time figuring out what is going wrong with this old VBS script. It's supposed to simply connect to LDAP, which i tested the user and pw and then pull some items and make an XML report that looks like this....

<Employee>
<XRefCode>0123456</XRefCode>
<EmployeeNumber>0123456</EmployeeNumber>
<FirstName>John</FirstName>
<LastName>Doe</LastName>
<ContactInformation>
<ContactInformationTypeXrefCode>BusinessEmail</ContactInformationTypeXrefCode>
<EffectiveStart>2020-09-30</EffectiveStart>
<ElectronicAddress>jdoe@emailaddress.com</ElectronicAddress>
</ContactInformation>
</Employee>


Seems simple, but as of a few months it stopped working.

Now the report comes out blank with only the header looking like this...

<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?>

Any help would be wonderful as i'm not a vbs person.

Here is the script....


Dim sProgname
Dim sProgPath
Dim sProgdesc
Dim sVersion
Dim sTitle
Dim sINIFileName
Dim sMsg
Dim sResp
Dim sFilePath
Dim sOutfile

Dim sEmplID
Dim sFirstName
Dim sLastName
Dim sEmail
Dim sDateTransDate

Const ForReading = 1
Const ForWriting = 2

sProgname = wscript.ScriptName
sProgname = left(sProgname,InStrRev(sProgname,".")-1)
sProgdesc = "Company.com LDAP to Dayforce Email Sync"
sVersion = "V1.3 - 11/13/2017"
sTitle = sProgname & " " & sProgdesc & " " & sVersion
sINIFileName = wscript.ScriptFullName
sINIFileName = left(sINIFilename,InStrRev(sINIFilename,".")-1) & ".ini"
sProgPath = left(sINIFilename,InStrRev(sINIFilename,"\")-1)
sFilePath = "C:\folder\"
sOutfile = sFilePath & "\BusinessEmail.xml"
sMsg = ""

' -- DisplayMsg Popup
Dim ws
Dim btncode
set ws = WScript.CreateObject("WScript.Shell")

Dim objTextFileOut
Dim iOutCnt

Dim oDS
Dim oFS
Dim oOU
Dim oOUDN
Dim sLDAPServer
Dim sUser
Dim sPassword
Dim sCN
Dim sDN
Dim sOUDNQuery
Dim sLastCN

CONST ADS_SECURE_AUTHENTICATION = &H0001
CONST ADS_USE_ENCRYPTION = &H0002
CONST ADS_USE_SSL = &H0002
CONST ADS_READONLY_SERVER = &H0004
CONST ADS_NO_AUTHENTICATION = &H0010
CONST ADS_FAST_BIND = &H0020
CONST ADS_USE_SIGNING = &H0040
CONST ADS_USE_SEALING = &H0080
CONST ADS_USE_DELEGATION = &H0100
CONST ADS_SERVER_BIND = &H0200

Dim arrCSV
Dim dictValidation
Set dictValidation = CreateObject("Scripting.Dictionary")

' -- Main Logic
Call GetDateTransDate
Call LoadValidation(sFilePath & "\SIG_EmployeeValidationExtract.csv")
Call OpenOutput
Call WriteXMLHeader
Call DumpLDAPUserInfo
Call WriteXMLTrailer
Call ProgramTermination
Wscript.Quit

Sub DumpLDAPUserInfo
Dim MyiOUcnt
Dim MyioUsercnt
Dim MyarrCols
Dim MysKey
Dim MysEmail
' Insert code securely
sLDAPServer = "company.com"
sUser = "0123456"
sPassword = "Password1"
sCN = "/CN=" & sUser
sDN = "CN=" & sUser & ",OU=Users,DC=Company,DC=com"
sOUDNQuery = "LDAP://company.com/OU=Users,DC=Company,DC=com"

Set oDS = GetObject("LDAP:")
Set oOUDN = oDS.OpenDSObject( _
sOUDNQuery, _
sUser, _
sPassword, _
ADS_SECURE_AUTHENTICATION + ADS_SERVER_BIND)
sMsg = oOUDN.Class & vbCrLf & sOUDNQuery & vbCrLf & _
"Click OK to Continue ..."
Call DisplayMsg(sMsg,5,vbInformation)
MyiOUcnt = 0
MyioUsercnt = 0
sLastCN = ""
For each oOU in oOUDN
MyiOUcnt = MyiOUcnt + 1
MysKey = oOU.cn
If dictValidation.Exists(MysKey) Then
MyarrCols = Split(dictValidation(MysKey),"|")
sEmplID = MysKey
sFirstName = MyarrCols(10)
sLastName = MyarrCols(11)
sEmail = MyarrCols(9)
MysEmail = oOU.mail
If (oOU.mail <> "") AND (lcase(oOU.mail) <> lcase(sEmail)) Then
' If MyioUsercnt < 10 Then
' sMsg = oOU.cn & vbCrLf & _
' oOU.displayName & vbCrLf & _
' oOU.givenName & vbCrLf & _
' oOU.sn & vbCrLf & _
' oOU.mail & vbCrLf & _
' "Old email: " & sEmail
' Call DisplayMsg(sMsg,2,vbInformation)
' End If
Call WriteOutput
MyioUsercnt = MyioUsercnt + 1
End If
sLastCN = oOU.cn
End If
Next
sMsg = "oOU count=" & CStr(MyiOUcnt) & vbCrLf & _
"oUser count=" & Cstr(MyioUsercnt) & vbCrLf & _
"Output count=" & Cstr(iOutcnt)
End Sub

' Open Output file - Overwrite if necessary
Sub OpenOutput
Set oFS = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set objTextFileOut = oFS.CreateTextFile(sOutfile, True)
If Err.number <> 0 Then
WScript.Echo Err.Description & " Err#" & Cstr(Err.number) & vbCrLf & _
"Openning " & sOutFile & vbCrLf
Call ProgramTermination
Exit Sub
End If
On Error Goto 0
iOutCnt = 0
End Sub

Sub WriteXMLHeader
objTextFileOut.Writeline "<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?>"
objTextFileOut.Writeline "<EmployeeImport>"
End Sub

Sub WriteXMLTrailer
objTextFileOut.Writeline "</EmployeeImport>"
End Sub

Sub WriteOutput
If oOU.mail <> "" Then
objTextFileOut.Writeline " <Employee>"
objTextFileOut.Writeline " <XRefCode>" & sEmplID & "</XRefCode>"
objTextFileOut.Writeline " <EmployeeNumber>" & sEmplID & "</EmployeeNumber>"
objTextFileOut.Writeline " <FirstName>" & sFirstName & "</FirstName>"
objTextFileOut.Writeline " <LastName>" & sLastName & "</LastName>"
objTextFileOut.Writeline " <ContactInformation>"
objTextFileOut.Writeline " <ContactInformationTypeXrefCode>BusinessEmail</ContactInformationTypeXrefCode>"
objTextFileOut.Writeline " <EffectiveStart>" & sDateTransDate & "</EffectiveStart>"
objTextFileOut.Writeline " <ElectronicAddress>" & oOU.mail & "</ElectronicAddress>"
objTextFileOut.Writeline " </ContactInformation>"
objTextFileOut.Writeline " </Employee>"
iOutcnt = iOutcnt + 1
End If
End Sub

Sub LoadValidation(sMyValFilename)
Dim MyObjFSO
Dim MyObjTextFileIn
Dim MysData
Dim MysKey
Dim Myi
Dim MyArray

Set MyObjFSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set MyobjTextFileIn = MyobjFSO.OpenTextFile(sMyValFilename, ForReading, False)
If Err.number <> 0 Then
WScript.Echo Err.Description & " Err#" & Cstr(Err.number) & vbCrLf & _
"Openning " & sMyValFilename & vbCrLf
Call ProgramTermination
Exit Sub
End If
On Error GoTo 0
Do
MysData = MyObjTextFileIn.Readline
If len(MysData) Then
Call ParseCSV(MysData)
MysData = Join(arrCSV,"|")
MyArray = Split(MysData,"|",2)
MysKey = MyArray(0)
If Ubound(MyArray) > 0 Then MysData = MyArray(1) Else MysData = ""
dictValidation.add MysKey, MysData
End If
Loop While MyobjTextFileIn.AtEndOfStream <> True
MyobjTextFileIn.Close
End Sub

Sub ProgramTermination
If Not (objTextFileOut is Nothing) Then
objTextFileOut.Close
set objTextFileOut = Nothing
End If
WScript.Echo sMsg & vbcrlf & _
"* End of "& sProgname & " *"
WScript.quit
End Sub

Sub ParseCSV(MysData)
Dim MysColData
Dim MyInQuotes
Dim iCSVIdx

arrCSV = split(MysData,",")
For iCSVIdx = 0 to Ubound(arrCSV)
arrCSV(iCSVIdx) = ""
Next
MysData = MySData & ","
iCSVIdx = 0
MyInQuotes = False
Do While len(MYsData) > 0
MysColData = left(MysData,1)
MysData = mid(MysData,2)
Select Case MysColData
Case Chr(34)
MyInQuotes = not (MyInQuotes)
Case ","
If MyInQuotes = True Then
arrCSV(iCSVIdx) = arrCSV(iCSVIdx) & MysColData
Else
iCSVIdx = iCSVIdx + 1
' If len(MysData) > 1 Then
' arrCSV(iCSVIdx) = ""
' End If
End If
Case Else
arrCSV(iCSVIdx) = arrCSV(iCSVIdx) & MysColData
End Select
Loop
End Sub

Sub GetDateTransDate
sDateTransDate = DatePart("yyyy",Now()) & "-" & _
Right("0" & DatePart("m",Now()),2) & "-" & _
Right("0" & DatePart("d",Now()),2)
End Sub

Sub DisplayMsg(MysMsg,MyiWait,MyiType)
btncode = -1
ws.AppActivate sTitle
btncode = ws.popup (MysMsg,MyiWait,sTitle,MyiType or 1)
Select Case btncode
Case 1
Case 2
sMsg = MysMsg & " - Aborted by User Request ..."
Call ProgramTermination
End Select
End Sub