Option Explicit
' ======================================================================================
' Desc: This code show how to create a simple treeview class using ASP and Cascading Stylesheets.
' Great for programmers who want to learn how to create simple ASP controls.
'
' Author: Tanwani Anyangwe (tanwani@aspwebsolution.com)
'
' Requires: ASP 2.1 +
'
' Copyright © 2001 Tanwani Anyangwe for AspWebSolution.com
' --------------------------------------------------------------------------------------
' Visit AspWebSolution - free source code for ASP & AS.NET programmers
' [URL unfurl="true"]http://aspwebsolution.com[/URL]
' --------------------------------------------------------------------------------------
'
' Please ensure you visit the site and read their free source licensing
' information and requirements before using their code in your own
' application.
'
' ======================================================================================
'To keep a global count of howmany nodes have been created
Dim NODE_COUNTER : NODE_COUNTER = 1
'String buffer - way faster than concatenating strings (e.g. string1 & string2 - use buffer.Append(myString))
Class Buffer
Private dic
Private counter
Private Sub Class_Initialize()
counter = 0
'Set dic = Server.CreateObject("Scripting.Dictionary")
Set dic = CreateObject("Scripting.Dictionary")
End Sub
Private Sub Class_Terminate()
Set dic = Nothing
End Sub
Private Function GetKey()
GetKey = CStr(counter + 1)
counter = counter + 1
End Function
Public Sub Append(vStr)
Call dic.Add(GetKey(), vStr)
End Sub
Public Function ToString()
ToString = Join(dic.Items)
End Function
End Class
Class Collection
Private m_next,m_len
Private m_dic
Public Sub Add(Item)
m_dic.Add "K" & m_next,Item
m_next = m_next+1
m_len = m_len+1
End Sub
Public Sub Clear
m_dic.RemoveAll
End Sub
Public Function Length
Length=m_len
End Function
Public Default Function Item(Index)
Dim tempItem,i
For Each tempItem In m_dic.Items
If i=Index Then
Set Item=tempItem
Exit Function
End If
i=i+1
Next
End Function
Public Sub Remove(ByVal Index)
Dim Item,i
For Each Item In m_dic.Items
If i=Index Then
m_dic.Remove(Item)
m_len=m_len-1
Exit Sub
End If
i=i+1
Next
End Sub
Private Sub Class_Initialize
m_len=0
'Set m_dic = Server.CreateObject("Scripting.Dictionary")
Set m_dic = CreateObject("Scripting.Dictionary")
End Sub
Private Sub Class_Terminate
Set m_dic = Nothing
End Sub
Public Function GetXml(parentid)
Dim buf
Set buf = New Buffer
Dim item
'buf.Append("<items>")
For Each item In m_dic.Items
buf.Append(item.GetXml(parentid))
Next
'buf.Append("</items>")
GetXml = buf.ToString
Set buf = Nothing
End Function
End Class
Class Node
'Public Parent
Public Text
Public Href
Public Target
Public ToolTipText
Public ChildNodes
Public ImageUrl
Public ID
Public Sub Init(strText,strHref,strToolTipText)
Text=strText
Href=strHref
ToolTipText=strToolTipText
End Sub
Public Sub Add(objNode)
ChildNodes.Add(objNode)
End Sub
Private Sub Class_Initialize
Set ChildNodes = New Collection
ID = NODE_COUNTER
NODE_COUNTER = NODE_COUNTER + 1
End Sub
Private Sub Class_Terminate
Set ChildNodes = Nothing
End Sub
Public Function GetXml(parentId)
Dim buf
Set buf = New Buffer
buf.Append "<item><menuid>" & Me.ID & "</menuid><text><![CDATA[" & Me.Text & "]]></text>"
buf.Append "<tooltip>" & Me.ToolTipText & "</tooltip><target>" & Me.Target & "</target>"
buf.Append "<url>" & Me.Href & "</url><imageurl>" & Me.ImageUrl & "</imageurl>"
buf.Append "<parentid>" & parentId & "</parentid>"
buf.Append("</item>")
buf.Append(ChildNodes.GetXml(Me.ID))
GetXml = buf.ToString
Set buf = Nothing
End Function
End Class
Class TreeView
Private m_folder
Public Color
Public Nodes
Public DefaultTarget
Public ID
Public MAX_RECORDS
Private m_strXml
Private m_strXsl
Public Property Let ImagesFolder(strFolder)
m_folder=strFolder
End Property
Public Property Get ImagesFolder()
ImagesFolder=m_folder
End Property
Private Sub Class_Initialize
Set Nodes = New Collection
Color="Navy"
m_folder="images"
MAX_RECORDS = 2000
m_strXsl = "treeview.xsl"
End Sub
Private Sub Class_Terminate
Set Nodes = Nothing
End Sub
Public Function AddNode(Text)
Dim tn
Set tn = new Node
tn.Text=Text
Nodes.Add(tn)
End Function
Public Function CreateNode(Text,Href,ToolTipText)
Dim tn
Set tn = new Node
Call tn.Init(Text,Href,ToolTipText)
Set CreateNode=tn
End Function
Public Function CreateSimpleNode(Text)
Dim tn
Set tn = new Node
tn.Text = Text
Set CreateSimpleNode=tn
End Function
Private Sub Out(s)
'Response.Write(s)
document.write s
'MsgBox Len(s), vbOKOnly, "Length of S"
show.value = s
'MsgBox s, vbOKOnly, "Value of S"
End Sub
Public Sub Display
If m_strXml = "" Then
m_strXml = "<items>" & Nodes.GetXml(0) & "</items>"
End If
dim starttime : starttime = timer()
Out(GetString())
' Out "<!--" & timer()- starttime& "-->"
'dim t:t=GetString
'Out timer()- starttime
'dim starttime : starttime = timer()
'Response.ContentType = "text/xml"
'Response.Write "<?xml version=""1.0"" encoding=""ISO-8859-1"" ?>"
'Response.Write GetString() 'm_strXml
'Response.Write "<!--" & timer()-starttime& "-->"
'Response.End
End Sub
Public Sub LoadFromDb(strConn,strMenuTable)
Const strXsl = "db2xml.xsl"
m_strXml = GetDbXml(strConn,strMenuTable, strXsl)
End Sub
Public Sub LoadFromXml(strXml)
m_strXml = strXml
End Sub
Function IIf(Expression,TruePart,FalsePart)
If Expression Then IIf = TruePart Else IIf = FalsePart
End Function
Private Sub Alert(message,isError)
'Response.Write "<div style='color:"& IIf(isError,"red","purple") &";font-family:batang;'>" & Replace(message,vbCrlf,"<br/>") & "</div>"
MsgBox message, vbOKOnly, "Message from Alert function"
End Sub
Private Function GetDbXml(strConn,strMenuTable, strXsl)
Dim strXml
strXml = GetDataString(strConn,strMenuTable,"__COL","__ROW","__NULL")
strXml = Replace(strXml,"&","&")
strXml = Replace(strXml,"<","<")
strXml = Replace(strXml,"__COL","</col><col>")
strXml = Replace(strXml,"__ROW","</col></row><row><col>")
strXml = Replace(strXml,"__NULL","")
strXml = "<rows><row><col>" & strXml & "</col></row></rows>"
strXml = Replace(strXml,"<row><col></col></row>","")
If strXsl <> "" Then
Dim xml,xsl
'Load XML
if not loadXmlDoc(xml,strXml,"GetDb XML Source") then exit Function
if not loadXmlDoc(xsl,strXsl,"GetDb XSL Stylesheet") then exit Function
'Transform file
strXml = xml.transformNode(xsl)
End If
GetDbXml = strXml
End Function
Private Function GetDataString(strConn,strMenuTable, ColumnDelimiter, RowDelimiter, NullExpr)
Dim Conn
'Set Conn = Server.CreateObject("ADODB.Connection")
Set Conn = CreateObject("ADODB.Connection")
Conn.Open strConn
Dim RS
Set RS = Conn.Execute("SELECT TOP "& MAX_RECORDS & " * FROM " & strMenuTable)
If Not RS.EOF Then
Dim fld,s
For Each fld In RS.Fields
s = s & fld.Name & ColumnDelimiter
next
s = s & RowDelimiter
Set fld = Nothing
'Store our one big string
GetDataString = s & RS.GetString(,, ColumnDelimiter, RowDelimiter, NullExpr)
'Cleanup!
RS.Close
End If
'Cleanup!
Set RS = Nothing
Conn.Close
Set Conn = Nothing
End function
Private Function LoadXmlDoc(ByRef xmldoc, ByVal source, ByVal title)
If Trim(source) = "" Then
Call Alert(UCASE(title) &" NOT FOUND",True)
Exit Function
End If
'set xmldoc = Server.CreateObject("Microsoft.XMLDOM")
set xmldoc = CreateObject("Microsoft.XMLDOM")
xmldoc.async = false
If InStr(source,"<") Then
xmldoc.loadXml(source)
else
'If InStr(source,":\") = 0 then source = Server.MapPath(source)
'test source
xmldoc.load(source)
end if
if xmldoc.parseError.errorcode<>0 then
Call Alert("<b>XML Error:</b><br>" & xmldoc.parseError.reason & "<br><code>"& source & "</code>",True)
else
LoadXmlDoc = True
end if
End Function
Private Function GetString()
Dim xml, xsl
if not loadXmlDoc(xml,m_strXml,"XML Source") then exit Function
if not loadXmlDoc(xsl,m_strXsl,"XSL Stylesheet") then exit Function
xml.documentElement.setAttribute "color",Color
xml.documentElement.setAttribute "imagesfolder",ImagesFolder
xml.documentElement.setAttribute "defaulttarget",DefaultTarget
xml.documentElement.setAttribute "id",ID
GetString = xml.transformNode(xsl)
End Function
Public Sub DisplayFolderContents(ByVal strFolderPath)
LoadFromFolder(strFolderPath)
Display
End Sub
Public Sub LoadFromFolder(ByVal strFolderPath)
Dim fso
'Set fso = Server.CreateObject("Scripting.FileSystemObject")
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(strFolderPath) Then
Dim strBaseUrl, objBuf
strBaseUrl = Request.ServerVariables("SCRIPT_NAME")
strBaseUrl = Left(strBaseUrl,InStrRev(strBaseUrl,"/") - 1)
Set objBuf = New Buffer
objBuf.Append "<items>"
Call LoadFolderContents(objBuf,fso.GetFolder(strFolderPath),0,0)
objBuf.Append "</items>"
m_strXml = objBuf.ToString
Else
Out "<font color=red>Folder <b>'" & strFolderPath & "'</b> does not exist</font>"
End If
Set fso = Nothing
End Sub
Private Sub LoadFolderContents(ByRef objBuf,ByRef objFolder,ByRef intCounter,ByVal intParentId)
Dim objSubFolder, objFile
For Each objSubFolder In objFolder.SubFolders
intCounter = intCounter + 1
objBuf.Append "<item>"
objBuf.Append("<menuid>" & intCounter & "</menuid>")
objBuf.Append("<text>" & objSubFolder.Name & "</text>")
objBuf.Append("<parentid>" & intParentId & "</parentid>")
objBuf.Append("</item>")
Call LoadFolderContents(objBuf,objSubFolder,intCounter,intCounter)
Next
For Each objFile In objFolder.Files
intCounter = intCounter + 1
objBuf.Append "<item>"
objBuf.Append("<menuid>" & intCounter & "</menuid>")
objBuf.Append("<text>" & objFile.Name & "</text>")
objBuf.Append("<parentid>" & intParentId & "</parentid>")
objBuf.Append("</item>")
Next
Set objFile = Nothing
Set objSubFolder = Nothing
End Sub
End Class
