ASP的自定义函数[7]

这是一个后台管理的文章发布系统里的一个将copy的文字转换成html代码的函数，如果是空格会自动加&nbsp;如果换行会自动加<br>也可以自己直接写HTML代码
<%
'自建Asp函数库

'HTML/*********************
'将部分字符串转化为Html代码
function htmlencode2(str)
dim result
dim l
if isNULL(str) then 
htmlencode2=""
exit function
end if
l=len(str)
result=""
dim i
for i = 1 to l
select case mid(str,i,1)
case "'"
result=result+"’"
'case ""
' result=result+">"
case chr(13)
result=result+"<br>"
'case chr(34)
' result=result+""
case "&"
result=result+"&"
case chr(32) 
'result=result+" "
if i+1<=l and i-1>0 then
if mid(str,i+1,1)=chr(32) or mid(str,i+1,1)=chr(9) or mid(str,i-1,1)=chr(32) or mid(str,i-1,1)=chr(9) then 
result=result+" "
else
result=result+" "
end if
else
result=result+" " 
end if
case chr(9)
result=result+" "
case else
result=result+mid(str,i,1)
end select
next 
htmlencode2=result
end function

'字符串验证**************

'Emailcheck
Function isEmail(val)
isEmail=False
if len(val)>0 then
if instr(val,"@")>0 and instr(val,".")>0 and len(val)>5 then
else
exit function
end if
else
exit function
end if
isEmail=true
end function

%>

--------------------------------------------------------------------------------

-- 
无级分类的函数，分表格显示与下拉列表显示两种
数据库Db_category: CategoryID | ParentID | CategoryName
调用：Sub CategoryType(CategoryID,num,Action,SelectedID,Style)
Category.asp:
<%
Sub CategoryType(CategoryID,num,Action,SelectedID,Style)
'style = 1 , 以表格显示
'style = 2 , 以下拉列表显示
if Style = 0 then
response.write "<table border='1' width='100%' cellspacing='0' cellpadding='2' bordercolorlight='#000000' bordercolordark='#FFFFFF' class='p9'>"
response.write "<tr align='center'>"
response.write "<td width='10%'> 分类ID </td>"
response.write "<td width='10%'> 上级ID </td>"
response.write "<td width='*'> 分类名称 </td>"
response.write "<td width='15%'> 操作 </td></tr>"
call CategoryList(CategoryID,num,Action)
response.write "</table>"
else
response.write "<select name='Category'>"
response.write "<option value='0'> ---产品根目录--- </option>"
call CategorySel(CategoryID,num,SelectedID)
response.write "</select>"
end if
end sub
Sub CategoryList(ParentID,num,Action)
sql="select CategoryID,ParentID,CategoryName from Db_Category where ParentID="&ParentID
set rs=server.createobject("adodb.recordset")
rs.open sql,conn,1,1
if not rs.eof then
Category = rs.getrows
end if
rs.close
set rs=nothing
snum = num + 1
str = Makeblank(snum,0)
if isArray(Category) then
for l=0 to ubound(Category,2)
response.Write("<tr>")
for k=0 to ubound(Category,1)
if k = ubound(Category,1) then '当显示CategoryName 时加[],其他不加
response.Write("<td>"&str&" [ "&Category(k,l)&"] "&"</td>")
else
response.Write("<td> "&Category(k,l)&" "&"</td>")
end if
next
if Action = 1 then '添加目录
response.Write("<td align='center'> <a href='CategoryAdd.asp?CategoryID="&Category(0,l)&"'>添加子类</a> </td></tr>")
elseif Action = 2 then '修改目录
response.Write("<td align='center'> <a href='CategoryEdit.asp?CategoryID="&Category(0,l)&"'>修改类别</a> </td></tr>")
elseif Action = 3 then '删除目录
response.Write("<td align='center'> <a href='CategoryDel.asp?CategoryID="&Category(0,l)&"'>删除类别</a> </td></tr>")
else '没有操作，仅浏览
response.Write("<td align='center'> --------- </td></tr>") 
end if
'调用递归函数，列出下级目录
call CategoryList(Category(0,l),snum,Action)
next
set Category = nothing
end if
End Sub
Sub CategorySel(CategoryID,num,SelectedID)
sql="select CategoryID,ParentID,CategoryName from Db_Category where ParentID="&CategoryID
set rs=server.createobject("adodb.recordset")
rs.open sql,conn,1,1
if not rs.eof then
Category = rs.getrows
end if
rs.close
set rs = nothing
snum = num + 1
str = Makeblank(snum,1)
if isArray(Category) then
for l=0 to ubound(Category,2)
if Category(0,l) = SelectedID then '当显示已选择的ID时加[Selected],表示已选择
response.Write("<option value='"&Category(0,l)&"' Selected>"&str&Category(2,l)&"</option>")
else
response.Write("<option value='"&Category(0,l)&"'>"&str&Category(2,l)&"</option>")
end if
'调用递归函数，列出下级目录
call CategorySel(Category(0,l),snum,SelectedID)
next
set Category = nothing
end if
End Sub
Function Makeblank(num,Style)
if Style = 0 then 
for i = 2 to num
TempStr = TempStr&" "
next
Makeblank = TempStr&"├" 
else
for i = 2 to num
TempStr = TempStr&" "
next
Makeblank = TempStr&"└ "
end if
'不同的表格线:└┌┍┕┎┖┐┘┑┙┒┚┓┛├ ┤┝ ┥┞ ┦┼ ╄ ┽ ╅┣ ┫
End function
%>
--------------------------------------------------------------------------------

