×
INTELLIGENT WORK FORUMS
FOR COMPUTER PROFESSIONALS

Contact US

Log In

Come Join Us!

Are you a
Computer / IT professional?
Join Tek-Tips Forums!
  • Talk With Other Members
  • Be Notified Of Responses
    To Your Posts
  • Keyword Search
  • One-Click Access To Your
    Favorite Forums
  • Automated Signatures
    On Your Posts
  • Best Of All, It's Free!

*Tek-Tips's functionality depends on members receiving e-mail. By joining you are opting in to receive e-mail.

Posting Guidelines

Promoting, selling, recruiting, coursework and thesis posting is forbidden.

Students Click Here

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

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

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

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

Red Flag This Post

Please let us know here why this post is inappropriate. Reasons such as off-topic, duplicates, flames, illegal, vulgar, or students posting their homework.

Red Flag Submitted

Thank you for helping keep Tek-Tips Forums free from inappropriate posts.
The Tek-Tips staff will check this out and take appropriate action.

Reply To This Thread

Posting in the Tek-Tips forums is a member-only feature.

Click Here to join Tek-Tips and talk with other members! Already a Member? Login


Close Box

Join Tek-Tips® Today!

Join your peers on the Internet's largest technical computer professional community.
It's easy to join and it's free.

Here's Why Members Love Tek-Tips Forums:

Register now while it's still free!

Already a member? Close this window and log in.

Join Us             Close