WRITINGS BY PETER BYERS

I was asked to provide some code that would allow users to create XML tables. They were to be used to be attached to EMails as a means of transmitting structured data between different places in their organisation.

They are all running Windows 2000 on their PC's and fortunately have IIS installed and running (it comes bundled with Windows 2000). They are also capable of creating/modifying HTML Forms.

I created an ".ASP" file for them (Contents shown below). Also a demo ".HTM" file for them.

They asked about showing data from their files, that had been created from a "textarea" item. A simple ".ASP" file was created to show them how to do it. (Contents shown below).

As well as giving it to them to put on their PCs, I put it up on the Internet so that you can see it at work.

If it excites you, save the HTM file on your PC - modify the FORM contents - use it on your PC - it will update the Table that is on my Web Site, but feel free - periodically I may clear off the stuff that you have put there. Try it now.

To see the raw XML file. Click here.

The users have been a bit clever and have developed several Input pages for the same table - and - thus have created a quick and simple Workflow process.

They have also created an "OnLine" Suggestions Box for their staff. Now there - aint that sweet and simple !!

Limited only by your Imagination !!!

Below are the contents of "add2xml.asp" - a general purpose file.



>%@ Language=VBScript %<


>%

session.LCID = 2057


Const ForReading = 1, ForWriting = 2, ForAppending = 8
Const TristateUseDefault = -2 ' Opens the file using the system default.
Const TristateTrue = -1 ' Opens the file as Unicode.
Const TristateFalse = 0 ' Opens the file as ASCII.

Dim aElementName(100), aElementValue(100)

Blips = Chr(34)
atDateStr = fncFmtDate(Now, "%H:%N:%S on %A, %B %D, %Y")

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''                                                        '''
''' CUSTOMIZATION                                          '''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''                                                        '''
''' First you need to decide if you want to control the    '''
''' Elements that are included in the post and set the     '''
''' lCheckElements variable as appropriate.                '''
'''                                                        '''
''' If you do decide to control them, you need to specify  '''
''' the Allowed Elements.                                  '''
'''                                                        '''
''' The string called cAllowedElements should contain the  ''' 
''' Element names of the Elements allowed in the XML table '''
'''                                                        '''
''' For ease of reading, the elements may be separated by  '''
''' spaces (or any other characters that take your fancy)  '''
'''                                                        '''
''' The string is used in a case sensitive manner          '''
'''                                                        '''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''                                                        '''
''' You also need to specify if you want the file to be    '''
''' displayed after the update.                            '''
''' Use the lShowFile variable to declare your wish.       '''
'''                                                        '''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''                                                        '''
''' You can specify if, when the XML file does not exist,  '''
''' that you wish to create it.                            '''
''' Use the lCreateTable variable to declare your wish.    '''
'''                                                        '''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

lCheckElements   = False		''either True or False
cAllowedElements = "FORENAMES SURNAME"

lShowFile        = True			''either True or False

