listsheet.htc

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

<PUBLIC:COMPONENT URN='Commerce.ListSheet' tagName="listsheet" lightweight=true>
	<PUBLIC>
		<!-- ids of xml data and meta-data islands -->
		<PROPERTY NAME='DataXML' />
		<PROPERTY NAME='MetaXML' />
		<!-- read-only scriptable property: returns entire XML data list -->
		<PROPERTY NAME='xmlList'	Get='xmlGetList' />
		<PROPERTY NAME='page'		Get='nGetPage'			Put='SetPage' />
		<PROPERTY NAME='recordcount'	Get='nGetRecordcount'	Put='SetRecordcount' />

		<EVENT NAME='OnError'			ID='evtError'></EVENT><!-- fired when developer error occurs -->
		<EVENT NAME='OnDblClickRow'		ID='evtDblClickRow'></EVENT><!-- fired row double-clicked on -->
		<EVENT NAME='OnContextClick'	ID='evtContextClick'></EVENT><!-- fired row context menu item clicked on -->
		<EVENT NAME='OnRowSelect'		ID='evtRowSelected'></EVENT><!-- fired when unselected row clicked on -->
		<EVENT NAME='OnRowUnselect'		ID='evtRowUnselected'></EVENT><!-- fired when selected row clicked on -->
		<EVENT NAME='OnAllRowsSelect'	ID='evtAllRowsSelected'></EVENT><!-- fired when select all rows button clicked on -->
		<EVENT NAME='OnAllRowsUnselect'	ID='evtAllRowsUnselected'></EVENT><!-- fired when unselect all rows button clicked on -->
		<EVENT NAME='OnGroupOpen'		ID='evtGroupOpen'></EVENT><!-- fired when group is opened -->
		<EVENT NAME='OnHeaderClick'		ID='evtHeaderClicked'></EVENT><!-- fired when column heading clicked on -->
		<EVENT NAME='OnNewPage'			ID='evtNewPage'></EVENT><!-- fired when page button clicked on or new page entered in page input -->

		<METHOD NAME='SelectAllRows'	INTERNALNAME='onSelectAll' /><!-- selects all rows (except subobjects) -->
		<METHOD NAME='UnselectAllRows'	INTERNALNAME='onUnselectAll' /><!-- unselects all rows (except subobjects) -->
		<METHOD NAME='reload'			INTERNALNAME='Reload' /><!-- fetchs new list using form elements and args -->
	</PUBLIC>

	<SCRIPT LANGUAGE='VBScript'>
		Option Explicit

		'define all localizable strings
		const L_Loading_Text = "Loading list, please wait..."
		const L_AbortControl_ErrorMessage = "The control could not load.  Please contact your system administrator"
		const L_ControlURNandID_ErrorMessage = "Error in ListSheet with id: ""%1"""
		const L_IDNotFound_ErrorMessage = "element not found in document with id: ""%1"""
		const L_IDNotUnique_ErrorMessage = "element id not unique in document: ""%1"""
		const L_MetaXMLErrorAtCharLine_ErrorMessage = "MetaXML ""%1"" at char %2 in line %3:"
		const L_DataXMLErrorAtCharLine_ErrorMessage = "DataXML ""%1"" at char %2 in line %3:"
		const L_SourceCode_ErrorMessage = "Source code:"
		const L_SelectAllBtn_Button = "Select All"
		const L_UnselectAllBtn_Button = "Deselect All"
		const L_ListTotal_Text = "List total: "
		const L_Page_Text = "Page: "
		const L_PageInput_ToolTip = "Type a page number"
		const L_FirstPage_ToolTip = "First page"
		const L_BackPage_ToolTip = "Previous page"
		const L_NextPage_ToolTip = "Next page"
		const L_LastPage_ToolTip = "Last page"
		const L_NoItemsMatch_Message = "No items match this search."
		const L_SpecifyFind_Message = "Specify items to find above, and click the ""find"" button."
		const L_SortBy_ToolTip = "Sort by %1"
		const L_TooManyPages_ErrorMessage = "Warning: Number of pages is greater than the maximum allowed (9,999). Please specify a filter or further search criteria to fetch a smaller list."
		const L_TooManyRecords_ErrorMessage = "Warning: Number of records is greater than the maximum allowed (2,000,000,000). Please specify a filter or further search criteria to fetch a smaller list."
		const L_PageNumberLimit_ErrorMessage = "Page numbers must be between 1 and the number of available pages"
		const L_HTTPErrorOccured_ErrorMessage = "An HTTP error occurred."
		const L_XMLErrorOccured_ErrorMessage = "An XML error occurred."
		const L_ASPPageErrorOccured_ErrorMessage = "The ASP page reported an error."
		const L_Warning_DialogTitle = "Warning"
		const L_Error_DialogTitle = "Error"
		const L_CodeReasonURL_ErrorMessage = "Code : %1<BR>Reason : %2<BR>URL : %3"
		const L_CodeSourceDescription_ErrorMessage = "Code : %1<BR>Source : %2<BR>Description : %3"
		const L_HTTPErrorURL_ErrorMessage = "HTTP error %1 : %2<BR>URL : %3"
		const L_NoXMLDocument_ErrorMessage = "No xml document returned"
		const L_NoDetails_ErrorMessage = "no details"

		Dim m_xmlDataDoc, m_xmlMetaDoc, m_xmlMetaGlobal, m_xmlMetaColumns, m_xmlMetaSubColumns, _
			m_xmlSubNode, m_elLeftCol, m_elRightCol, m_elRecordcountDisplay, m_elDragTab, _
			m_elHeadTable, m_elMasterTable, m_elGroupTable, m_elDetailTable, m_elPageDisplay, _
			m_elPageNumInput, m_elFirstPageBtn, m_elBackPageBtn, m_elNextPageBtn, _
			m_elHighlighted, m_elLastPageBtn, m_elSelAllBtn, m_elUnselAllBtn, m_elPageContainer, _
			m_elWaitDisplay, m_elSelControls, m_elEmptyTable, m_elPageControlsDisplay, _
			m_elTotalrecords, m_elCurPage, m_sSortDir, m_sSortCol, m_xmlIDTransformDoc, _
			m_nCombWidth, m_nCurPage, m_nPageCount, m_nRecordcount, m_nPageSize, _
			m_nLeftWidth, m_nRightWidth, m_nTotalWidth, m_nTableWidth, m_mx, m_bDebugHTTPXML, _
			m_bDebug, m_bSubObject, m_bDataFound, m_bMultiSelect, m_bSelectAll, m_bPageControls, _
			m_bSubEditSheet, m_bGrouped, m_bSubGrouped, m_bSelectionButtons, m_bLoading, _
			m_bEmptyPrompt, m_dSelectedRows, m_sContextMenuID, m_sContextMenuWidth, _
			m_xmlContextRecord, m_elBDContextMenu

		'show wait cursor and set loading flag
		addclass element, "wait"
		m_bLoading = true

		'constant for maximum page numbers
		const MAX_PAGE_COUNT		= 9999
		const UNKNOWN_PAGE_NUMBER	= -1
		'constant for maximum record count
		const MAX_RECORD_COUNT		= 2000000000
		const UNKNOWN_RECORD_COUNT	= -1
		'webding character constants:
		const FIRST_ARROW	= 9
		const LEFT_ARROW	= 3
		const RIGHT_ARROW	= 4
		const LAST_ARROW	= ":"
		'expand icon characters
		const PLUS			= "+"
		const MINUS			= "-"
		'keycode constants
		const KEYCODE_SPACE			= 32
		const KEYCODE_ENTER			= 13
		const KEYCODE_UP_ARROW		= 38
		const KEYCODE_DOWN_ARROW	= 40
		const KEYCODE_TAB			= 9
		const KEYCODE_F10			= 121

		' when true all developer errors will display in an alert
		m_bDebug = false
		' when true http/xml calls will display sent and received in msgbox
		m_bDebugHTTPXML = false

		set m_elBDContextMenu = nothing	'current context menu
		set m_dSelectedRows = CreateObject("Scripting.Dictionary")	'dictionary for holding selected rows
		set m_xmlDataDoc = nothing		'used to hold data document
		set m_xmlMetaDoc = nothing		'used to hold meta-data document
		set m_elHighlighted = nothing	'used to hold currently highlighted row
		m_elMasterTable = null	'table for data binding
		m_elGroupTable = null	'table for subgroup (2nd level) data binding
		m_elDetailTable = null	'table for detail data binding
		m_elHeadTable = null	'table for headings
		m_bDataFound = true		'this is set to false when there is no data doc so different empty prompt displayed
		m_nTableWidth = 0		'accumulator for table width; used to reduce redraw
		m_nPageCount = 1		'defaults to one page of data
		m_nCurPage = 1			'defaults to page 1 of data
		set m_xmlIDTransformDoc = CreateObject("MSXML.DOMDocument")	'used to hold ID transform xsl

		'the following are used exclusively when loading the XML documents
		dim m_bMetaXMLReady, m_bDataXMLReady, m_bControlInitialized, m_bControlAborted
		m_bMetaXMLReady = false			'true when meta-data XML is loaded and parsed
		m_bDataXMLReady = false			'true when data XML is loaded and parsed
		m_bControlInitialized = false	'true when all data is loaded initialization has started
		m_bControlAborted = false		'true when errors have forced the control to abort running

		const READYSTATE_COMPLETE = 4	'constant used to check XML document's readyState

		Initialize()

		sub Initialize()
			'if not in debug mode then hide errors
			if not m_bDebug then on error resume next

			if bIsXMLOK(MetaXML) then
				'if meta-data XML island looks ok load the XML document
				LoadXML MetaXML, m_bMetaXMLReady
				'if data XML island is not defined create an empty record from the meta-data
				if not m_bControlAborted and isNull(DataXML) then
					'load from meta (set datafound so correct prompt can be displayed)
					m_bDataFound = false
					set m_xmlDataDoc = xmlGetDataFromMeta()
					if m_xmlDataDoc is nothing then
						AbortControl()
					else
						m_bDataXMLReady = true
					end if
				elseif not m_bControlAborted then
					'if data XML island looks ok load the XML document
					LoadXML DataXML, m_bDataXMLReady
				end if
				if not m_bControlAborted and m_bMetaXMLReady and m_bDataXMLReady then
					'if all XML loaded and no abort errors found, go initialize control
					InitControl()
				'else = otherwise InitControl will be run by onXMLReadyStateChange or control was aborted
				end if
			end if
		end sub

		sub LoadXML(sXML, bReady)
			dim elXML, xmlDoc
			'when this routine complete either XML is loaded, control aborted or
			'event attached for async load
			if bIsXMLOK(sXML) then
				'get data island element
				set elXML = element.document.all(sXML)
				'get XML document
				set xmlDoc = elXML.xmlDocument
				'attach onReadyStateChange event for async load of XML
				elXML.attachEvent "onreadystatechange", GetRef("onXMLReadyStateChange")
				'check if already complete
				if elXML.readyState = "complete" then
					if xmlDoc.parseError.errorCode = 0 then
						'readyState is complete and no parse errors
						bReady = true
					else
						'parse errors: detach event, show error, and abort control
						elXML.detachEvent "onreadystatechange", GetRef("onXMLReadyStateChange")
						ShowXMLError sXML, xmlDoc
						AbortControl()
					end if
				end if
			end if
		end sub

		function bIsXMLOK(oXML)
			dim elXML
			'when this routine complete we know id is OK and references unique element
			'otherwise control is aborted after displaying error
			bIsXMLOK = true
			if isNull(oXML) then
				'if id is bad or missing
				ReportError(sFormatString(L_IDNotFound_ErrorMessage, Array(oXML)))
				AbortControl()
				bIsXMLOK = false
			else
				set elXML = element.document.all(oXML)
				if elXML is nothing then
					'if id is not found in the document
					ReportError(sFormatString(L_IDNotFound_ErrorMessage, Array(oXML)))
					AbortControl()
					bIsXMLOK = false
				elseif typename(elXML) = "DispHTMLElementCollection" then
					'if id is not unique in the document
					ReportError(sFormatString(L_IDNotUnique_ErrorMessage, Array(oXML)))
					AbortControl()
					bIsXMLOK = false
				end if
			end if
		end function

		sub onXMLReadyStateChange
			dim elSource
			'this routine completes async load of XML document
			set elSource = window.event.srcElement
			if elSource.readyState = "complete" then
				if elSource.XMLdocument.parseError.errorCode = 0 then
					'readyState is complete and no parse errors
					'document is loaded and parsed so detach event
					elSource.detachEvent "onreadystatechange", GetRef("onXMLReadyStateChange")
					'mark XML source as ready
					select case elSource.id
						case MetaXML
							m_bMetaXMLReady = true
						case DataXML
							m_bDataXMLReady = true
					end select
				else
					'parse errors: detach event, show error, and abort control
					elXML.detachEvent "onreadystatechange", GetRef("onXMLReadyStateChange")
					ShowXMLError sXML, elSource.XMLdocument
					AbortControl()
				end if
			end if
			if not m_bControlAborted and m_bMetaXMLReady and m_bDataXMLReady then
				'all XML loaded, go initialize control
				InitControl()
			'else = otherwise wait for next event
			end if
		end sub

		sub AbortControl()
			dim elFont
			'sets flag for aborted control and displays error text in element
			m_bControlAborted = true
			element.innerText = ""
			set elFont = element.appendChild(element.document.createElement("SPAN"))
			elFont.style.color = "red"
			elFont.style.fontWeight = "bold"
			element.title = L_AbortControl_ErrorMessage
			elFont.innerText = L_AbortControl_ErrorMessage
		end sub

		sub InitControl()
			dim xmlTemp, sTemp, xmlDoc, xml
			'ensure InitControl is only run once
			if m_bControlInitialized then exit sub
			m_bControlInitialized = true

			'get documentElement's for XML already loaded
			set m_xmlMetaDoc = element.document.all(MetaXML).xmlDocument.documentElement
			if m_xmlMetaDoc is nothing then
				'workwround code:
				set xmlDoc = CreateObject("MSXML.DOMDocument")
				xmlDoc.loadXML(element.document.all(MetaXML).innerHTML)
				set m_xmlMetaDoc = xmlDoc.documentElement
			end if
			set m_xmlDataDoc = element.document.all(DataXML).xmlDocument.documentElement
			if m_xmlDataDoc is nothing then
				'workwround code:
				set xmlDoc = CreateObject("MSXML.DOMDocument")
				xmlDoc.loadXML(element.document.all(DataXML).innerHTML)
				set m_xmlDataDoc = xmlDoc.documentElement
			end if
			if not m_xmlDataDoc.hasChildNodes then m_xmlDataDoc.appendChild(m_xmlDataDoc.ownerDocument.createElement("record"))
			if element.document.all(DataXML).tagName = "SCRIPT" then
				'if xml in SCRIPT tag then rewrite in XML tag to enable data binding
				element.document.all(DataXML).id = DataXML & "_old"
				element.document.all(DataXML & "_old").insertAdjacentHTML "afterEnd", "<xml id='" & DataXML & "'></xml>"
				set xmlDoc = element.document.all(DataXML).XMLDocument
				xmlDoc.loadxml(m_xmlDataDoc.xml)
				set m_xmlDataDoc = xmlDoc.documentElement
			end if
			if inStr(m_xmlDataDoc.xml, "&amp;#13;") > 0 then
				m_xmlDataDoc.ownerDocument.loadXML replace(m_xmlDataDoc.xml, "&amp;#13;", "¶")
			end if
			set m_xmlMetaColumns = m_xmlMetaDoc.selectSingleNode("//columns")
			set m_xmlMetaGlobal = m_xmlMetaDoc.selectSingleNode("//global")
			sTemp = m_xmlMetaGlobal.getAttribute("selection")
			m_bMultiSelect = CBool(not isNull(sTemp) and LCase(sTemp) = "multi")
			sTemp = m_xmlMetaGlobal.getAttribute("selectall")
			m_bSelectAll = CBool(m_bMultiSelect and not isNull(sTemp) and LCase(sTemp) = "yes")

			'set context menu, if any
			m_sContextMenuID = m_xmlMetaGlobal.getAttribute("contextmenuid")
			if not isNull(m_sContextMenuID) and m_sContextMenuID <> "" then
				set m_elBDContextMenu = eval(m_sContextMenuID)
				if not m_elBDContextMenu is nothing then
					m_sContextMenuWidth = m_xmlMetaGlobal.getAttribute("contextmenuwidth")
					if isNull(m_sContextMenuWidth) or m_sContextMenuWidth <> "" then m_sContextMenuWidth = "220px"
					element.attachEvent "oncontextmenu", GetRef("showContextMenuEx")
					element.attachEvent "onkeydown", GetRef("onContextMenuKeyDown")
					m_elBDContextMenu.attachEvent "onreadystatechange", GetRef("SetContextHTC")
					m_elBDContextMenu.style.behavior = "url(/widgets/listHTC/menucontrol.htc)"
				end if
			end if

			'get recordcount from recordset
			sTemp = m_xmlDataDoc.getAttribute("recordcount")
			if not isNull(sTemp) and isNumeric(sTemp) then
				m_nRecordcount = CLng(sTemp)
				m_xmlDataDoc.removeAttribute("recordcount")
			end if
			FormatData m_xmlDataDoc, "./columns/column", "id"
			FormatData m_xmlDataDoc, "./columns/column", "id2"
			FormatData m_xmlDataDoc, "./columns/column", "id3"
			FormatData m_xmlDataDoc, "./columns/subobject/column", "id"
			set xmlTemp = m_xmlMetaColumns.selectSingleNode("*[@id2]")
			m_bGrouped = CBool(not xmlTemp is nothing)
			set xmlTemp = m_xmlMetaColumns.selectSingleNode("*[@id3]")
			m_bSubGrouped = CBool(not xmlTemp is nothing)
			set m_xmlMetaSubColumns = m_xmlMetaDoc.selectSingleNode("./columns/subobject")
			m_bSubObject = CBool(not m_xmlMetaSubColumns is nothing)
			if m_bSubObject then
				m_bGrouped = true
				sTemp = m_xmlMetaSubColumns.getAttribute("type")
				m_bSubEditSheet = CBool(not isNull(sTemp) and LCase(sTemp) = "properties")
			end if

			'add bd_queryid node for each record
			m_xmlIDTransformDoc.loadXML GetIDTransformXSL()
			set xml = CreateObject("MSXML.DOMDocument")
			m_xmlDataDoc.transformNodeToObject m_xmlIDTransformDoc, xml
			m_xmlDataDoc.ownerDocument.loadxml(xml.xml)
			set m_xmlDataDoc = m_xmlDataDoc.ownerDocument.documentElement