Solved

modify script to export xml data into .csv/html/txt  format

Posted on 2008-06-20
9
813 Views
Last Modified: 2012-06-21
Hello Exports,
Can someone please assist me in making this script work to export xml data in different formats. At the moment it is only exporting data into .csv format.
I would like to have rest of the script independant to the format, I mean ideally I would want to create one function for each format, so that tomorrow if the client comes back and want some other export format I would only  need to create another function without doing any more changes to the rest of the script.
Please can you look into the attached and see if this makes any sense to you.
Thanks for your help
Regards
Sam
0
Comment
Question by:newbie27
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 7
  • 2
9 Comments
 
LVL 8

Author Comment

by:newbie27
ID: 21836009

''###############################################################################
' Reads XML Database and exports selected fields into CSV formats
 
' FUNCTIONS: AddChildElement/AddNewNode/CheckArgs/CheckJacketFile/CleanAuthor/CleanXML/DeleteFile/DisplayDate/DisplayTime/ExtractXMLField/FindFilePath/GetArguments/GetChildNodes/GetDelimitedPhrases/GetLoadFiles/GetNumberOfFiles/GetNumberOfFolders/GetXML/IndexThisFile/InsertImage/IsIn/LoadAuthorHash/LoadCSV/LoadFormatHash/LoadMapHash/LoadRoleHash/LoadStatusHash/LoadXML/LoadXmlDoc/Padz/PrettyDate/PrintHash/ReadFile/RemoveChildElement/RemoveFromIndexThisFile/SaveNode/SetRegistryDefault/SortItOut/Trunc/WriteFile/WriteRecord/XMLField/
'###############################################################################
' Constants
Const ForReading = 1, ForWriting = 2, ForAppending = 8
 
' Variables
Dim LOGDIR, LOGFILE, REJECTFILE, REJECTDIR, FLAGGEDFILE, DELETESDIR, LogNameDefault, ReportStep, rCount, MaxFileCount, UpdCount, DelCount, AddCount, RejCount, DelNFCount
Dim SaveSwitchVersion, DestinationServer, SavedChildNodes
Dim RefNo, Collection, Record, Node, XMLDoc, FilesToIndexFile, FilesToRemoveFile
Dim MapHash, AuthorHash, FormatHash, StatusHash, RoleHash
Dim WriteRecordTime, FindFileTime, MassageKeysTime, SetHashTime, MapHashTime, WriteBlobTime, FirstSortTime, SecondSortTime, WriteFilesTime
Dim OutFile, Separator
 
' Declare Argument Variables for GetArguments()
Dim OutFileName,EhausNodeName,SearchQuery,OutExtension,OutFolder,KeyFields,ExcludeList,DataFolder,IndexFolder,RootFolder,LoadFolder,LoadFormat,LoadType,FilePattern,SiteName,Password,Username,QuietMode,WebFlag
Dim engine, sj
 
' Objects
set engine = CreateObject("dtSearchEngine6.Server")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set XmlDoc = CreateObject("MSXML2.DOMDocument")
 
' Settings
LogNameDefault = "EXPORT-DATA"
ReportStep = 1000
'RefNo = "ref_no"
'Collection = ""
'Record = "record"
 
' Action >
 
	x = MainProcess()
	msg("")
	if x = true then
		msg("Script finished successfully.")
	Else
		msg("Script failed.")
	End if
 
	'Set fso = Nothing
	
' > Finish
'*******************************************************************************
Function MainProcess ()
Dim i, x
 
	MainProcess = false
 
'Retrieve the arguments.	
	GetArguments()
 
' Set up Logfile
	If LogName = "" then LogName = LogNameDefault
	LOGDIR = "E:\tbp\logs"
	LOGFILE = ucase(LogName) & "_" & Replace(DisplayDate, "/", "") & ".log"
	
' How is the File to be formatted?
	if Ucase(LoadFormat) = "TAB" Then 
		Separator = VBTAB 
	ElseIf LoadFormat = "" Then
		Separator = ","
	Else
		Separator = LoadFormat
	End if    
	
 
	If OutExtension = "" Then OutExtension = "dat"
	If Right(OutFolder, 1) <> "\" Then OutFolder = OutFolder & "\"	'"
	If DataFolder <> "" Then
		If Right(DataFolder, 1) <> "\" Then DataFolder = DataFolder & "\"	'"
	End If
  If OutFileName = "" Then
		OutFile = OutFolder & "" & UCase(SiteName) & "_EXPORT_" & Replace(DisplayDate, "/", "") & "." & OutExtension	'"
	Else
		OutFile = OutFolder & OutFileName & "." & OutExtension
	End If
	
	msg("")
	msg("STARTING " & LogName & " - " & DisplayDate)
	'msg("Log file will be written to: [" & LOGDIR & "]")
	msg("Log file will be: [" & LOGFILE & "]")
	msg("Out File: [" & OutFile & "]")
 
'
	msg("")
	ShowArgs("")
		
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
' OK Ready to R&R
 
	If DataFolder <> "" Then
		If FilePattern <> "" Then
			x = GetLoadFiles(DataFolder, FilePattern)
			If x <> "" Then
				'todo
				y = ExportFilesListed(x)
			Else
				msg("No files found matching pattern")
				msg("")
				MainProcess = true
				exit Function
			End If
		Else
			' just churn thorugh the folder
			y = ExportFilesListed("")
		End If
		
	ElseIf SearchQuery <> "" Then
		x = ExportSearch(SearchQuery)
		
	End If
 
	msg("")
	msg("Records exported:    		[" & AddCount & "]")
	msg("")
	msg("Finished!")
	
	MainProcess = True
	
End Function
' ##############################################################################
Function ExportSearch(SearchQuery)
Dim maxfiles, fc, i, n, parts, p, val, blob, fBlob
 
	maxFiles = 2000000
	'on error resume next
	Set sj = Engine.NewSearchJob
	sj.IndexesToSearch = chr(34) & IndexFolder & chr(34)
	sj.Request = SearchQuery
	sj.MaxFilesToRetrieve = maxFiles
	'sj.ResultsInMemory = False
	sj.AutoStopLimit = maxFiles
	sj.DelayDocInfo = true
	sj.Execute
	
	Set res = sj.Results
	fc =  sj.FileCount
	msg("Files found matching query: [" & fc & "]")
	If QuietMode = "on" Or QuietMode = "true" Or QuietMode = "y" Then
		'Shhhh!
	Else
		ans = MsgBox("Continue?", 1, "Export Files [" & Ucase(SiteName) & "]")
		if ans = 2 then
			msg("Script Cancelled")
			msg("")
			exit Function
		End if
	End If
	
