listsheet.htc

这是一个使用DHTML技术显示的功能

			UpdateList()
			'attach event handlers for wait display control
			m_elMasterTable.attachEvent "onreadystatechange", GetRef("hideWaitDisplayEX")
			window.attachEvent "onload", GetRef("HideWaitDisplay")
			m_elMasterTable.datasrc = "#" & DataXML
			if m_bGrouped then
				if m_bSubGrouped then
					m_elGroupTable.datasrc = "#" & DataXML
				end if
				m_elDetailTable.datasrc = "#" & DataXML
			end if
		end sub

		sub SetContextHTC()
			dim elSource
			set elSource = window.event.srcElement
			if elSource.readystate = "complete" then
				elSource.detachEvent "onreadystatechange", GetRef("SetContextHTC")
				elSource.attachEvent "onhighlight", GetRef("toggleContextMenuHighlight")
				elSource.attachEvent "onunhighlight", GetRef("toggleContextMenuHighlight")
				elSource.attachEvent "onclose", GetRef("closeContextMenu")
				elSource.attachEvent "onexecute", GetRef("clickContextMenuItem")
			end if
		end sub

		Function sFormatString(sFormat, aArgs)
			dim nArg, sNewString
			'formats strings like C format using numbered arguments (%1, %2, &tc.)
			'call like: sText = sFormatString(sOriginalText, Array(sArg1, sArg2, ...))
			sNewString = sFormat
			for nArg = LBound(aArgs) to UBound(aArgs)
				sNewString = Replace(sNewString, "%" & nArg + 1, aArgs(nArg))
			next
			sFormatString = sNewString
		End Function

		sub ReportError(strMessage)
			dim evt
			strMessage = sFormatString(L_ControlURNandID_ErrorMessage, Array(element.id)) & vbCrLf & vbCrLf & strMessage
			' Display the message if in debug-mode.
			if m_bDebug = true then alert(strMessage)
			'set result on error event and then fire it
			set evt = createEventObject()
			evt.setAttribute "error", strMessage
			evt.type = "error"
			evtError.fire(evt)
		end sub

		sub ShowXMLError(sType, xml)
			Dim sBuffer
			'create xml error text and then call ReportError with it
			if sType = "meta" then
				sBuffer = sBuffer & sFormatString(L_MetaXMLErrorAtCharLine_ErrorMessage, Array(metaXML, xml.parseError.linePos, xml.parseError.line))
			else
				sBuffer = sBuffer & sFormatString(L_DataXMLErrorAtCharLine_ErrorMessage, Array(dataXML, xml.parseError.linePos, xml.parseError.line))
			end if
			sBuffer = sBuffer & vbCrLf & xml.parseError.reason & vbCrLf
			sBuffer = sBuffer & L_SourceCode_ErrorMessage & vbCrLf
			sBuffer = sBuffer & xml.parseError.srcText
			ReportError(sBuffer)
		end sub

		function xmlXMLFromForm(byRef elForm)
			dim xmlDOMDoc, xmlDoc, xmlItemNode, elField
			set xmlDOMDoc = xmlGetXMLDOMDoc()
			set xmlDoc = xmlDOMDoc.documentElement
			for each elField in elForm.elements
				if elField.name <> "" then
					if LCase(elField.getAttribute("type")) = "checkbox" or _
						LCase(elField.getAttribute("type")) = "radio" then
						if elField.checked then
							AddItemNode xmlDoc, elField.name, elField.value
						end if
					elseif elField.tagName = "select" then
						AddItemNode xmlDoc, elField.name, elField.options(elField.selectedIndex).value
					else
						AddItemNode xmlDoc, elField.name, elField.value
					end if
				end if
			next
			set xmlXMLFromForm = xmlDOMDoc
		end function

		function xmlGetXMLDOMDoc()
			dim xmlDOMDoc
			set xmlDOMDoc = CreateObject("MSXML.DOMDocument")
			set xmlDOMDoc.documentElement = xmlDOMDoc.createElement("document")
			set xmlGetXMLDOMDoc = xmlDOMDoc
		end function

		sub AddItemNode(byRef xmlDoc, byVal sName, byVal sValue)
			dim xmlDOMDoc, xmlItemNode
			set xmlDOMDoc = xmlDoc.ownerDocument
			set xmlItemNode = xmlDoc.appendChild(xmlDOMDoc.createElement("item"))
			xmlItemNode.setAttribute "name", sName
			xmlItemNode.setAttribute "value", sValue
		end sub

		Function xmlPostToServer(strURL, xmlDOMDoc)
			Dim xmlhttpObj, bSuccess, xmlResponse, oParseError, xmlError, xmlErrors, _
				xmlWarnings, xmlWarning, bAsync, xmlGlobal, nRecordCount, sOp, _
				iStart, sDetails, iEnd

			on error resume next
			' Create an XMLHTTP object to POST to the server.  Set the operation to
			' be synchronous.  Set up the header so IIS will grok the request body.
			Set xmlhttpObj = CreateObject("MSXML2.XMLHTTP.2.6")
			sOp = xmlDOMDoc.selectSingleNode("//item[@name = 'op']").getAttribute("value")

			'display debug info
			if m_bDebugHTTPXML then alert "sending: " & xmlDOMDoc.xml

			bAsync = False
			xmlhttpObj.open "POST", strURL, bAsync

			' Send the request.  Get a response.  Whoa, rocket-science.
			xmlhttpObj.send xmlDOMDoc

			' Analyze the response now.
			bSuccess = True

			' Check for HTTP errors.
			If xmlhttpObj.status <> 200 Then
				'parse if from the 500error.asp page
				' (this parses out everything but the error information)
				iStart = inStr(xmlhttpObj.responseText, "bderrordetails")
				if iStart > 0 then
					iStart = inStr(xmlhttpObj.responseText, "<li>")
					sDetails = mid(xmlhttpObj.responseText, iStart)
					iEnd = inStr(sDetails, "</TD>") - 1
					sDetails = left(sDetails, iEnd)
				else
					'not 500error.asp so no details
					sDetails = ""
				end if
				ShowErrorDialog L_HTTPErrorOccured_ErrorMessage, _
					sFormatString(L_HTTPErrorURL_ErrorMessage, _
					Array(xmlhttpObj.statusText, sDetails, strURL))
				bSuccess = False
			elseif Err.number <> 0 Then
				ShowErrorDialog L_HTTPErrorOccured_ErrorMessage, _
					sFormatString(L_HTTPErrorURL_ErrorMessage, _
					Array("0x" & Hex(Err.number), Err.description, strURL))
				bSuccess = False
			End If

			'display debug info
			if m_bDebugHTTPXML then alert "received (text): " & xmlhttpObj.responseText

			' Check for XML parse errors.
			If bSuccess Then
				Set xmlResponse = xmlhttpObj.responseXML
				Set oParseError = xmlResponse.parseError
				If oParseError.errorCode <> 0 Then
					ShowErrorDialog L_XMLErrorOccured_ErrorMessage, _
						sFormatString(L_CodeReasonURL_ErrorMessage, _
						Array("0x" & Hex(oParseError.errorCode), _
						oParseError.reason, strURL))

					bSuccess = False
				else
					'display debug info
					if m_bDebugHTTPXML then alert "received (xml): " & xmlResponse.xml
				End If
				if xmlResponse.documentElement is nothing then
					ShowErrorDialog L_NoXMLDocument_ErrorMessage, L_NoDetails_ErrorMessage
					bSuccess = False
				end if
			End If

			' Check for ASP errors or warnings (reported using <ERROR> and <WARNING> format).
			If bSuccess Then
				Set xmlErrors = xmlResponse.selectNodes("//*[nodeName() $ieq$ 'error']")
				Set xmlWarnings = xmlResponse.selectNodes("//*[nodeName() $ieq$ 'warning']")
				'display warnings unless there are errors to display
				If xmlErrors.length > 0 Then
					for each xmlError in xmlErrors
						dim nErr
						nErr = xmlError.getAttribute("id")
						if isNumeric(nErr) then nErr = "0x" & Hex(CLng(nErr))
						ShowErrorDialog L_ASPPageErrorOccured_ErrorMessage, _
							sFormatString(L_CodeSourceDescription_ErrorMessage, _
							Array(nErr, xmlError.getAttribute("source"), xmlError.text))
						xmlError.parentNode.removeChild(xmlError)
					next
					bSuccess = False
				elseIf xmlWarnings.length > 0 Then
					HideWaitDisplay()
					for each xmlWarning in xmlWarnings
						msgbox xmlWarning.text, vbOKOnly, L_Warning_DialogTitle
						xmlWarning.parentNode.removeChild(xmlWarning)
					next
					if xmlResponse.selectNodes("record").length = 0 then bSuccess = False
				End If
			End If

			' get recordcount
			If bSuccess Then
				nRecordCount = xmlResponse.documentElement.getAttribute("recordcount")
				if sOp = "sublist" then
					'ignore recordcount for sublist
					xmlResponse.documentElement.removeAttribute("recordcount")
				elseif not isNull(nRecordCount) and isNumeric(nRecordCount) then
					SetRecordcount(CLng(nRecordCount))
					xmlResponse.documentElement.removeAttribute("recordcount")
				else
					SetRecordcount(-1)
				end if
				if not xmlResponse.documentElement.hasChildNodes then xmlResponse.documentElement.appendChild(xmlResponse.createElement("record"))
			End If

			' If we failed, return Nothing.
			If Not(bSuccess) Then
				Set xmlResponse = Nothing
				HideWaitDisplay()
			End If

			Set xmlPostToServer = xmlResponse
		End Function

		Sub ShowErrorDialog(strError, strDetails)
			Dim dictArgs

			HideWaitDisplay()

			Set dictArgs = CreateObject("Scripting.Dictionary")

			dictArgs("error") = strError
			dictArgs("details") = strDetails

			Call showModalDialog("/widgets/DlgError.htm", dictArgs, _
				"status:no;help:no")
		End Sub

		function xmlGetDataFromMeta()
			dim xmlRecord, cIndex, xmlData
			DataXML = element.document.uniqueID
			element.document.all(MetaXML).insertAdjacentHTML "afterEnd", "<xml id='" & DataXML & "'></xml>"
			set xmlData = CreateObject("MSXML.DOMDocument")
			set xmlData.documentElement = xmlData.createElement("document")
			set xmlRecord = xmlData.documentElement.appendChild(xmlData.createElement("record"))
			set m_xmlMetaColumns = element.document.all(MetaXML).xmlDocument.documentElement.selectSingleNode("columns")
			for cIndex = 0 to m_xmlMetaColumns.childNodes.length - 1
				xmlRecord.appendChild(xmlData.createElement(m_xmlMetaColumns.selectNodes("column")(cIndex).getAttribute("id")))
			next
			element.document.all(DataXML).loadxml xmlData.xml
			if xmlData.parseError.errorCode = 0 then
				if not isNull(xmlData.documentElement) then
					set xmlGetDataFromMeta = xmlData.documentElement
				end if
			else
				xmlGetDataFromMeta = nothing
				ShowXMLError "data", xmlData
			end if
		end function

		function elGetContainer(elElement, sKey, sValue)
			Dim elTemp, elTemp2
			' returns nothing, self, or first ancester node to match
			'sKey property/method value
			set elTemp = elElement
			set elTemp2 = elElement
			do while not isNull(elTemp) and not elTemp is nothing and (elTemp.tagName <> "BODY")
				if eval("elTemp." & sKey & " = """ & sValue & """") then
					set elTemp2 = elTemp
					set elGetContainer = elTemp2
					exit function
				end if
				set elTemp = elTemp.parentElement
			loop
			set elGetContainer = elTemp2
		end function

		sub AddClass(elItem, sNewClass)
			'adds newclass to item's classname if not already there
			if inStr(elItem.className, sNewClass) then exit sub
			elItem.className = elItem.className & " " & sNewClass
		end sub

		sub RemoveClass(elItem, sOldClass)
			'removes oldclass from the item's classname and also removes extra spaces
			if inStr(elItem.className, sOldClass) then
				elItem.className = replace(replace(elItem.className, sOldClass, ""), "  ", " ")
			end if
		end sub

		function bHasClass(elItem, sClass)
			'returns true if item's classname contains class
			bHasClass = CBool(inStr(elItem.className, sClass))
		end function

		sub UpdateList()
			dim xmlColumns, xmlMetaCol, xmlHidden, _
				elContainer, elTableTemp, elRow, elCell, elHeadRow, elCells, _
				elSubGroupCells, elDetailCells, elMasterDataRow, elSubMasterRow, _
				elGroupDataRow, elSubGroupRow, elDetailDataRow, _
				bEmptyRecordset, bHeaders, bSort, bScroll, _
				sWidth, sFormat, sMasterID, sGroupID, sDetailID,  _
				nDefaultWidth, nCols, nCol, nCell, nHeadCellWidth

			element.innerText = ""

			set xmlHidden = m_xmlMetaColumns.selectNodes("*[@hide $ieq$ 'yes']")
			for nCol = 0 to xmlHidden.length - 1
				m_xmlMetaColumns.appendChild(m_xmlMetaColumns.removeChild(xmlHidden(nCol)))
			next
			set xmlColumns = m_xmlMetaColumns.selectNodes("column[$not$ @hide $or$ @hide $ine$ 'yes']")
			nCols = xmlColumns.length
			bHeaders = CBool(isNull(m_xmlMetaGlobal.getAttribute("headers")) or _
						LCase(m_xmlMetaGlobal.getAttribute("headers")) = "yes")
			bSort = CBool(isNull(m_xmlMetaGlobal.getAttribute("sort")) or _
						LCase(m_xmlMetaGlobal.getAttribute("sort")) = "yes")
			bScroll = CBool(isNull(m_xmlMetaGlobal.getAttribute("scroll")) or _
						LCase(m_xmlMetaGlobal.getAttribute("scroll")) = "yes")
			m_bPageControls = CBool(isNull(m_xmlMetaGlobal.getAttribute("pagecontrols")) or _
						LCase(m_xmlMetaGlobal.getAttribute("pagecontrols")) = "yes")
			m_bSelectionButtons = CBool(isNull(m_xmlMetaGlobal.getAttribute("selectionbuttons")) or _
						LCase(m_xmlMetaGlobal.getAttribute("selectionbuttons")) = "yes")
			m_bEmptyPrompt = CBool(isNull(m_xmlMetaGlobal.getAttribute("emptyprompt")) or _
						LCase(m_xmlMetaGlobal.getAttribute("emptyprompt")) = "yes")
			bEmptyRecordset = CBool(not (m_xmlDataDoc.hasChildNodes and _
							m_xmlDataDoc.firstChild.selectNodes("*[. != '']").length > m_xmlDataDoc.firstChild.selectNodes("record").length + 1))

			' create template table
			set elTableTemp = element.document.createElement("TABLE")
			with elTableTemp
				.cellPadding = 0
				.cellSpacing = 0
				.className = "lsTableStyle"
			end with

			if bHeaders then
				' create heading table
				set elContainer = element.appendChild(element.document.createElement("DIV"))
				elContainer.style.paddingRight = "15px"
				elContainer.style.width = "100%"
				set m_elHeadTable = elContainer.appendChild(elTableTemp.cloneNode(true))
				m_elHeadTable.id = "lsheadtable"
				set elHeadRow = m_elHeadTable.createTHead()
				set elHeadRow = elHeadRow.insertRow()