Solved

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

Posted on 2008-06-20
9
778 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
  • 7
  • 2
9 Comments
 
LVL 8

Author Comment

by:newbie27
Comment Utility

''###############################################################################

' 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
Comment Utility
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
Comment Utility
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
 
LVL 8

Author Comment

by:newbie27
Comment Utility
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
How to improve team productivity

Quip adds documents, spreadsheets, and tasklists to your Slack experience
- Elevate ideas to Quip docs
- Share Quip docs in Slack
- Get notified of changes to your docs
- Available on iOS/Android/Desktop/Web
- Online/Offline

 
LVL 8

Author Comment

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

Author Comment

by:newbie27
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
thanks
0

Featured Post

Threat Intelligence Starter Resources

Integrating threat intelligence can be challenging, and not all companies are ready. These resources can help you build awareness and prepare for defense.

Join & Write a Comment

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…
If you need to start windows update installation remotely or as a scheduled task you will find this very helpful.
This video gives you a great overview about bandwidth monitoring with SNMP and WMI with our network monitoring solution PRTG Network Monitor (https://www.paessler.com/prtg). If you're looking for how to monitor bandwidth using netflow or packet s…
This video demonstrates how to create an example email signature rule for a department in a company using CodeTwo Exchange Rules. The signature will be inserted beneath users' latest emails in conversations and will be displayed in users' Sent Items…

744 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