' Write Field Names in the First Row
	FieldTitle = Replace(Ucase(KeyFields), ",", Separator) & VbCrLf
	x = WriteFile(OutFile, FieldTitle)
	
	AddCount = 0
	For i = 0 to fc - 1
		res.GetNthDoc(i)
		AddCount = AddCount + 1
		If AddCount mod ReportStep = 0 Or AddCount = fc-1 Then
			msg("> records processed: [" & Padz(AddCount, 8) & "]")
			If Right(blob, 2) = VbCrLf Then Blob = Left(blob, len(blob)-2)
			AppendtoFile OutFile, blob 
			blob = ""
		End If
		fullpath = res.DocDetailItem("_filename")
		fBlob = ReadFile(fullpath)
		'RefNo = res.DocDetailItem("ref_no")
 
		parts = Split(KeyFields, ",")
		for each p in parts
			val = XMLField(fBlob, p, False)
			FieldLine = FieldLine & val & Separator
		Next
		fBlob = ""
		If Right(FieldLine, 1) = Separator Then FieldLine = Left(FieldLine, Len(FieldLine)-1)
		blob = blob & FieldLine & VbCrLf
		FieldLine = "": val = ""
	Next 
 
	Set sj = Nothing
	Set res = Nothing
 
 
End Function
' ##############################################################################
Function ExportFilesListed (FileList)
Dim parts, p, ff, cBlob, folder, files, f
 
	If FileList = "" Then
		' yuk!
		'Set FSO = CreateObject("Scripting.FileSystemObject")
		Set folder = fso.GetFolder(DataFolder)
		Set files = folder.Files
		For each f in files
			'msg(Right(f, Len(f) - InstrRev(f, "\")))	'"
			FileList = FileList & Right(f, Len(f) - InstrRev(f, "\")) & "|"	'"
		Next
		If Right(FileList, 1) = "|" Then FileList = Left(FileList, Len(FileList)-1)
		parts = split(FileList, "|")
	Else
		parts = split(FileList, "|")
	End If
		
	ff = ubound(parts)
	msg("[" & ff+1 & "]" & "file(s) found for processing..")
	if ff = 0 then
		msg(".. [" & parts(0) & "]")
	Else
		msg(" ..[" & parts(0) & "] ..[" & parts(ff) & "]")
	End if
		
	msg("")
	FieldList = split(KeyFields, ",")
	
	' Write Field Names in the First Row
	FieldTitle = Replace(Ucase(KeyFields), ",", Separator) & VbCrLf
	x = WriteFile(OutFile, FieldTitle)
	
	cBlob = ""
	AddCount = 0
	for each p in parts
		AddCount = AddCount + 1
		If AddCount mod ReportStep = 0 Then
			msg("> records processed: [" & Padz(AddCount, 8) & "]")
		End If
		cBlob = ReadFile(DataFolder & p) 
		Set FieldHash = CreateObject("Scripting.Dictionary")
		' Store Value of the fields in a Scripting Dictionary
		for each Field in FieldList
		  	FieldHash(Field) = CleanXML(Trim(XmlField(cBlob , Field , false)))
		Next   
		FieldBlob = ""
		for each Field in FieldList
		   'write out fieldhash to a blob
           FieldBlob = FieldBlob & FieldHash(Field) & Separator
		Next
		
		AppendtoFile OutFile, FieldBlob 
		'clear blob
		cBlob = ""
		
		Set FieldHash = Nothing	   	
		'Set FSO = Nothing	
	Next	
 
End Function
'###############################################################################
Function ProcessDeletes(f)
Dim MyFile, blob, EANs, p, fn, n
 
	msg(" Processing Deletes file [" & f & "]")
	blob = ReadFile(LoadFolder&"\"&f)	'"
	EANs = XMLField(blob, "ISBN13", False)
	blob = "" 
	
	For each p in Split(EANs, "|")
		fn = FindFilePath(p, IndexFolder, "", CSVal)
		If fn = "" Then
			DelNFCount = DelNFCount + 1
			x = AppendToFile(DELETESDIR&"\"&REJECTFILE, p)	'"
		Else
			blob = ReadFile(fn)
			n = Right(fn, Len(fn) - InstrRev(fn, "\"))	'"
			x = WriteFile(DELETESDIR & "\" & n, blob)	'"
 			x = DeleteFile(fn)
			If x = True then
				DelCount = DelCount + 1
				if DelCount mod ReportStep = 0 then msg(" ..[" & Padz(DelCount, 7) & "] records processed")
				RemoveFromIndexThisFile(fn)
			Else
				' I think deletefile will issue an Error message
			End If
		End If
	Next
 
End Function
 
 
'###############################################################################
Function FindFilePath(RefNo, IndexFolder, CSTag, ByRef CSVal)
Dim res, fc, fn, blob, sj, counter
 
	maxFiles = 5
	'on error resume next
	Set sj = Engine.NewSearchJob
	sj.IndexesToSearch = chr(34) & IndexFolder & chr(34)
	sj.Request = "barcode contains (" & RefNo & ")"
	sj.MaxFilesToRetrieve = maxFiles
	sj.ResultsInMemory = true
	sj.AutoStopLimit = maxFiles
	sj.DelayDocInfo = true
	sj.Execute
	
	Set res = sj.Results
	fc =  sj.FileCount
	
	if fc = 1 then
		res.GetNthDoc(0)
		FindFilePath = res.DocDetailItem("_filename")
		If CSTag <> "" Then CSVal = res.DocDetailItem(Lcase(CSTag)) End If
	ElseIf fc = 0 Then
		FindFilePath = ""
	Else
		' we have duplicates - we don't need more! Update the first one found list the others
		msg("[" & fc & "] records found for [" & RefNo & "] ..")
		counter = 0
		For i = 0 to fc - 1
			res.GetNthDoc(i)
			fullpath = res.DocDetailItem("_filename")
			If instr(fullpath, RefNo) > 0 Then
				counter = counter + 1
				If counter = 1 Then
					FindFilePath = fullpath
					msg("..updating.. [" & i & "]:[" & FindFilePath & "]")
					If CSTag <> "" Then CSVal = res.DocDetailItem(Lcase(CSTag)) End If
				ElseIf counter > 1 Then
					msg("..deleting.. [" & i & "]:[" & fullpath & "]")
					fn = Right(fullpath, Len(fullpath) - InstrRev(fullpath, "\"))	'"
					blob = ReadFile(fullpath)
					x = WriteFile(DELETESDIR & "\" & fn & "-" & i & ".xml", blob)	'"
					x = DeleteFile(fullpath)
					RemoveFromIndexThisFile(fullpath)
					DelCount = DelCount + 1
				End If
			Else
				' Copy them all so we can investigate - don't delete or update! 2006-12-20
				msg("..copying.. [" & i & "] = [" & fullpath & "]")
				fn = Right(fullpath, Len(fullpath) - InstrRev(fullpath, "\"))	'"
				blob = ReadFile(fullpath)
				x = WriteFile(DELETESDIR & "\" & fn & "-" & RefNo & "-" & i & ".xml", blob)	'"
			End If
		Next 
	End If
 
	Set sj = Nothing
	Set res = Nothing
 
End Function
' ##############################################################################
Function RemoveDuplicates(ftext)
Dim DeDupeHash, parts, p, k
 
Set DeDupeHash = CreateObject("Scripting.Dictionary")
 
	if instr(ftext, "|") > 0 Then
		parts = split(ftext, "|")
		for each p in parts
			DeDupeHash(p) = " "
		next
		'
		For each k in DeDupeHash.Keys
			RemoveDuplicates = RemoveDuplicates & k & "|"
		Next
	End if
	If Right(RemoveDuplicates, 1) = "|" Then RemoveDuplicates = Left(RemoveDuplicates, Len(RemoveDuplicates)-1)
	
	Set DeDupeHash = Nothing
 
End Function
'###############################################################################
Function XMLField(ByVal XMLText, FieldName, ire)
' 2007-02-07: Completely revamped and revised. Should work version!
'
Dim fieldlist, fl
Dim CurrentText, FieldData
 
	CurrentText = XMLText
	FieldName = Replace(FieldName, "\", "/")	'"
	fieldlist = Split(FieldName, "/")
	For each fl in fieldlist
		FieldData = ExtractXMLField(CurrentText, fl, ire)
		CurrentText = FieldData
	Next
 
' Tidy; but not always a good idea!
	If ire = False then
		FieldData = Replace(FieldData, "<![CDATA[", "")
		FieldData = Replace(FieldData, "]]>", "")
	End If
 
	XMLField = FieldData
 
End Function
'###############################################################################
Function ExtractXMLField(ByVal XMLText, ElementName, ire)
' 2007-02-07'
Dim StartPointer,FieldDelimiter,FieldName,StartTag,EndTag,pos1,pos2,FieldData
Dim tmpTags, tmpAttr, tmpData
 
	StartPointer = 1
	FieldDelimiter = "|"
	FieldName = ElementName
	If Instr(1, XMLText, "<" & FieldName & " ", 1) > 0 Then
		' you know the Element has an attribute
		StartTag = "<" & FieldName & " "
		EndTag = "</" & Replace(FieldName, " ", "") & ">"
		' This should find short version elements eg <br /> without breaking the rest of the script. Hah!!
		If instr(1, XMLText, EndTag, 1) < 1 Then
			EndTag = ">"
		End If
	Else
		StartTag = "<" & FieldName & ">"
		EndTag = "</" & FieldName & ">"
	End If
	'msg("Tags: [" & StartTag & "] [" & EndTag & "]")
	pos1 = 0
	Do While (pos1 < Len(XMLText))
		pos1 = instr(StartPointer, XMLText, StartTag, 1)
		if pos1 = 0 Then exit Do
		pos2 = instr(pos1, XMLText, EndTag, 1)
		if pos1 > 0 AND pos1 < pos2 then
			' what we normally expect
			tmpTags = Mid(XMLText, pos1, (pos2 + Len(EndTag)) - Pos1)
			if Right(StartTag, 1) = " " Then
			 tmpAttr = Mid(tmpTags, len(StartTag)+1, Instr(tmpTags, ">")-len(StartTag))
			 if Right(tmpAttr, 1) = ">" Then tmpAttr = Trim(Left(tmpAttr, Len(tmpAttr)-1))
			 if Right(tmpAttr, 1) = "/" Then tmpAttr = Trim(Left(tmpAttr, Len(tmpAttr)-1))
			 Attr = Attr &  tmpAttr & FieldDelimiter
			End If
 
			tmpData = Replace(tmpTags, StartTag & tmpAttr, "",1 ,-1, 1)
			tmpData = Replace(tmpData, EndTag, "", 1, -1, 1)
			if left(tmpData, 1) = ">" Then tmpData = Trim(Right(tmpData, Len(tmpData)-1))
			if Right(tmpData, 1) = "/" Then tmpData = Trim(Left(tmpData, Len(tmpData)-1))
 
			If ire = true then
				FieldData  = FieldData & tmpTags & FieldDelimiter
			Else
				FieldData  = FieldData & tmpData & FieldDelimiter
			End If
 
			StartPointer = pos2 + Len(EndTag)
		ElseIf pos1 <= 0 Or pos2 <= 0 Then
			' The value is either empty or meaningless
			Exit Do
		End if
	Loop
	If Right(FieldData, 1) = FieldDelimiter Then FieldData = Left(FieldData, Len(FieldData)-1)
	If Right(Attr, 1) = FieldDelimiter Then Attr = Left(Attr, Len(Attr)-1)
	ExtractXMLField = FieldData
 
End Function
'###############################################################################
FUNCTION ReadFile(FileName)
dim FC, FileContent
 
	On Error Resume Next
	'Set FSO = CreateObject("Scripting.FileSystemObject")
	If FSO.FileExists(FileName) = True Then
		Set FC = FSO.OpenTextFile(FileName, ForReading)
   		FileContent = FC.ReadAll
		If Err.Number = 0 Then
			If FileContent = "" Then msg("EEROR: File empty!")
			'Otherwise its OK
		Else
			msg("ERROR: File read error: ["& Err.Description & "]")
		End If
		FC.Close
		If Err.Number <> 0 Then
			msg("EEORE: Error closing file:[" & FileName & "]")
		End If
		Set FC = nothing
	Else
		FileContent = ""
		msg("File not found: [" & FileName & "]")
	End If
	'Set FSO = Nothing
	ReadFile = FileContent
 
END FUNCTION
'###############################################################################
FUNCTION AppendToFile(FileName, blob)
Dim File
 
	On Error Resume Next
	Err.Clear
	AppendToFile = False
	'Set fso = CreateObject("Scripting.FileSystemObject")
	Set File = FSO.OpentextFile(FileName, ForAppending, True)
	If Err.Number = 0 Then
		File.Write blob & VbCrLf
		File.Close
		If Err.Number = 0 Then
			'msg("File written OK [" & FileName & "]")
			AppendToFile = True
		Else
			msg("ERROR: Error closing/writing file; [" & Err.Description & "]")
		End If
	Else
		msg("ERROR: Error writing file: [" & FileName & "] [" & Err.Description & "]")
		msg(blob)
	End If
	
	Err.Clear
	Set File = Nothing
	'Set fso = Nothing
	
END FUNCTION
'###############################################################################
FUNCTION WriteFile(FileName, blob)
Dim File
 
	On Error Resume Next
	WriteFile = False
	'Set fso = CreateObject("Scripting.FileSystemObject")
	Set File = FSO.CreateTextFile(FileName, True)
	If Err.Number = 0 Then
		File.Write blob
		File.Close
		If Err.Number = 0 Then
			'msg("File written OK [" & FileName & "]")
			WriteFile = True
		Else
			msg("ERROR: Error closing/writing file; [" & Err.Description & "]")
		End If
	Else
		msg("ERROR: Error writing file: [" & FileName & "] [" & Err.Description & "]")
	End If
	
	Err.Clear
	Set File = Nothing
	'Set fso = Nothing
	
END FUNCTION
'###############################################################################
Function DeleteFile(PathAndName)
Dim x
 
	On Error Resume Next
	'Set FSO = CreateObject("Scripting.FileSystemObject")
	DeleteFile = False
	If (fso.FileExists(PathAndName)) Then
	   x = fso.DeleteFile(PathAndName, true)
	Else
		msg("File not found..["& PathAndName & "]")
	End If
	If Err.Number = 0 then
		DeleteFile = true
	Else
		msg("ERROR: Deleting File [" & PathAndName & "]: [" & Err.Description & "]")
	End if
	'Set FSO = Nothing
	
End Function
'###############################################################################
Function GetLoadFiles(folderspec, FilePattern)
Dim folder, files, file, fn, ft, fnp, ftp
Dim Matchstr, x
   
   	msg("Finding files matching pattern ["& FilePattern & "]")
	FilePattern = replace(FilePattern, "*", "")
	If FilePattern = "" then 
		FilePattern = "*.*"
		msg("..defaulting to file pattern [*.*]")
	End If
	If instr(FilePattern, ".") > 0 then
		fnp = Left(FilePattern, InstrRev(FilePattern, ".")-1)
		ftp = Right(FilePattern, Len(FilePattern) - InstrRev(FilePattern, "."))
	Else
		fnp = FilePattern
		ftp = "*"
	End If
	If fnp = "" then fnp = "*": If ftp = "" then ftp = "*"
	'msg("fnp [" & fnp & "] " & "ftp [" & ftp & "]")
	
	'Set fso = CreateObject("Scripting.FileSystemObject")
	Set folder = fso.GetFolder(folderspec)
	Set files = folder.Files
	For Each file in files
		MatchName = 0: MatchType = 0
		If instr(file.Name, ".") > 0 then
			fn = Left(file.Name, InstrRev(file.Name, ".")-1)
			ft = Right(file.Name, Len(file.Name) - InstrRev(file.Name, "."))
		End If
		'msg("fn [" & fn & "] " & "ft [" & ft & "]")
		
		' Does the File.name contain the fnp?
		If instr(lcase(fn), Lcase(fnp)) > 0 Or fnp = "*" then
			MatchName = MatchName + 1
		End if
		' Does the FileType contain the ftp?
		If instr(lcase(ft), lcase(ftp)) > 0 Or ftp = "*" then
			MatchType = MatchType + 1
		End if
 
		'msg("MatchType: [" & MatchType & "] " & "MatchName: [" & matchName & "] Filename: [" & file.name & "] fnp: [" & fnp & "] ftp: [" & ftp &"]")
		
		If MatchType = 1 And MatchName = 1 Then
			GetLoadFiles = GetLoadFiles & file.Name & "|"
		Else
			'
		End if
 
	Next
	If right(GetLoadFiles, 1) = "|" Then GetLoadFiles = Left(GetLoadFiles, len(GetLoadFiles)-1)
	
End Function
'###############################################################################
Function GetNumberOfFolders(path)
Dim f, fc
 
	'Set FSO = CreateObject("Scripting.FileSystemObject")
   	Set f = fso.GetFolder(path)
   	Set fc = f.SubFolders
   	'Set FSO = Nothing
   	GetNumberOfFolders = fc.count
 
End Function
'###############################################################################
Function GetNumberOfFiles(path)
Dim f, fc
 
	'Set FSO = CreateObject("Scripting.FileSystemObject")
   	Set f = fso.GetFolder(path)
   	Set fc = f.files
	'Set FSO = Nothing
   	GetNumberOfFiles = fc.count
	
End Function
'###############################################################################
Function GetChildNodes(fullpath)
Dim cn, XmlText, NodeText, blob
 
	XmlText = ReadFile(fullpath)
	For each cn in arrChildNodes
		NodeText = XMLField(XMLText, cn, True)
		If NodeText <> "" Then blob = blob & NodeText 
	Next
	
	GetChildNodes = blob
 
End Function
'###############################################################################
Function SaveNode(xmlDoc, MyParentNode)
Dim MySavedNode
 
	Set MySavedNode = XmlDoc.SelectNodes("//"&MyParentNode)	
	For i = 0 to MySavedNode.Length - 1
		SaveNode = SaveNode & MySavedNode.Item(i).xml
	Next
	Set MySavedNode = Nothing
End Function
' ##############################################################################
Function AddChildElement(XmlDoc, MyParentNode, ChildElementName, ChildElementValue)
Dim newElementname, newElementValue, Node, currNode
 
	Set currNode = XmlDoc.DocumentElement.SelectSingleNode(MyParentNode&"/"&ChildElementName)
	If currNode Is Nothing Then
		Set newElementName = XmlDoc.createElement(ChildElementName) 
		Set newElementValue = XmlDoc.createTextNode(ChildElementValue) 
		newElementName.appendchild(newElementValue)
		Set Node = XmlDoc.DocumentElement.SelectSingleNode(MyParentNode)
		If Node Is Nothing Then
			' We could create node but better to ensure this is done in MainProcess
			' x = AddNewNode(XmlDoc, MyParentNode)
			'msg("<" & MyParentNode & "> Node is missing")
		Else
			Node.appendChild(newElementName)
			'msg("creating child [" & newElementname.xml & "]")
		End if
	Else
		x = RemoveChildElement(XMLDoc, MyParentNode, ChildElementName)
		Set newElementName = XmlDoc.createElement(ChildElementName) 
		Set newElementValue = XmlDoc.createTextNode(ChildElementValue) 
		newElementName.appendchild(newElementValue)
		Set Node = XmlDoc.DocumentElement.SelectSingleNode(MyParentNode)
		Node.appendChild(newElementName)
	End if
	
	Set currNode = Nothing
	Set newElementName = Nothing
	Set newElementValue = Nothing
	Set Node = Nothing
	
End Function
' ##############################################################################
Function RemoveChildElement(XMLDoc, MyParentNode, ChildElementName)
Dim myRoot, myNodeList, myItem
 
	Set myRoot = XMLDoc.DocumentElement.selectSingleNode(MyParentNode)
	Set myNodeList = myRoot.SelectNodes(ChildElementName)
	If Not myNodeList Is Nothing Then
		For each myItem in myNodeList
			myRoot.removeChild myItem
		Next
	End If
	Set myNodeList = Nothing
	
End Function
' ##############################################################################
Function AddNewNode(XmlDoc, MyParentNode)
Dim Node
 
	Set Node = XmlDoc.documentElement.SelectSingleNode(MyParentNode)
	If Node Is Nothing Then
		' then we need to create it as a Child of the Document.root
		Set Node = XmlDoc.createNode(1, MyParentNode, "")
		XmlDoc.documentElement.appendChild(Node)
		'msg("Creating new node:[" & Node.xml & "]" )
	End if
 
	Set Node = Nothing
End Function
' ##############################################################################	
Function LoadXmlDoc(fullpath ,xDoc)
Dim MyDoc
 
	LoadXmlDoc = False
	Set MyDoc = createObject("Microsoft.XMLDOM")
	MyDoc.async = False
	MyDoc.load fullpath
	If Err.Number = 0 And MyDoc.ParseError.ErrorCode = 0 Then
		LoadXmlDoc = True
		Set XmlDoc = MyDoc
	Else
		msg("Err: LoadXmlDoc ["& MyDoc.ParseError.Reason &"] ["&fullpath&"]")
	End If
	
End Function
' ##############################################################################
Sub GetArguments()
' NB The arg variables need to be globally declared at the beginning of the script
' OutFileName,EhausNodeName,CSVIndexFolder,WebRoot,OutFolder,KeyFields,ExcludeList,DataFolder,IndexFolder,RootFolder,LoadFolder,LoadFormat,LoadType,FilePattern,SiteName,LogName,Password,Username,QuietMode,WebFlag
 
	For Each oArg in WScript.Arguments
  		sSwitch = LCase(Left(oArg,4))
		sSwitch = replace(sSwitch, "=", "")
  		if Len(oArg) > 4 Then
  			sValue = lcase(Right(oArg,Len(oArg)-4))
			sValue = Replace(sValue, chr(34), "")
		Else
			sValue = ""
		End if
		If sValue <> "" then ArgCount = ArgCount + 1
 
		Select Case sSwitch
      Case "/on"
				OutFileName = sValue
			case "/nn"
				EhausNodeName = sValue
			case "/sq"
				SearchQuery = sValue
			Case "/ex"
				OutExtension = sValue
			Case "/of"
				OutFolder = sValue
			Case "/kf"
				KeyFields = sValue
			Case "/el"
				ExcludeList = sValue
			Case "/df"
				DataFolder = sValue
			Case "/if"
				IndexFolder = sValue
			Case "/rf"
      			RootFolder = sValue
			Case "/lf"
				LoadFolder = sValue
			Case "/fm"
				LoadFormat = sValue
			Case "/lt"
				LoadType = left(sValue, 3)	
			Case "/fp"
				FilePattern = sValue
			Case "/sn"
      			SiteName = sValue
			Case "/ln"
      			LogName = sValue
			Case "/pw"
				Password = sValue
			Case "/un"
				Username = sValue
			Case "/qt"
				QuietMode = sValue
			Case "/wf"
				WebFlag = sValue
  		End Select
	Next
	
End Sub
'###############################################################################
Sub ShowArgs(argslist)
Dim parts, p, sl, n
 
	If argslist = "" Then
		argsList = "Delimiter,EhausNodeName,CSVIndexFolder,WebRoot,OutFolder,KeyFields,ExcludeList,DataFolder,IndexFolder,RootFolder,LoadFolder,LoadFormat,LoadType,FilePattern,SiteName,LogName,Password,Username,QuietMode,WebFlag"
	End If
	parts = Split(argsList, ",")
	For each p in parts
		If Eval(p) <> "" Then
			for n = 0 to (30 - len(p))
				dots = dots & "."
			next
			msg(Ucase(p) & dots & "[" & Eval(p) & "]")
			dots = ""
		End If
	Next
	
End Sub
' ##############################################################################	
FUNCTION GetDelimitedPhrases(byVal Text, StartTag, StopTag)
' Returns a pipe delimited string with every substring bounded by specified StartTag and StopTag
' 2007-07-03
dim startpos, pos1, pos2, storepos, parts, ppn, ii, x, y, pTEXT
	
	startpos = 1: pos2 = 1
	do until pos2 = 0
		pos1 = instr(startpos, Text, StartTag) + len(StartTag)-1
		pos2 = instr(startpos, Text, StopTag)
		if pos1 <> 0 and pos2 <> 0 then
			if pos1 = pos2 then
				storepos = storepos & "|" & pos1
			elseif pos1 < pos2 then
				storepos = storepos & "|" & pos1 & "|" & pos2
			end if
		end if
		startpos = pos2 + 1
	loop
	if storepos <> "" then
		storepos = right(storepos, len(storepos)-1)
		parts = split(storepos, "|")
		
		if ubound(parts) mod 2 = 1 then
			ii = 0
			do while ii <= ubound(parts)
				x = parts(ii): y = parts(ii+1)-x
				if mid(Text, x+1, y-1) <> "" then
					'response.write "<br> DELIM: [" & mid(Text, x+1, y-1) & "]"
					pTEXT = pTEXT & "|" & mid(Text, x+1, y-1)
				end if
				ii = ii + 2
			loop
			storepos = ""
			if left(pTEXT, 1) = "|" then pTEXT = right(pTEXT, len(pTEXT)-1)
			while instr(pText, "||") > 0 
				pTEXT = replace(pTEXT, "||", "|")
			wend
			GetDelimitedPhrases = pTEXT
		else
			GetDelimitedPhrases = ""
		end if
	end if	
 
END FUNCTION
'###############################################################################
Function CheckJacketFile(ean)
Dim Prefix, maxfiles, sj, res, fc, title
 
	
	Prefix = left(ean, 6)
	maxFiles = 4
	
	Set sj = Engine.NewSearchJob
	sj.IndexesToSearch = chr(34) & JacketIndex & chr(34)
	sj.Request = "(" & ean & ")"
	sj.MaxFilesToRetrieve = maxFiles
	sj.ResultsInMemory = true
	sj.AutoStopLimit = maxFiles
	sj.DelayDocInfo = true
	sj.Execute
	
	Set res = sj.Results
	fc =  sj.FileCount
	
	if fc >= 3 then
		'res.GetNthDoc(0)
		'Title = res.DocDetailItem("title")
		CheckJacketFile = "/jackets/m/" & Prefix & "/" & ean & ".jpg"
	Elseif fc > 0 And fc < 3 Then
		' I suppose we could check for instances where we only one or two of the 3 we should have..
		'msg("not all sizes of jacket found ..[" & ean & "]")
		CheckJacketFile = "/jackets/m/" & Prefix & "/" & ean & ".jpg"
	Else
		CheckJacketFile = ""
	End If
 
	Set sj = Nothing
	Set res = Nothing
	
	
End Function
'###############################################################################
Function InsertImage(ISBN, iType, iSize, DBM, iServer)
Dim ImageServerUrl, iUrl, XmlDoc, Node
Dim objHttp, RemoteOutput, lResolve, lConnect, lSend, lReceive
Set objHttp = CreateObject("Msxml2.SERVERXMLHTTP")
On Error Resume Next
 
	If iServer = "" then ImageServer = SetImageServer
	If iServer <> "" then ImageServer = iServer
	If ImageServer = "" then ImageServer = "http://213.253.134.29"
	ImageServer = Replace(LCase(ImageServer), "http://", "")
	ImageServer = "http://" & ImageServer
	
    ImageServerUrl = ImageServer & "/xmla/xml_images.asp"
    ISBN = Replace(ISBN, "-", "")
    iUrl = ImageServerUrl & "?ISBN=" & ISBN & "&Type=" & iType & "&Size=" & iSize & "&DBM=" & DBM
	'response.write iUrl
    RemoteOutput = GetXML(iUrl)
    If RemoteOutput <> "" Then
        Set XmlDoc = CreateObject("MSXML2.DOMDocument")
        XmlDoc.async = False
        XmlDoc.LoadXml (RemoteOutput)
        Set Node = XmlDoc.documentElement.selectSingleNode("/recordcollection/imagedetails/jacketpath")
        InsertImage = Node.Text
        If LCase(InsertImage) = "no image" Then InsertImage = ""
    End If
    Set XmlDoc = Nothing
    Set Node = Nothing
 
End Function
'###############################################################################
FUNCTION GetXML(rURL)
Dim objHttp, RemoteOutput, sResolve, sConnect, sSend, sReceive, SecondsOut
 
	On Error Resume Next
	SecondsOut = 15  ' How many seconds to wait for responsefrom XMLA
	rURL = Replace(LCase(rURL), "http://", "")
	rURL = "http://" & rURL
	
	Set objHttp = CreateObject("MSXML2.ServerXMLHTTP")
	sResolve = SecondsOut * 1000: sConnect = SecondsOut * 1000: sSend = SecondsOut * 1000: sReceive = SecondsOut * 1000
	objHttp.SetTimeouts sResolve, sConnect, sSend, sReceive
	objHttp.Open "POST", rUrl, False
	objHttp.Send
	If Err.Number = 0 Then
		GetXML = objHttp.ResponseText
	Else
		GetXML = ""
	End if
	Set objHttp = Nothing
	
END FUNCTION
'###############################################################################
Function SetRegistryDefault(ByRef ThisVar, RegKey) 
Dim oWshShell, MyServer, RegValue, myNetwork
 
	Err.Clear
	On Error Resume Next
	Set myNetwork = CreateObject("WScript.Network")
	MyServer = myNetwork.ComputerName
	Set oWshShell = CreateObject("WScript.Shell")
	RegValue = oWshShell.RegRead("HKLM\Software\Ehaus\MachineDefaults\"&MyServer&"\"&RegKey)	'"
	Set oWshShell = Nothing
	'msg "<br>RegValue: " & RegValue
	If RegValue <> "" AND ThisVar = "" then ThisVar = RegValue
	'msg "<br>Err: " & Err.Number & " - " & Err.Description & " - " & Timer
 
End Function
'###############################################################################
FUNCTION CleanXML(T)
	
	'T = Replace(T, "&amp;", "##38;")
	'T = Replace(T, "&apos;", "##39;")
	'T = Replace(T, "&quot;", "##34;")
	'T = Replace(T, "&lt;", "##60;")
	'T = Replace(T, "&gt;", "##62;")
	'T = Replace(T, "&#", "##")
	'T = Replace(T, "&", "&#38;")
	'T = Replace(T, "##", "&#")
	
	'T = Replace(T, "<", "&#60;")
	'T = Replace(T, ">", "&#62;")
	'T = Replace(T, "£", "&#163;")
	T = Replace(T, vbcrlf," ")
	T = Replace(T, vbcr, "")
	T = Replace(T, vblf, "")
	T = Replace(T, "CDATA![", "")
	T = Replace(T, "<![CDATA[", "")
	T = Replace(T, "]]>", "")
 
	'T = Replace(T, chr(150), "-")
	'T = Replace(T, chr(145), "&#39;")
	'T = Replace(T, chr(146), "&#39;")
	'T = Replace(T, chr(133), "...")
	
	CleanXML = Trim(T)
	
END FUNCTION
'###############################################################################
FUNCTION CleanAuthor(ByVal a)
' only being used for the sort_ fields and the dewey_num
 
	a = Trunc(a)
	a = replace(a, "&quot;", "")
	a = replace(a, "&amp;", "")
	a = replace(a, "&apos;", "")
	a = replace(a, "&#39;", "")
	a = Replace(a, "&#38;", "")
	a = Replace(a, "&#34;", "")
	a = Replace(a, "&#60;", "")
	a = Replace(a, "&#62;", "")
	a = Replace(a, "&#163;", "")
	a = replace(a, ".", " ")
	a = replace(a, ",", " ")
	a = replace(a, """", " ")
	a = replace(a, "'", " ")
	a = replace(a, "-", " ")
	a = replace(a, ";", " ")
	a = replace(a, ":", " ")
	a = replace(a, "&", " ")
	a = replace(a, "[", " ")
	a = replace(a, "]", " ")
	while instr(a, " ") > 0
		a = replace(a, " ", "")
	wend
	a = replace(a, "et al", "")
	CleanAuthor = a
 
end function
'###############################################################################
Public Function SortItOut(ByRef objDict, ByVal vSortType, ByVal vSortDirection, ByVal vDataType)
' --
' LJG 08/2004 v1.0
' Sorts a Scripting Dictionary alphabetically using either keyname or value to sort.
' PARAMS 
' objDict = By Reference the Scripting Dictionary Object to sort.
' vSortType = the sort type either "name" or "value" as string
' vSortDir = "a" = Ascending "d" = descending
' vDataType = "num" = number, "str" = alpha ' defaults to alpha if ""
' To call e.g: Call SortItOut(Hash, "name", "a", "str") 
' --
	Dim objXML, Xsl, objNode, objName, objValue, objKey, strListSortXSL, bDiag
	' -- 
	
	If vDataType <> "num" Then vDataType = ""
	If vSortDirection <> "d" Then vSortDirection = "a"
	If vSortType <> "name" Then vSortType = "value"
	If LCase(vSortType) = "key" Then vSortType = "name"
	
	Set objXML = CreateObject("MSXML2.DOMDocument")
	objXML.async = false
	objXML.loadXMl "<keys></keys>"
	
	For Each objKey In objDict.Keys
		Set objNode = objXMl.documentElement.appendChild (objXML.createElement("key"))
		set objName = objNode.appendChild (objXML.createElement("name"))
		objName.text = objKey
		set objValue = objNode.appendChild (objXML.createElement("value"))
		objValue.text = objDict(objKey)
	Next 
	' --
	' -- Load Up XSL 
	' --
	strListSortXSL = "<?xml version=""1.0"" encoding=""UTF-8""?>" & _
		"<xsl:stylesheet version=""1.0"" xmlns:xsl=""http://www.w3.org/1999/XSL/Transform"">" & _
		"<xsl:output method=""xml"" version=""1.0"" encoding=""UTF-8"" indent=""yes""/>" & _
		"<xsl:template match=""@*|node()"">" & _
		"<xsl:copy>" & _
        "<xsl:apply-templates select=""@*|node()"">" & _
        "<xsl:sort select=""translate(" & vSortType & ", 'abcdefghijklmnopqrstuvwxyz', 'ABCDEFGHIJKLMNOPQRSTUVWXYZ')"""
 
		If LCase(vDataType) = "num" Then
			strListSortXSL = strListSortXSL & " data-type=""number"""
		End If
		If LCase(vSortDirection) = "d" Then
			strListSortXSL = strListSortXSL & " order=""descending""/>"
		Else
			strListSortXSL = strListSortXSL & " order=""ascending""/>"
		End If
		strListSortXSL = strListSortXSL & "</xsl:apply-templates></xsl:copy></xsl:template></xsl:stylesheet>" 	
		
		Set Xsl = createObject("MSXML2.DOMDocument")
		Xsl.async = False
		Xsl.loadXML(strListSortXSL)
 
		objXML.LoadXML objXML.transformNode(Xsl) 
		' -- Reform dictionary
		objDict.RemoveAll
		
		Set objKey = Nothing
		
		For Each objKey In objXML.selectNodes("*/key")
			objDict(objKey.selectSingleNode("name").text) = objKey.selectSingleNode("value").text
		Next
		
		Set objKey = Nothing
		Set objXML = Nothing
		Set Xsl = nothing
		Set objNode = Nothing
		Set objValue = Nothing
		Set objName = Nothing
		
		
End Function
'###############################################################################
FUNCTION Trunc(FieldStr)
	
	' Removes affiliateions and things
	If instr(FieldStr, "(") > 0 then FieldStr = Split(FieldStr, "(", 2)(0) End If
	' Removes all but the first instance of a repeating field
	If instr(FieldStr, "|") > 0 then FieldStr = Split(FieldStr, "|", 2)(0) End If
	
	Trunc = Trim(FieldStr)
		
END FUNCTION
'###############################################################################
Sub msg(lText)
 Dim f
 
   	if lText <> "" then
		lText = "> [" & DisplayTime & "] " & lText
	End If
	'Set fso = CreateObject("Scripting.FileSystemObject")
	Set f = fso.OpenTextFile(LOGDIR & "\" & LOGFILE, ForAppending, True) '"
	f.Write lText & VbCrLf
	If QuietMode = "on" Or QuietMode = "true" Then
		'Shhhh!
	Else
		wscript.echo lText
	End If
	f.Close
	'Set fso = Nothing
   
End Sub
'###############################################################################
Sub IndexThisFile(ltext)
Dim f
 
 	'Set FSO = CreateObject("Scripting.FileSystemObject")
	Set f = fso.OpenTextFile(FilesToIndexFile, ForAppending, True) '"
	f.Write lText & VbCrLf
	f.Close
   	'Set FSO = Nothing
	
End Sub
'###############################################################################
Sub RemoveFromIndexThisFile(ltext)
Dim f
 
 	'Set FSO = CreateObject("Scripting.FileSystemObject")
	Set f = fso.OpenTextFile(FilesToRemoveFile, ForAppending, True) '"
	f.Write lText & VbCrLf
	f.Close
	'Set FSO = Nothing
   
End Sub
'###############################################################################
Function PrettyDate(myDate)
' Takes either yyyy-mm-dd Or yyyy-mm-dd/HH:MM Or yyyymmdd:yyyymmdd and comes up with something else
Dim parts, p, bits, b, TempDate
 
lang = "EN"
Set DateHash = CreateObject("Scripting.Dictionary")
DateHash("01_EN") = "Jan" : DateHash("02_EN") = "Feb" :DateHash("03_EN") = "Mar" : DateHash("04_EN") = "Apr" : DateHash("05_EN") = "May" : DateHash("06_EN") = "Jun" : DateHash("07_EN") = "Jul" : DateHash("08_EN") = "Aug" : DateHash("09_EN") = "Sep" : DateHash("10_EN") = "Oct" : DateHash("11_EN") = "Nov" : DateHash("12_EN") = "Dec"
	
	bits = split(myDate, " ")
	for each b in bits
		'response.write "<br> [" & myDate & "]"  & b
		if left(b, 4)*1 > 1900 AND left(b, 4) < 2500 then
			If len(b) = 17 and Mid(b, 9, 1) = ":" then
				'Its a date range yyyymmdd:yyyymmdd
				parts = split(b, ":")
				TempDate = Mid(parts(0), 7, 2) & " " & DateHash(Mid(parts(0), 5, 2) & "_" & lang) & " " & Mid(parts(0), 1, 4)
				TempDate = TempDate & totxt & Mid(parts(1), 7, 2) & " " & DateHash(Mid(parts(1), 5,2) & "_"& lang) & " " & Mid(parts(1), 1, 4)
				
			Elseif len(b) = 16 and Mid(b, 11, 1) = "/" then
				' yyyy-mm-dd/HH:MM
				parts = split(b, "/")
				TempDate = Mid(parts(0), 9, 2) & " " & DateHash(Mid(parts(0), 6, 2) & "_"& lang) & " " & Mid(parts(0), 1, 4)
				
			Elseif len(b) = 10 and Mid(b, 5, 1) = "-" and Mid(b, 8, 1) = "-" then
				'yyyy-mm-dd
				TempDate = Mid(b, 9, 2) & " " & DateHash(Mid(b, 6, 2) & "_"& lang) & " " & Mid(b, 1, 4)
			
			Elseif len(b) = 8 and isNumeric(b) then
				'yyyymmdd
				If Mid(b, 7, 2) = "00" Then
					TempDate = "01" & " " & DateHash(Mid(b, 5, 2) & "_"& lang) & " " & Mid(b, 1, 4)
				Else
					TempDate = Mid(b, 7, 2) & " " & DateHash(Mid(b, 5, 2) & "_"& lang) & " " & Mid(b, 1, 4)
				End If
 
			Else
				TempDate = b
			End if
		Else
			TempDate = b
		End if
		PrettyDate = PrettyDate & " " & TempDate
	Next
 
End Function
'###############################################################################
Function DisplayDate()
	DisplayDate = Year(Date) & "/" & Padz(Month(Date),2)& "/" & Padz(Day(Date),2)
End Function 
'###############################################################################
Function DisplayTime()
	DisplayTime = Padz(Hour(Now),2) & ":"  & Padz(Minute(Now),2) & ":" & Padz(Second(Now),2)
End Function 
'###############################################################################
Function Padz(n,s)
	Padz=string(s-len(n),"0")& n
End Function
'###############################################################################
Function IsIn(ByVal p1, ByVal t1)
Dim tx
	for each tx in t1
		if lcase(trim(p1)) = lcase(trim(tx)) then
			IsIn = True
			exit function
		end if
	next
	IsIn = False
End Function
'###############################################################################
Sub PrintHash(hash)
Dim MyPrintHash 
 
	Set MyPrintHash = CreateObject("Scripting.Dictionary")
	Set MyPrintHash = hash
	'msg QuietMode & VbCrLf
	for each k in MyPrintHash.keys
		'if MyHash.Item(k)<>"" then
			msg " KEY: " & k & " VALUE: [" & MyPrintHash.Item(k) & "]" 
		'end if
	next
	'msg" " & VbCrLf
	Set MyPrintHash = Nothing
	
End Sub
'###############################################################################

Open in new window

0
 
LVL 65

Expert Comment

by:RobSampson
ID: 21842595
Hi Sam,

Wow, that's a big script!

I really can't tell what it does....it's a lot of code to try to make sense of without seeing it in action.

I really don't know if I will be able to help you, but if you could start by providing a sample XML file, and even a CSV output of the file after this script has run over it....I'll have a look and see if I can make sense of it.

Regards,

Rob.
0
 
LVL 8

Author Comment

by:newbie27
ID: 21844832
Hello Rob,
Thanks for looking into this for me. I am sorry for not making it more clear, I know it is huge, I will cut short the functions which most of them are redundant in the script and post you back soon.
Thanks
Sam
0
Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
LVL 8

Author Comment

by:newbie27
ID: 21867325
Hello Rob,
I have managed to receive comma separated ISBNLists (record Ids) and few parameter values from the asp page and then calling export_data.vbs to actually process and retrieve data for the given ids from the XML database and finally export it.

Export should be like saving the file in one of FTP folder on the server, the output format would be the users desired selection, at the moment I am trying to save it as comma separated fields in .csv format.
Please can you have a look to the attached, it is returning 11 records in fValues

Please see if this makes any sense to you

thanks for your help
sam

PS: if you please visit
http://213.253.134.6/artism/admin/list_admin.asp
click on export and to see the page where I am working ....

cn = 4
			DBM = "artism"
			SiteName ="artism"
			FieldList = "ref_no,pe_rev_name,co_name,action_flag,co_group,notes"
			
			If RemoteServer = "" Then RemoteServer = "http://213.253.134.6"
			Set DataHash = CreateObject("Scripting.Dictionary")
		
		' Chunk ISBNs into lots of say 50
			parts = split(ISBNs, ",")
			For i = 0 to Ubound(parts)
				if (i + 1) mod cn = 0 Then
					blob = blob & parts(i) & "|"
				Else
					blob = blob & parts(i) & ","
				end if
			Next
						
			If Right(blob, 1) = "," Then blob = Left(blob, Len(blob)-1)
			
			msg "blob=" & blob
		
		' Get the data and store it ready for writing out
			parts = split(blob, "|")
			For each p in parts
				xTxt = QuickSearchText("&SF1=keyword" & "&ST1=" & p & "&PL=" & cn, DBM, FieldList, NodeName, RemoteServer, IncTags)
				'msg "xtxt=" & xtxt
				xParts = Split(xTxt, "|")
				For each xp in xParts
					DataHash(XMLField(xp, "fv_ref_no", false)) = xp
				Next
			Next
		   
		'Now write out the divs in the correct order of course!
			parts = split(ISBNs, ",")
			For each p in parts
				
				mx = DataHash(p)
				'msg "mx=" & mx
				Fields = Split(FieldList, ",")
				 
				For each f in Fields
					fValues = fValues & XMLField(mx, "fv_"&f, False) & ":" 
					
				Next
				
				fValues = fValues & VbCrLf  
		         
			Next
		
			msg fValues
	

Open in new window

0
 
LVL 8

Author Comment

by:newbie27
ID: 21867600
fValues = " please see the attached "
screen.jpg
0
 
LVL 8

Author Comment

by:newbie27
ID: 21870505
Hello Rob,
Please can you assist me in writing correct columns into the csv file in this script ....
thanks for your help
sam
OutFolder="E:\tbp\www\artism\admin\FTP\download"
	OutFileName="media"
	OutExtension="csv"
FieldTitle = Replace(Ucase(FieldList), ",", Separator) & VbCrLf
			x = WriteFile(OutFile, FieldTitle)
		    
 
		'Now write out the columns in the correct order
			parts = split(ISBNs, ",")
			For each p in parts
				
				mx = DataHash(p)
				'msg "mx=" & mx
				Fields = Split(FieldList, ",")
				 
				For each f in Fields
					fValues = fValues & XMLField(mx, "fv_"&f, False) & ":" 
					
				Next
				
				fValues = fValues & VbCrLf  
		         
			Next
		
			AppendtoFile OutFile, fValues 
		    msg fValues`

Open in new window

0
 
LVL 65

Accepted Solution

by:
RobSampson earned 500 total points
ID: 21905288
Hi, sorry I haven't got back to you on this....I still find it a bit confusing about where it's up to, and what needs to be done....but, judging by the output of fValues that you have, it's obviouly not CSV compatible, so try this instead.

Regards,

Rob.
OutFolder="E:\tbp\www\artism\admin\FTP\download"
	OutFileName="media"
	OutExtension="csv"
FieldTitle = Replace(Ucase(FieldList), ",", Separator) & VbCrLf
			x = WriteFile(OutFile, FieldTitle)
		    
 
		'Now write out the columns in the correct order
			parts = split(ISBNs, ",")
			For each p in parts
				
				mx = DataHash(p)
				'msg "mx=" & mx
				Fields = Split(FieldList, ",")
				 fValue = ""
				For each f in Fields
				    If fValues = "" Then
						fValues = """" XMLField(mx, "fv_"&f, False) & """"
					Else
						fValues = fValues & ",""" XMLField(mx, "fv_"&f, False) & """"
					End If
				Next
				
				fValues = fValues & VbCrLf  
		         
			Next
		
			AppendtoFile OutFile, fValues 
		    msg fValues

Open in new window

0
 
LVL 8

Author Comment

by:newbie27
ID: 21910021
Hello Rob,
Thanks for your help,
can you please look into this once you get the chance Rob?

http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_23531069.html

thanks
sam
0
 
LVL 8

Author Closing Comment

by:newbie27
ID: 31469373
thanks
0

Featured Post

Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

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

I met Paul Devereux (@pdevereux) today when I responded to his tweet asking “Anybody know how to automate adding files from disk to a folder in #outlook  ?”.  I replied back and told Paul that using automation, in this case scripting, to add files t…
This article is the result of a quest to better understand Task Scheduler 2.0 and all the newer objects available in vbscript in this version over  the limited options we had scripting in Task Scheduler 1.0.  As I started my journey of knowledge I f…
Michael from AdRem Software explains how to view the most utilized and worst performing nodes in your network, by accessing the Top Charts view in NetCrunch network monitor (https://www.adremsoft.com/). Top Charts is a view in which you can set seve…
In this brief tutorial Pawel from AdRem Software explains how you can quickly find out which services are running on your network, or what are the IP addresses of servers responsible for each service. Software used is freeware NetCrunch Tools (https…

691 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