-- qq在线显示程序核心代码
<%
Function GetURL(url) 
Set Retrieval = CreateObject("Microsoft.XMLHTTP") 
With Retrieval 
.Open "GET", url, False, "", "" 
.Send 
GetURL = .ResponseText 
End With 
Set Retrieval = Nothing 
End Function 

Function qqonline(qqid) 
Dim T,Start,Length,PicURL
'找到该用户界面的源代码
T=GetURL("http://search.tencent.com/cgi-bin/friend/oicq_find?oicq_no=";;&qqid)
'查找字符串ShowResult(的位置
Start=Instr(1,T,"ShowResult("+chr(34))
'查找字符串http://的位置
Start=Instr(Start,T,"http://";;) 
'查找包含字符串的长度
Length=Instr(Start,T,chr(34)+","+chr(34))-Start 
PicURL=Mid(T,Start,Length) 
pic_right=right(picurl,5)
pic_left=left(pic_right,1)
if pic_left="2" then
qqonline="在线"
else
qqonline="离线"
end if
End Function
%><%=qqonline(24080411)%>

--------------------------------------------------------------------------------

-- 
vbs类生成xml文件 
有两文件:
objXML.asp:测试文件
clsXML.asp:vbs类文件
代码:
objXML.asp

<%@ Language=VBScript %>
<% Option Explicit %>
<!--#INCLUDE FILE="clsXML.asp"-->
<%
Dim objXML, strPath, str
Set objXML = New clsXML

strPath = Server.MapPath(".") & "\New.xml"

objXML.createFile strPath, "Root"
'Or If using an existing XML file:
'objXML.File = "C:\File.xml"

objXML.createRootChild "Images"

'Here only one attribute is added to the Images/Image Node
objXML.createChildNodeWAttr "Images", "Image", "id", "1"
objXML.updateField "Images//Image[@id=1]", "super.gif"
objXML.createRootNodeWAttr "Jobs", Array("Size", "Length", "Width"), _
Array(24, 31, 30)
objXML.createRootNodeWAttr "Jobs", Array("Size", "Length", "Width"), _
Array(24, 30, 29)
objXML.createRootNodeWAttr "Jobs", Array("Size", "Length", "Width"), _
Array(24, 31, 85)

'Notice that all three job nodes have size 24, all of those 
'nodes will be updated
objXML.updateField "Jobs[@Size=24]", "24's"

'Notice that only two nodes have the specified XPath, hence 
'only two new child nodes will be added
objXML.createChildNodeWAttr "Jobs[@Size=24 and @Length=31]", "Specs", _
Array("Wood", "Metal", "Color"), _
Array("Cedar", "Aluminum", "Green")

'It is always important to iterate through all of the nodes
'returned by this XPath query.
For Each str In objXML.getField("Jobs[@Size=24]")
Response.Write(str & "<br>")
Next
Set objXML = Nothing

Response.Redirect "New.xml"
%>

clsXML.asp:

<%
Class clsXML
'strFile must be full path to document, ie C:\XML\XMLFile.XML
'objDoc is the XML Object
Private strFile, objDoc