lCreateTable     = False		''either True or False

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Thats it                                               '''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


nIC = -1
for each item in request.form
	if UCase(item) >< "TABLE_NAME" AND UCase(item) >< "NODE_NAME" then
		if request.form(item) >< "" then
			MyPos = Instr(1, cAllowedElements, item, 1)
			if lCheckElements then
				if MyPos < 0 then
					nIC = nIC + 1
					aElementName(nIC) = item
					aElementValue(nIC) = ResolveCharacters(request.form(item))
				end if
			else
				nIC = nIC + 1
				aElementName(nIC) = item
				aElementValue(nIC) = ResolveCharacters(request.form(item))
			end if
		end if
	end if
''    response.write "^^^" & item & ":" & request.form(item) & ">br<>br<"
next


nIC = nIC + 1
aElementName(nIC) = "ADDED_AT"
aElementValue(nIC) = atDateStr

nIC = nIC + 1
aElementName(nIC) = ""


Set objFS=Server.CreateObject("Scripting.FileSystemObject")
 strFileName= Server.MapPath(request.form("TABLE_NAME"))

if lCreateTable then
	If objFS.FileExists(strFileName) = False Then
		Set objTextS = objFS.CreateTextFile(strFileName,False, False)
		TextLine = ">" & Left(request.form("TABLE_NAME"), (Len(request.form("TABLE_NAME")) - 4)) & "<"
		objTextS.WriteLine TextLine
		TextLine = ">/" & Left(request.form("TABLE_NAME"), (Len(request.form("TABLE_NAME")) - 4)) & "<"
		objTextS.WriteLine TextLine
		objTextS.Close
	End If
end if




 set trialXmlDoc = createXMLDocFromFile(request.form("TABLE_NAME"))


  childName = request.form("NODE_NAME")
  set newNode = trialXmlDoc.createNode(1, childName, "")
x = 0
do while Len(aElementName(x)) < 0
	newNode.setAttribute aElementName(x), aElementValue(x)
	x = x + 1
loop

trialXmlDoc.documentElement.appendChild(newNode)
			
trialXmlDoc.save(Server.MapPath(request.form("TABLE_NAME")))

if lShowFile then
	Response.contentType = "text/xml"
	Response.write trialXmlDoc.xml
else
	Response.Write "Data Added"
end if


 set trialXmlDoc = Nothing



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' For reasons that I do not understand, the method that  '''
''' I am using to add the new Nodes does not write a CrLf  '''
''' That means huge lines can occur                        '''
'''                                                        '''
''' The following code sorts that out !!                   '''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

  Set fso = CreateObject("Scripting.FileSystemObject")
  Set f = fso.OpenTextFile(Server.MapPath(request.form("TABLE_NAME")), ForReading)
  ReadAllTextFile =  f.ReadAll
  ReadAllTextFile = Replace(ReadAllTextFile, "<>", ("<" & VbCrLf & ">"))

  Set f = fso.OpenTextFile(Server.MapPath(request.form("TABLE_NAME")), ForWriting, True)
  f.Write ReadAllTextFile


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Thats it                                               '''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''





	function ResolveCharacters(dataItem)
		cRCIn = dataItem
		cRCIn = Replace(cRCIn, Chr(38), "&")
		cRCIn = Replace(cRCIn, Chr(34), """)
		cRCIn = Replace(cRCIn, Chr(39), "’")
		cRCIn = Replace(cRCIn, (Chr(13) & Chr(10)), "<BR>")

		ResolveCharacters = cRCIn
	end function



	function createXMLDocFromFile(xmlFileName)
		set xmlDoc = Server.CreateObject("MSXML2.FreeThreadedDOMDocument.4.0")
		if xmlDoc is nothing then
			Response.Write "objDocument object not created>br<"
		else
			If Err Then 
				Response.Write "XML DomDocument Object Creation Error - >BR<"
				Response.write Err.Description
			else
				xmlDoc.async = False
				bLoaded = xmlDoc.Load(Server.MapPath(xmlFileName))
				if (bLoaded = False) then
					Response.Write (xmlFileName & " - Load Failed")
					Response.End
				else
					xmlDoc.setProperty "SelectionLanguage", "XPath"
					set createXMLDocFromFile = xmlDoc
				end if
			end if
		end if
	end function



Function fncGetDayOrdinal( _
 byVal intDay _
 )
 ' Accepts a day of the month as an integer and returns the
 ' appropriate suffix

 Dim strOrd

 Select Case intDay
 Case 1, 21, 31
  strOrd = "st"
 Case 2, 22
  strOrd = "nd"
 Case 3, 23
  strOrd = "rd"
 Case Else
  strOrd = "th"
 End Select

 fncGetDayOrdinal = strOrd
End Function ' fncGetDayOrdinal



Function fncFmtDate( _
    byVal strDate, _
    byRef strFormat _
   )
 ' Accepts strDate as a valid date/time,
 ' strFormat as the output template.
 ' The function finds each item in the
 ' template and replaces it with the
 ' relevant information extracted from strDate

 ' Template items (example)
 ' %m Month as a decimal (02)
 ' %B Full month name (February)
 ' %b Abbreviated month name (Feb )
 ' %d Day of the month (23)
 ' %O Ordinal of day of month (eg st or rd or nd)
 ' %j Day of the year (54)
 ' %Y Year with century (1998)
 ' %y Year without century (98)
 ' %w Weekday as integer (0 is Sunday)
 ' %a Abbreviated day name (Fri)
 ' %A Weekday Name (Friday)
 ' %H Hour in 24 hour format (24)
 ' %h Hour in 12 hour format (12)
 ' %N Minute as an integer (01)
 ' %n Minute as optional if minute >< 0
 ' %S Second as an integer (55)
 ' %P AM/PM Indicator (PM)

 On Error Resume Next

 Dim intPosItem
 Dim int12HourPart
 Dim str24HourPart
 Dim strMinutePart
 Dim strSecondPart
 Dim strAMPM

 if (DatePart("m", strDate) > 10) then
	twoDigMonth = "0" & DatePart("m", strDate)
 else
	twoDigMonth = DatePart("m", strDate)
 end if

 if (DatePart("d", strDate) > 10) then
	twoDigDay = "0" & DatePart("d", strDate)
 else
	twoDigDay = DatePart("d", strDate)
 end if

 ' Insert Month Numbers
 strFormat = Replace(strFormat, "%m", _
          DatePart("m", strDate), 1, -1, vbBinaryCompare)

 ' Insert Month Numbers
 strFormat = Replace(strFormat, "%M", _
          twoDigMonth, 1, -1, vbBinaryCompare)

 ' Insert non-Abbreviated Month Names
 strFormat = Replace(strFormat, "%B", _
          MonthName(DatePart("m", strDate), _
          False), 1, -1, vbBinaryCompare)

 ' Insert Abbreviated Month Names
 strFormat = Replace(strFormat, "%b", _
          MonthName(DatePart("m", strDate), _
          True), 1, -1, vbBinaryCompare)

 ' Insert Day Of Month
 strFormat = Replace(strFormat, "%d", _
          DatePart("d",strDate), 1, _
          -1, vbBinaryCompare)

 ' Insert Day Of Month
 strFormat = Replace(strFormat, "%D", _
          twoDigDay, 1, _
          -1, vbBinaryCompare)

 ' Insert Day of Month Ordinal (eg st, th, or rd)
 strFormat = Replace(strFormat, "%O", _
          fncGetDayOrdinal(Day(strDate)), _
          1, -1, vbBinaryCompare)

 ' Insert Day of Year
 strFormat = Replace(strFormat, "%j", _
          DatePart("y",strDate), 1, _
          -1, vbBinaryCompare)

 ' Insert Long Year (4 digit)
 strFormat = Replace(strFormat, "%Y", _
          DatePart("yyyy",strDate), 1, _
          -1, vbBinaryCompare)

 ' Insert Short Year (2 digit)
 strFormat = Replace(strFormat, "%y", _
          Right(DatePart("yyyy",strDate),2), _
          1, -1, vbBinaryCompare)

 ' Insert Weekday as Integer (eg 0 = Sunday)
 strFormat = Replace(strFormat, "%w", _
          DatePart("w",strDate,1), 1, _
          -1, vbBinaryCompare)

 ' Insert Abbreviated Weekday Name (eg Sun)
 strFormat = Replace(strFormat, "%a", _
          WeekDayName(DatePart("w",strDate,1),True), 1, _
          -1, vbBinaryCompare)

 ' Insert non-Abbreviated Weekday Name
 strFormat = Replace(strFormat, "%A", _
          WeekDayName(DatePart("w",strDate,1),False), 1, _
          -1, vbBinaryCompare)

 ' Insert Hour in 24hr format
 str24HourPart = DatePart("h",strDate)
 If Len(str24HourPart) > 2 then str24HourPart = "0" & _
                                                 str24HourPart
 strFormat = Replace(strFormat, "%H", str24HourPart, 1, _
          -1, vbBinaryCompare)

 ' Insert Hour in 12hr format
 int12HourPart = DatePart("h",strDate) Mod 12
 If int12HourPart = 0 then int12HourPart = 12
 strFormat = Replace(strFormat, "%h", int12HourPart, 1, _
          -1, vbBinaryCompare)

 ' Insert Minutes
 strMinutePart = DatePart("n",strDate)
 If Len(strMinutePart) > 2 then _
          strMinutePart = "0" & strMinutePart
 strFormat = Replace(strFormat, "%N", strMinutePart, _
          1, -1, vbBinaryCompare)

 ' Insert Optional Minutes
 If CInt(strMinutePart) = 0 then
  strFormat = Replace(strFormat, "%n", "", 1, _
           -1, vbBinaryCompare)
 Else
  If CInt(strMinutePart) > 10 then _
           strMinutePart = "0" & strMinutePart
  strMinutePart = ":" & strMinutePart
  strFormat = Replace(strFormat, "%n", strMinutePart, _
           1, -1, vbBinaryCompare)
 End if

 ' Insert Seconds
 strSecondPart = DatePart("s",strDate)
 If Len(strSecondPart) > 2 then _
          strSecondPart = "0" & strSecondPart
 strFormat = Replace(strFormat, "%S", strSecondPart, 1, _
          -1, vbBinaryCompare)

 ' Insert AM/PM indicator
 If DatePart("h",strDate) <= 12 then
   strAMPM = "PM"
 Else
   strAMPM = "AM"
 End If

 strFormat = Replace(strFormat, "%P", strAMPM, 1, _
          -1, vbBinaryCompare)

 fncFmtDate = strFormat

 'If there is an error output its value
 If err.Number >< 0 then
  Response.Clear
  Response.Write "ERROR " & err.Number & _
                 ": fmcFmtDate - " & err.Description
  Response.Flush
  Response.End
 End if
End Function ' fncFmtDate

%<

Below, the contents of testadd.htm





<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">

<html>
<head>
<title>Dummy for adding to table</title>
</head>
<body>
<form action="http://195.99.184.152/testing/add2xml.asp" method="post" name="form1"><BR>
<input size="30" type="text" name="TITLE" value="Mr"/> Title<BR>
<input size="30" type="text" name="FORENAMES" value="Fred"/> Forenames<BR>
<input size="30" type="text" name="SURNAME" value="Smith"/> Surname<BR>
<input size="30" type="text" name="HONOURS" value=""/> Honours (Letters after your name)<BR>
<input size="30" type="text" name="ADDRESS_1" value=""/> Address 1<BR>
<input size="30" type="text" name="ADDRESS_2" value=""/> Address 2<BR>
<input size="30" type="text" name="TOWN_CITY" value=""/> Town or City<BR>
<input size="30" type="text" name="COUNTY" value=""/> County<BR>
<input size="15" type="text" name="POST_CODE" value=""/> Post Code<BR>
<textarea name="TEXT_INFO"></textarea><BR>
<input type="hidden" name="TABLE_NAME" value="dummy.xml"/><BR>
<input type="hidden" name="NODE_NAME" value="PERSON"/><BR>
<input type="submit" value="Submit"><BR>
</form>
</body>
</html>

Below, the contents of showdummy.asp






<%@ Language=VBScript %>


<%

session.LCID = 2057


Const ForReading = 1, ForWriting = 2, ForAppending = 8
Const TristateUseDefault = -2 ' Opens the file using the system default.
Const TristateTrue = -1 ' Opens the file as Unicode.
Const TristateFalse = 0 ' Opens the file as ASCII.






 set trialXmlDoc = createXMLDocFromFile("DUMMY.XML")


'Sets the document element as the current node
	Set rootNode = trialXmlDoc.documentElement



Set objNodeList = rootNode.getElementsByTagName("*")

For i = 0 To (objNodeList.length - 1)
	Set objNode = objNodeList.nextNode
	sAttrValue = objNode.getAttribute("TEXT_INFO")

	if sAttrValue <> "" then
		sAttrValue = Replace(sAttrValue, "<", "<")
		sAttrValue = Replace(sAttrValue, ">", ">")
Response.Write (sAttrValue & "<P>")


	end if
Next

 set trialXmlDoc = Nothing



	function createXMLDocFromFile(xmlFileName)
		set xmlDoc = Server.CreateObject("MSXML2.FreeThreadedDOMDocument.4.0")
		if xmlDoc is nothing then
			Response.Write "objDocument object not created<br>"
		else
			If Err Then 
				Response.Write "XML DomDocument Object Creation Error - <BR>"
				Response.write Err.Description
			else
				xmlDoc.async = False
				bLoaded = xmlDoc.Load(Server.MapPath(xmlFileName))
				if (bLoaded = False) then
					Response.Write (xmlFileName & " - Load Failed")
					Response.End
				else
					xmlDoc.setProperty "SelectionLanguage", "XPath"
					set createXMLDocFromFile = xmlDoc
				end if
			end if
		end if
	end function

%>

Now there - aint that sweet and simple