'*********************************************************************
' Initialization/Termination
'*********************************************************************

'Initialize Class Members
Private Sub Class_Initialize()
strFile = ""
End Sub

'Terminate and unload all created objects
Private Sub Class_Terminate()
Set objDoc = Nothing
End Sub

'*********************************************************************
' Properties
'*********************************************************************

'Set XML File and objDoc
Public Property Let File(str)
Set objDoc = Server.CreateObject("Microsoft.XMLDOM")
objDoc.async = False
strFile = str
objDoc.Load strFile
End Property

'Get XML File
Public Property Get File()
File = strFile
End Property

'*********************************************************************
' Functions
'*********************************************************************

'Create Blank XML File, set current obj File to newly created file
Public Function createFile(strPath, strRoot)
Dim objFSO, objTextFile
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.CreateTextFile(strPath, True)
objTextFile.WriteLine("<?xml version=""1.0""?>")
objTextFile.WriteLine("<" & strRoot & "/>")
objTextFile.Close
Me.File = strPath
Set objTextFile = Nothing
Set objFSO = Nothing
End Function

'Get XML Field(s) based on XPath input from root node
Public Function getField(strXPath)
Dim objNodeList, arrResponse(), i
Set objNodeList = objDoc.documentElement.selectNodes(strXPath)
ReDim arrResponse(objNodeList.length)
For i = 0 To objNodeList.length - 1
arrResponse(i) = objNodeList.item(i).Text
Next
getField = arrResponse
End Function

'Update existing node(s) based on XPath specs
Public Function updateField(strXPath, strData)
Dim objField
For Each objField In objDoc.documentElement.selectNodes(strXPath)
objField.Text = strData
Next
objDoc.Save strFile
Set objField = Nothing
updateField = True
End Function

'Create node directly under root
Public Function createRootChild(strNode)
Dim objChild
Set objChild = objDoc.createNode(1, strNode, "")
objDoc.documentElement.appendChild(objChild)
objDoc.Save strFile
Set objChild = Nothing
End Function

'Create a child node under root node with attributes
Public Function createRootNodeWAttr(strNode, attr, val)
Dim objChild, objAttr
Set objChild = objDoc.createNode(1, strNode, "")
If IsArray(attr) And IsArray(val) Then
If UBound(attr)-LBound(attr) <> UBound(val)-LBound(val) Then
Exit Function
Else
Dim i
For i = LBound(attr) To UBound(attr)
Set objAttr = objDoc.createAttribute(attr(i))
objChild.setAttribute attr(i), val(i)
Next
End If
Else
Set objAttr = objDoc.createAttribute(attr)
objChild.setAttribute attr, val
End If
objDoc.documentElement.appendChild(objChild)
objDoc.Save strFile
Set objChild = Nothing
End Function

'Create a child node under the specified XPath Node
Public Function createChildNode(strXPath, strNode)
Dim objParent, objChild
For Each objParent In objDoc.documentElement.selectNodes(strXPath)
Set objChild = objDoc.createNode(1, strNode, "")
objParent.appendChild(objChild)
Next
objDoc.Save strFile
Set objParent = Nothing
Set objChild = Nothing
End Function

'Create a child node(s) under the specified XPath Node with attributes
Public Function createChildNodeWAttr(strXPath, strNode, attr, val)
Dim objParent, objChild, objAttr
For Each objParent In objDoc.documentElement.selectNodes(strXPath)
Set objChild = objDoc.createNode(1, strNode, "")
If IsArray(attr) And IsArray(val) Then
If UBound(attr)-LBound(attr) <> UBound(val)-LBound(val) Then
Exit Function
Else
Dim i
For i = LBound(attr) To UBound(attr)
Set objAttr = objDoc.createAttribute(attr(i))
objChild.SetAttribute attr(i), val(i)
Next
End If
Else
Set objAttr = objDoc.createAttribute(attr)
objChild.setAttribute attr, val
End If
objParent.appendChild(objChild)
Next
objDoc.Save strFile
Set objParent = Nothing
Set objChild = Nothing
End Function

'Delete the node specified by the XPath
Public Function deleteNode(strXPath)
Dim objOld
For Each objOld In objDoc.documentElement.selectNodes(strXPath)
objDoc.documentElement.removeChild objOld
Next
objDoc.Save strFile
Set objOld = Nothing
End Function
End Class
%>

--------------------------------------------------------------------------------