针对有网友说看不见文章内容，
现提示如下:
点击每一个标题行任一地方都会展开和隐藏此文章内容(不要点击标题).
目前展开隐藏功能只支持IE浏览器，虽然可以改成支持FF浏览器，不过现在一直没时间去弄，等有时间再修改了。 |
|
blog名称:乱闪Blog
日志总数:267
评论数量:1618
留言数量:-26
访问次数:2654441
建立时间:2005年1月1日 |
|
|
| |
 ASP 模板技术之参数传递
|
在内容系统开发中，涉及内容和形式分离的过程，也就是根据用户自定义页面模板然后替换成相关内容的过程。这和外面很多整站的内容管理系统，有本质上的区别。有不少内容管理系统，多少人用，都是一个样子，因为页面无法自定义，不懂编程的用户无法修改。象那种，只填几个参数就出来的网站，我估计是没有什么前途的。因为人人都是一个样子，人人都是会填那些参数的。
举个例子，你查看一下以下几个站点，你会认为他们是一套程序吗？
www.blueidea.com
http://pages.blueidea.com
http://digi.blueidea.com
http://wuyi.digichina.net
http://www.dcshooter.com
如果我告诉你，他们都是一个程序，只是由相关的站长，设计不同的模板得到的页面显示，你就会发现，这个系统的优良性。
当然由于这套系统的高端性，目前普通用户无法使用，于是我开发了我自己的内容管理系统 kiss 内容管理系统。大家可以访问 http://aston.blueidea.com
而要给用户一个模板系统，首先，就是要有一个简单易懂的标记系统。大家看看下面的代码，看是否容易理解：
<tag:loop channelid="1" pagesize="10" title="20" type="NEW" column="1">
略有HTML经验的人，就知道，这是一个模板标记里的循环标记，因为这是最常用的，你看我们网站的首页，列出10条文档也就只需要写一个这样的标记就完成了，这是不是让不明白编程的人，也很容易做出自己设计的页面出来呢？
参数说明：
channelid 为一个栏目的在数据库中的ID
pagesize 为列举多少个文档
title 为标题的长度
type 为列表列型，这里的”NEW”我们设定为最新的文档
column 为显示几列
以上介绍是给不会编程，或者对不了解内容系统的人做个普及，并且给我的内容管理系统打个广告，而且我想说的是，蓝色理想站点用的内容管理系统模板模块，要比我的强大很多。
下面轮到程序员了，其它人可以不用往下看。
那么怎么把它们的值读出来呢？
下面这个函数是最后的，用来解析所有模板的内容
代码拷贝框
'【功能】自定义模板标签
Function ProcessCustomTags(ByVal sContent)
Dim objRegEx, Match, Matches
'建立正则表达式
Set objRegEx = New RegExp
'查找内容
objRegEx.Pattern = "<tag:.*/>"
'忽略大小写
objRegEx.IgnoreCase = True
'全局查找
objRegEx.Global = True
'Run the search against the content string we've been passed
Set Matches = objRegEx.Execute(sContent)
'循环已发现的匹配
For Each Match in Matches
'Replace each match with the appropriate HTML from our ParseTag function
sContent = Replace(sContent, Match.Value, ParseTag(Match.Value))
Next
'消毁对象
set Matches = nothing
set objRegEx = nothing
'返回值
ProcessCustomTags = sContent
End Function
[Ctrl+A 全部选择 然后拷贝]
在上面的代码中，用到了正则表达式，如果你对它还不是很了解，请参阅相关资料，这里就不详细介绍了。
那么怎么取出参数值呢，也是一个函数:
代码拷贝框
'【功能】取得模板标签的参数名
'如：<tag:loop channelid="1" pagesize="10" title="20" type="NEW" column="1">
function GetAttribute(ByVal strAttribute, ByVal strTag)
Dim objRegEx, Matches
'建立正则表达式
Set objRegEx = New RegExp
'查找内容 (the attribute name followed by double quotes etc)
objRegEx.Pattern = lCase(strAttribute) & "=""[0-9a-zA-Z]*"""
'忽略大小写
objRegEx.IgnoreCase = True
'全局查找
objRegEx.Global = True
'执行搜索
Set Matches = objRegEx.Execute(strTag)
'如有匹配的则返回值, 不然返回空值
if Matches.Count > 0 then
GetAttribute = Split(Matches(0).Value,"""")(1)
else
GetAttribute = ""
end if
'消毁对象
set Matches = nothing
set objRegEx = nothing
end function
[Ctrl+A 全部选择 然后拷贝]
OK好了，那怎么解析像上面<tagloop:>内容呢？
下面就是一个函数：
代码拷贝框
'【功能】解析并替换相应的模板标签内容
function ParseTag(ByVal strTag)
dim arrResult, ClassName, arrAttributes, sTemp, i, objClass
'如果标签是空的则退出函数
if len(strTag) = 0 then exit function
'Split the match on the colon character (:)
arrResult = Split(strTag, ":")
'Split the second item of the resulting array on the space character, to
'retrieve the name of the class
ClassName = Split(arrResult(1), " ")(0)
'Use a select case statement to work out which class we're dealing with
'and therefore which properties to populate etc
select case uCase(ClassName)
'It's a loop class, so instantiate one and get it's properties
case "LOOP"
set objClass = new LOOP_Class
LOOP.Channelid= GetAttribute("channelid", strTag")
LOOP.Pagesize= GetAttribute("pagesize", strTag")
LOOP.title = GetAttribute("title", strTag")
LOOP.type = GetAttribute("Type", strTag")
ParseTag = LOOP.column (GetAttribute("column", strTag"), true)
'Destroy our class object
set objClass = nothing
end select
end function
[Ctrl+A 全部选择 然后拷贝]
上面的loop是一个类，这里也不再详说了。因为好久没有说话了，不太习惯，呵呵。
结论，通过上面的函数，你可以很快的编写相关的模板程序了。希望对你有帮助。 |
|
超长字符的智能分页-支持HTML
|
对HTML做了相应的处理，不会由HTML代码中切开。
这里另一位兄弟曾发表过一个，原理一样，不过我没仔细看过，不知有啥不同。
代码如下：
--------------------------------------
'Request Form Item
I_Forder = Request.Form ("I_Folder")
I_Topic = Request.Form ("I_Topic")
I_Title = htmlencode(Request.Form ("I_Title"))
I_Body = Request.Form ("body")
I_Source = Request.Form ("I_Source")
I_Keyword= htmlencode(Request.Form ("I_Keyword"))
I_ISHOT = request.form("ishot")
if i_ishot = "" then i_ishot="N"
i_ispic = request.form("ispic")
if i_ispic = "" then i_ispic ="N"
i_pic = request.form("InsertImage")
i_body = replace(i_body,"contentEditable=true","contentEditable=false")
'Check Input
'......
'Get Pages ,B = Body
B_Len = Len(I_Body)
B_Pages = 1
'T = Temp
T_Loop = true
Do While T_Loop '这里loop多次，每4000分一页，算出页码并加入库。
If B_Len > 4000 then
N_Body = Left(I_Body,4000) 'N = New
'If "<P" in N_Body,Else ">" in N_Body
If Instrrev(N_Body,"<P") > 0 and (Len(N_Body) - Instrrev(N_Body,"<P"))< 400 then
N_Body = Left(N_Body,InstrRev(N_Body,"<P")-1)
else if Instrrev(N_Body," ") > 0 and (Len(N_Body) - Instrrev(N_Body," "))< 400 then
N_Body = Left(N_Body,InstrRev(N_Body," ")-1)
Else If Instrrev(N_Body,"。") > 0 and (Len(N_Body) - Instrrev(N_Body,"。"))< 400 then
N_Body = Left(N_Body,InstrRev(N_Body,"。"))
Else If Instrrev(N_Body,"；") > 0 and (Len(N_Body) - Instrrev(N_Body,"；"))< 400 then
N_Body = Left(N_Body,InstrRev(N_Body,"；"))
else if Instrrev(N_Body,"，") > 0 and (Len(N_Body) - Instrrev(N_Body,"，"))< 400 then
N_Body = Left(N_Body,InstrRev(N_Body,"，"))
else if Instrrev(N_Body,".") > 0 and (Len(N_Body) - Instrrev(N_Body,"."))< 400 then
N_Body = Left(N_Body,InstrRev(N_Body,"."))
end if
end if
End If
End If
end if
End if
N_Len = Len(N_Body)
I_Body = Mid(I_Body,N_Len+1)
B_Len = Len(I_Body)
Else
N_Body = I_Body
T_Loop = false
End If
'Add to database
Exec_prc_Content_Ins I_Forder,I_Topic,I_Title,I_Source,N_Body,i_ispic,i_pic,i_ishot,I_Keyword,B_Pages
'这里一个function，你可以自己处理，反正结果有两个，一个是body，一个是b_pages，就是页码。
B_Pages = B_Pages + 1
Loop
%>
<html>
<head>
<meta name="GENERATOR" content="Microsoft FrontPage 5.0">
<meta name="ProgId" content="FrontPage.Editor.Document">
<meta http-equiv="Content-Type" content="text/html; charset=gb2312">
<title>新建网页 1</title>
<link rel="stylesheet" type="text/css" href="../CSS/default.css">
</head>
<body>
<div align="center">
<center>
<table border=1 width="300" height="128" bordercolor="#000000" cellspacing="0" cellpadding="0" style="border-collapse: collapse"><tr>
<td bgcolor="#DEDBD6" height="31">
录入成功</td></tr><tr><td height="96">
<p align="center">此文章共分<%=B_Pages-1%>页
</td></tr></table>
</center>
</div>
<script>
top.main_top.location.reload();
</script>
</body> |
|
将HTML表单数据存储为XML格式
|
通常的，ASP中表单提交的数据一般被写入数据库。然而，如果你想让发送数据更为简便易行，那么，可以将它书写为XML文件格式。这种方式对于在web上收集的数据更为有用。因为XML对于所用平台来说非常的简便，所以用不着转换数据格式。
将提交的数据写为XML文档，则需要通过Microsoft XMLDOM Object创建一个新的XML文档。Microsoft XMLDOM Object拥有一个可扩展对象库，通过它可以创建elements，attributes以及values，通过创建的这些项目则可以组成XML文档。我无法将整个目标模型做个完整的介绍，因为它所包含的内容太广泛，对于将建成的网站来说，目标模型甚至通过自身也能组建一个相对完整的部份。
在XMLDOM Object被创建出来之后，通过创建目标（此目标是关于组成XML文档中每一层的ELEMENTS而言）XML的结构会被演示出来。接下来，会举例说明XMLDOM是怎样被创建出来的。创建root element之后，将它附加在XMLDOM文件上。然后创建child elements并附加在root element上，最后存储文档。
演示Microsoft XMLDOM 对象
<%
Dim objDom
Dim objRoot
Dim objChild1
Dim objChild2
Dim objPI
" XMLDOM 对象使用Server对象的CreateObject方法创建
Set objDom = Server.CreateObject("Microsoft.XMLDOM")
"使用XMLDOM的createElemnet方法创建一个IXMLDOMElement对象。
"createElemnet方法又一个string参数，这个string 表示该element的名称。
返回值被传递到objRoot变量。objRoot表示XML文档的根元素.。
Set objRoot = objDom.createElement("rootElement")
"Use the appendChild Method of the XMLDOM Object to add the objRoot
"Element Reference to the XML Document.
objDom.appendChild objRoot
"Now, following the same steps, you will create references to the
"child elements for the XML Document. The only difference is, when the
"child elements are appended to the document, you will call the
"appendChild Method of the IXMLDOMElement Object rather than the
"appendChild Method of the XMLDOM Object. By using the IXMLDOMElement
"to append the chi en, you are differentiating (and applying tiered
"structure to) the child elements from the root element.
Set objChild1 = objDom.createElement("childElement1")
objRoot.appendChild objChild1
Set objChild1 = objDom.createElement("childElement2")
objRoot.appendChild objChild2
"The final step to take care of before saving this document is to add
"an XML processing instruction. This is necessary so that XML parsers
"will recognize this document as an XML document.
Set objPI = objDom.createProcessingInstruction("xml","vertsion="1.0"")
"Call the insertBefore Method of the XMLDOM Object in order to insert
"the processing instruction before the root element (the zero element
"in the XMLDOM childNodes Collection).
objDom.insertBefore objPI, objDom.childNodes(0)
"Calling the Save Method of the XMLDOM Object will save this XML
"document to your disk drive. In this case, the document will be saved
"to the "c:" drive and will be named "MyXMLDoc.xml". When saving an
"XML document, if the file does not exist, it will be created. If it
"does exist, it will be overwritten.
objDom.Save "c:\MyXMLDoc.xml"
%>
文档被存档之后，如果你再打开这个文档，那么则会以如下代码列表形式出现：
MyXMLDoc.xml:
<?xml version="1.0"?>
<rootElement>
<childElement1 />
<childElement2 />
</rootElement>
在"MyXMLDoc.xml"文档中，childElement1 和 childElement2 会以空的elements形式出现。如果它们被赋值，那么每个值都将由标记符括起来。
现在，让我们来思考一下如何将HTML数据写到XML文档中去。我们已经知道该如何创建和存储XML文档。将一个表单数据写到XML文档中去的过程，现在已演变成为Request Object"s Form Collection以及将每一个表单域的value书定到XML element value 中去的步骤重复。以上可以通过ASP来完成。
例：将数据输送到XML
现在，我们举一个普通的HTML表单的例子来说明。此Form有用户名，地址，电话，以及E-MAIL等几个域。并将这些信息写入XML文件中并保存。
EnterContact.html:
<html>
<head>
<title>
Contact Information
</title>
</head>
<body>
<form action="processForm.asp" method="post">
<h3>请输入你的联系方式</h3>
First Name: <input type="text" id="firstName" name="firstName"><br>
Last Name: <input type="text" id="lastName" name="lastName"><br>
Address #1: <input type="text" id="address1" name="address1"><br>
Address #2: <input type="text" id="address2" name="address2"><br>
Phone Number: <input type="text" id="phone" name="phone"><br>
E-Mail: <input type="text" id="email" name="email"><br>
<input type="submit" id="btnSub" name="btnSub" value="Submit"><br>
</form>
</body>
</html>
将Form 中数据发送到processForm.asp.。这是一个ASP页面，在这个ASP中将反复调用同一个函数将form数据写入XML文件。
processForm.asp:
<%
"--------------------------------------------------------------------
"The "ConvertFormtoXML" Function accepts to parameters.
"strXMLFilePath - The physical path where the XML file will be saved.
"strFileName - The name of the XML file that will be saved.
"--------------------------------------------------------------------
Function ConvertFormtoXML(strXMLFilePath, strFileName)
"Declare local variables.
Dim objDom
Dim objRoot
Dim objField
Dim objFieldValue
Dim objattID
Dim objattTabOrder
Dim objPI
Dim x
"Instantiate the Microsoft XMLDOM.
Set objDom = server.CreateObject("Microsoft.XMLDOM")
objDom.preserveWhiteSpace = True
"Create your root element and append it to the XML document.
Set objRoot = objDom.createElement("contact")
objDom.appendChild objRoot
"Iterate through the Form Collection of the Request Object.
For x = 1 To Request.Form.Count
"Check to see if "btn" is in the name of the form element.
"If it is, then it is a button and we do not want to add it
"to the XML document.
If instr(1,Request.Form.Key(x),"btn") = 0 Then
"Create an element, "field".
Set objField = objDom.createElement("field")
"Create an attribute, "id".
Set objattID = objDom.createAttribute("id")
"Set the value of the id attribute equal the the name of
"the current form field.
objattID.Text = Request.Form.Key(x)
"The setAttributeNode method will append the id attribute
"to the field element.
objField.setAttributeNode objattID
"Create another attribute, "taborder". This just orders the
"elements.
Set objattTabOrder = objDom.createAttribute("taborder")
"Set the value of the taborder attribute.
objattTabOrder.Text = x
"Append the taborder attribute to the field element.
objField.setAttributeNode objattTabOrder
"Create a new element, "field_value".
Set objFieldValue = objDom.createElement("field_value")
"Set the value of the field_value element equal to
"the value of the current field in the Form Collection.
objFieldValue.Text = Request.Form(x)
"Append the field element as a child of the root element.
objRoot.appendChild objField
"Append the field_value element as a child of the field elemnt.
objField.appendChild objFieldValue
End If
Next
"Create the xml processing instruction.
Set objPI = objDom.createProcessingInstruction("xml", "version="1.0"")
"Append the processing instruction to the XML document.
objDom.insertBefore objPI, objDom.childNodes(0)
"Save the XML document.
objDom.save strXMLFilePath & "\" & strFileName
"Release all of your object references.
Set objDom = Nothing
Set objRoot = Nothing
Set objField = Nothing
Set objFieldValue = Nothing
Set objattID = Nothing
Set objattTabOrder = Nothing
Set objPI = Nothing
End Function
"Do not break on an error.
On Error Resume Next
"Call the ConvertFormtoXML function, passing in the physical path to
"save the file to and the name that you wish to use for the file.
ConvertFormtoXML "c:","Contact.xml"
"Test to see if an error occurred, if so, let the user know.
"Otherwise, tell the user that the operation was successful.
If err.number <> 0 then
Response.write("Errors occurred while saving your form submission.")
Else
Response.write("Your form submission has been saved.")
End If
%>
如果你是在你自己的应用程序中使用以上代码，请谨记一件事情，在"ConvertFormtoXML"函数已经运行的情况下，如果XML文件名已经存在，那么，文件将会被覆盖。在此，我建议在使用"ConvertFormtoXML"功能前，最好用随机建立的文件名。这样，就将有价值数据被改写的风险降为零。
关于XML文件的产生，举例如下：
Contact.xml
<?xml version="1.0" ?>
<contact>
<field id="firstName" taborder="1">
<field_value>Michael</field_value>
</field>
<field id="lastName" taborder="2">
<field_value>Qualls</field_value>
</field>
<field id="address1" taborder="3">
<field_value>2129 NW 27th St.</field_value>
</field>
<field id="address2" taborder="4">
<field_value />
</field>
<field id="phone" taborder="5">
<field_value>4055253988</field_value>
</field>
<field id="email" taborder="6">
<field_value>michaelq@vertiscope.com</field_value>
</field>
</contact>
我在此建议：将以上代码复制到你个人网站服务器上的同名页面上，并运行以上示例时。请一定要明确你使用的是对你个人服务器有效的路径和文件名。
当你一切准备好时，请再次检验你的XML文件。 |
|
XML操作类
|
<%
Class XMLDOMDocument
Private fNode,fANode
Private fErrInfo,fFileName,fOpen
Dim XmlDom
’返回节点的缩进字串
Private Property Get TabStr(byVal Node)
TabStr=""
If Node Is Nothing Then Exit Property
If not Node.parentNode Is nothing Then TabStr=" "&TabStr(Node.parentNode)
End Property
’返回一个子节点对象,ElementOBJ为父节点,ChildNodeObj要查找的节点,IsAttributeNode指出是否为属性对象
Public Property Get ChildNode(byVal ElementOBJ,byVal ChildNodeObj,byVal IsAttributeNode)
Dim Element
Set ChildNode=Nothing
If IsNull(ChildNodeObj) Then
If IsAttributeNode=false Then
Set ChildNode=fNode
Else
Set ChildNode=fANode
End If
Exit Property
ElseIf IsObject(ChildNodeObj) Then
Set ChildNode=ChildNodeObj
Exit Property
End If
Set Element=Nothing
If LCase(TypeName(ChildNodeObj))="string" and Trim(ChildNodeObj)<>"" Then
If IsNull(ElementOBJ) Then
Set Element=fNode
ElseIf LCase(TypeName(ElementOBJ))="string" Then
If Trim(ElementOBJ)<>"" Then
Set Element=XmlDom.selectSingleNode("//"&Trim(ElementOBJ))
If Lcase(Element.nodeTypeString)="attribute" Then Set Element=Element.selectSingleNode("..")
End If
ElseIf IsObject(ElementOBJ) Then
Set Element=ElementOBJ
End If
If Element Is Nothing Then
Set ChildNode=XmlDom.selectSingleNode("//"&Trim(ChildNodeObj))
ElseIf IsAttributeNode=true Then
Set ChildNode=Element.selectSingleNode("./@"&Trim(ChildNodeObj))
Else
Set ChildNode=Element.selectSingleNode("./"&Trim(ChildNodeObj))
End If
End If
End Property
’读取最后的错误信息
Public Property Get ErrInfo
ErrInfo=fErrInfo
End Property
’给xml内容
Public Property Get xmlText(byVal ElementOBJ)
xmlText=""
If fopen=false Then Exit Property
Set ElementOBJ=ChildNode(XmlDom,ElementOBJ,false)
If ElementOBJ Is Nothing Then Set ElementOBJ=XmlDom
xmlText=ElementOBJ.xml
End Property
’=================================================================
’类初始化
Private Sub Class_Initialize()
Set XmlDom=CreateObject("Microsoft.XMLDOM")
XmlDom.preserveWhiteSpace=true
Set fNode=Nothing
Set fANode=Nothing
fErrInfo=""
fFileName=""
fopen=false
End Sub
’类释放
Private Sub Class_Terminate()
Set fNode=Nothing
Set fANode=Nothing
Set XmlDom=nothing
fopen=false
End Sub
’=====================================================================
’建立一个XML文件，RootElementName：根结点名。XSLURL：使用XSL样式地址
’返回根结点
Function Create(byVal RootElementName,byVal XslUrl)
Dim PINode,RootElement
Set Create=Nothing
If (XmlDom Is Nothing) Or (fopen=true) Then Exit Function
If Trim(RootElementName)="" Then RootElementName="Root"
Set PINode=XmlDom.CreateProcessingInstruction("xml", "version=""1.0"" encoding=""GB2312""")
XmlDom.appendChild PINode
Set PINode=XMLDOM.CreateProcessingInstruction("xml-stylesheet", "type=""text/xsl"" href="""&XslUrl&"""")
XmlDom.appendChild PINode
Set RootElement=XmlDom.createElement(Trim(RootElementName))
XmlDom.appendChild RootElement
Set Create=RootElement
fopen=True
set fNode=RootElement
End Function
’开打一个已经存在的XML文件,返回打开状态
Function Open(byVal xmlSourceFile)
Open=false
xmlSourceFile=Trim(xmlSourceFile)
If xmlSourceFile="" Then Exit Function
XmlDom.async = false
XmlDom.load xmlSourceFile
fFileName=xmlSourceFile
If not IsError Then
Open=true
fopen=true
End If
End Function
’关闭
Sub Close()
Set fNode=Nothing
Set fANode=Nothing
fErrInfo=""
fFileName=""
fopen=false
End Sub
’读取一个NodeOBJ的节点Text的值
’NodeOBJ可以是节点对象或节点名，为null就取当前默认fNode
Function getNodeText(byVal NodeOBJ)
getNodeText=""
If fopen=false Then Exit Function
Set NodeOBJ=ChildNode(null,NodeOBJ,false)
If NodeOBJ Is Nothing Then Exit Function
If Lcase(NodeOBJ.nodeTypeString)="element" Then
set fNode=NodeOBJ
Else
set fANode=NodeOBJ
End If
getNodeText=NodeOBJ.text
End function
’插入在BefelementOBJ下面一个名为ElementName，Value为ElementText的子节点。
’IsFirst：是否插在第一个位置；IsCDATA：说明节点的值是否属于CDATA类型
’插入成功就返回新插入这个节点
’BefelementOBJ可以是对象也可以是节点名，为null就取当前默认对象
Function InsertElement(byVal BefelementOBJ,byVal ElementName,byVal ElementText,byVal IsFirst,byVal IsCDATA)
Dim Element,TextSection,SpaceStr
Set InsertElement=Nothing
If not fopen Then Exit Function
Set BefelementOBJ=ChildNode(XmlDom,BefelementOBJ,false)
If BefelementOBJ Is Nothing Then Exit Function
Set Element=XmlDom.CreateElement(Trim(ElementName))
’SpaceStr=vbCrLf&TabStr(BefelementOBJ)
’Set STabStr=XmlDom.CreateTextNode(SpaceStr)
’If Len(SpaceStr)>2 Then SpaceStr=Left(SpaceStr,Len(SpaceStr)-2)
’Set ETabStr=XmlDom.CreateTextNode(SpaceStr)
If IsFirst=true Then
’BefelementOBJ.InsertBefore ETabStr,BefelementOBJ.firstchild
BefelementOBJ.InsertBefore Element,BefelementOBJ.firstchild
’BefelementOBJ.InsertBefore STabStr,BefelementOBJ.firstchild
Else
’BefelementOBJ.appendChild STabStr
BefelementOBJ.appendChild Element
’BefelementOBJ.appendChild ETabStr
End If
If IsCDATA=true Then
set TextSection=XmlDom.createCDATASection(ElementText)
Element.appendChild TextSection
ElseIf ElementText<>"" Then
Element.Text=ElementText
End If
Set InsertElement=Element
Set fNode=Element
End Function
’在ElementOBJ节点上插入或修改名为AttributeName，值为：AttributeText的属性
’如果已经存在名为AttributeName的属性对象，就进行修改。
’返回插入或修改属性的Node
’ElementOBJ可以是Element对象或名，为null就取当前默认对象
Function setAttributeNode(byVal ElementOBJ,byVal AttributeName,byVal AttributeText)
Dim AttributeNode
Set setAttributeNode=nothing
If not fopen Then Exit Function
Set ElementOBJ=ChildNode(XmlDom,ElementOBJ,false)
If ElementOBJ Is Nothing Then Exit Function
Set AttributeNode=ElementOBJ.attributes.getNamedItem(AttributeName)
If AttributeNode Is nothing Then
Set AttributeNode=XmlDom.CreateAttribute(AttributeName)
ElementOBJ.setAttributeNode AttributeNode
End If
AttributeNode.text=AttributeText
set fNode=ElementOBJ
set fANode=AttributeNode
Set setAttributeNode=AttributeNode
End Function
’修改ElementOBJ节点的Text值，并返回这个节点
’ElementOBJ可以对象或对象名，为null就取当前默认对象
Function UpdateNodeText(byVal ElementOBJ,byVal NewElementText,byVal IsCDATA)
Dim TextSection
set UpdateNodeText=nothing
If not fopen Then Exit Function
Set ElementOBJ=ChildNode(XmlDom,ElementOBJ,false)
If ElementOBJ Is Nothing Then Exit Function
If IsCDATA=true Then
set TextSection=XmlDom.createCDATASection(NewElementText)
If ElementOBJ.firstchild Is Nothing Then
ElementOBJ.appendChild TextSection
ElseIf LCase(ElementOBJ.firstchild.nodeTypeString)="cdatasection" Then
ElementOBJ.replaceChild TextSection,ElementOBJ.firstchild
End If
Else
ElementOBJ.Text=NewElementText
End If
set fNode=ElementOBJ
Set UpdateNodeText=ElementOBJ
End Function
’返回符合testValue条件的第一个ElementNode，为null就取当前默认对象
Function getElementNode(byVal ElementName,byVal testValue)
Dim Element,regEx,baseName
Set getElementNode=nothing
If not fopen Then Exit Function
testValue=Trim(testValue)
Set regEx=New RegExp
regEx.Pattern="^[A-Za-z]+"
regEx.IgnoreCase=true
If regEx.Test(testValue) Then testValue="/"&testValue
Set regEx=nothing
baseName=LCase(Right(ElementName,Len(ElementName)-InStrRev(ElementName,"/",-1)))
Set Element=XmlDom.SelectSingleNode("//"&ElementName&testValue)
If Element Is Nothing Then
’Response.write ElementName&testValue
Set getElementNode=nothing
Exit Function
End If
Do While LCase(Element.baseName)<>baseName
Set Element=Element.selectSingleNode("..")
If Element Is Nothing Then Exit Do
Loop
If LCase(Element.baseName)<>baseName Then
Set getElementNode=nothing
Else
Set getElementNode=Element
If Lcase(Element.nodeTypeString)="element" Then
Set fNode=Element
Else
Set fANode=Element
End If
End If
End Function
’删除一个子节点
Function removeChild(byVal ElementOBJ)
removeChild=false
If not fopen Then Exit Function
Set ElementOBJ=ChildNode(null,ElementOBJ,false)
If ElementOBJ Is Nothing Then Exit Function
’response.write ElementOBJ.baseName
If Lcase(ElementOBJ.nodeTypeString)="element" Then
If ElementOBJ Is fNode Then set fNode=Nothing
If ElementOBJ.parentNode Is Nothing Then
XmlDom.removeChild(ElementOBJ)
Else
ElementOBJ.parentNode.removeChild(ElementOBJ)
End If
removeChild=True
End If
End Function
’清空一个节点所有子节点
Function ClearNode(byVal ElementOBJ)
set ClearNode=Nothing
If not fopen Then Exit Function
Set ElementOBJ=ChildNode(null,ElementOBJ,false)
If ElementOBJ Is Nothing Then Exit Function
ElementOBJ.text=""
ElementOBJ.removeChild(ElementOBJ.firstchild)
Set ClearNode=ElementOBJ
Set fNode=ElementOBJ
End Function
’删除子节点的一个属性
Function removeAttributeNode(byVal ElementOBJ,byVal AttributeOBJ)
removeAttributeNode=false
If not fopen Then Exit Function
Set ElementOBJ=ChildNode(XmlDom,ElementOBJ,false)
If ElementOBJ Is Nothing Then Exit Function
Set AttributeOBJ=ChildNode(ElementOBJ,AttributeOBJ,true)
If not AttributeOBJ Is nothing Then
ElementOBJ.removeAttributeNode(AttributeOBJ)
removeAttributeNode=True
End If
End Function
’保存打开过的文件，只要保证FileName不为空就可以实现保存
Function Save()
On Error Resume Next
Save=false
If (not fopen) or (fFileName="") Then Exit Function
XmlDom.Save fFileName
Save=(not IsError)
If Err.number<>0 then
Err.clear
Save=false
End If
End Function
’另存为XML文件，只要保证FileName不为空就可以实现保存
Function SaveAs(SaveFileName)
On Error Resume Next
SaveAs=false
If (not fopen) or SaveFileName="" Then Exit Function
XmlDom.Save SaveFileName
SaveAs=(not IsError)
If Err.number<>0 then
Err.clear
SaveAs=false
End If
End Function
’检查并打印错误信息
Private Function IsError()
If XmlDom.ParseError.errorcode<>0 Then
fErrInfo="<h1>Error"&XmlDom.ParseError.errorcode&"</h1>"
fErrInfo=fErrInfo&"<B>Reason :</B>"&XmlDom.ParseError.reason&"<br>"
fErrInfo=fErrInfo&"<B>URL :</B>"&XmlDom.ParseError.url&"<br>"
fErrInfo=fErrInfo&"<B>Line :</B>"&XmlDom.ParseError.line&"<br>"
fErrInfo=fErrInfo&"<B>FilePos:</B>"&XmlDom.ParseError.filepos&"<br>"
fErrInfo=fErrInfo&"<B>srcText:</B>"&XmlDom.ParseError.srcText&"<br>"
IsError=True
Else
IsError=False
End If
End Function
End Class
%> |
|
用ASP+XML实现CSDN的菜单(数据库),可分权限管理
|
只有一个程序文件和一个数据库.文件很少,也很容易查错.但是功能完全实现了!
数据库结构:
Table:Menu
ID
parentid,int,4
MenuName,Char,20
Link,Char,50
Table:UserLevel
ID
UserID,int,4
MenuID,int,4
-------------------------------------程序源文件:MenuList.Asp------------------------------
<%
'-------------------------------'
'源创商务策划有限公司-OA系统
'模块名称：可权限控制的菜单
'-------------------------------'
set conn = Server.CreateObject("ADODB.Connection")
conn.Open("Provider=Microsoft.Jet.OLEDB.4.0;Data Source="+Server.mappath("tree.mdb")+";Persist Security Info=False")
%>
<HTML>
<HEAD>
<TITLE> DSTree </TITLE>
<style>
body,td{font:12px verdana}
#treeBox{background-color:#fffffa;}
#treeBox .ec{margin:0 5 0 5;}
#treeBox .hasItems{font-weight:bold;height:20px;padding:3 6 0 6;margin:2px;cursor:hand;color:#555555;border:1px solid #fffffa;}
#treeBox .Items{height:20px;padding:3 6 0 6;margin:1px;cursor:hand;color:#555555;border:1px solid #fffffa;}
</style>
<script>
//code by star 20003-4-7
var HC = "color:#990000;border:1px solid #cccccc";
var SC = "background-color:#efefef;border:1px solid #cccccc;color:#000000;";
var IO = null;
function initTree(){
var rootn = document.all.menuXML.documentElement;
var sd = 0;
document.onselectstart = function(){return false;}
document.all.treeBox.appendChild(createTree(rootn,sd));
}
function createTree(thisn,sd){
var nodeObj = document.createElement("span");
var upobj = document.createElement("span");
with(upobj){
style.marginLeft = sd*10;
className = thisn.hasChildNodes()?"hasItems":"Items";
innerHTML = "<img src=expand.gif class=ec>" + thisn.getAttribute("text") +"";
onmousedown = function(){
if(event.button != 1) return;
if(this.getAttribute("cn")){
this.setAttribute("open",!this.getAttribute("open"));
this.cn.style.display = this.getAttribute("open")?"inline":"none";
this.all.tags("img")[0].src = this.getAttribute("open")?"expand.gif":"contract.gif";
}
if(IO){
IO.runtimeStyle.cssText = "";
IO.setAttribute("selected",false);
}
IO = this;
this.setAttribute("selected",true);
this.runtimeStyle.cssText = SC;
}
onmouseover = function(){
if(this.getAttribute("selected"))return;
this.runtimeStyle.cssText = HC;
}
onmouseout = function(){
if(this.getAttribute("selected"))return;
this.runtimeStyle.cssText = "";
}
oncontextmenu = contextMenuHandle;
onclick = clickHandle;
}
if(thisn.getAttribute("treeId") != null){
upobj.setAttribute("treeId",thisn.getAttribute("treeId"));
}
if(thisn.getAttribute("href") != null){
upobj.setAttribute("href",thisn.getAttribute("href"));
}
if(thisn.getAttribute("target") != null){
upobj.setAttribute("target",thisn.getAttribute("target"));
}
nodeObj.appendChild(upobj);
nodeObj.insertAdjacentHTML("beforeEnd","<br>")
if(thisn.hasChildNodes()){
var i;
var nodes = thisn.childNodes;
var cn = document.createElement("span");
upobj.setAttribute("cn",cn);
if(thisn.getAttribute("open") != null){
upobj.setAttribute("open",(thisn.getAttribute("open")=="true"));
upobj.getAttribute("cn").style.display = upobj.getAttribute("open")?"inline":"none";
if( !upobj.getAttribute("open"))upobj.all.tags("img")[0].src ="contract.gif";
}
for(i=0;i<nodes.length;cn.appendChild(createTree(nodes[i++],sd+1)));
nodeObj.appendChild(cn);
}
else{
upobj.all.tags("img")[0].src ="endnode.gif";
}
return nodeObj;
}
window.onload = initTree;
</script>
<script>
function clickHandle(){
if((this.getAttribute("href")!=null)&&(this.getAttribute("href")!="http://"))
{parent.mainFrame.location.href=this.getAttribute("href");} //在MainFrame窗口打开连接。
}
function contextMenuHandle(){
event.returnValue = false;
var treeId = this.getAttribute("treeId");
// your code here
}
</script>
</HEAD>
<BODY>
<xml id=menuXML>
<?xml version="1.0" encoding="GB2312"?>
<DSTreeRoot text="系统菜单" open="true" treeId="123">
<%
Set rs = Conn.Execute("SELECT (select count(*) from Menu where Menu.parentid=x.id and Menu.ID in (SELECT UserLevel.menuid FROM UserLevel WHERE UserLevel.userid = 1)) AS children, * FROM Menu AS x WHERE x.id in (SELECT UserLevel.menuid FROM UserLevel WHERE UserLevel.userid = 1)")
Do while not rs.eof
if rs("ParentID")=0 then
Count = Rs ("children")
%>
<DSTree text="<%=rs("Content")%>" href="<%=rs("Link")%>" open="false" treeId="<%=rs("ID")%>">
<%
rs.MoveNext
end if
for i=1 to Count
%>
<DSTree text="<%=rs("Content")%>" href="<%=rs("Link")%>" open="false" treeId="<%=rs("ID")%>">
</DSTree>
<%
Rs.MoveNext
Next
Response.write("</DSTree>")
Loop
rs.close
Conn.close
Set rs = Nothing
Set Conn = Nothing
%>
</DSTreeRoot>
</xml>
<table style="position:absolute;left:0;top:0;">
<tr><td id=treeBox style="width:400px;height:200px;border:1px solid #cccccc;padding:5 3 3 5;" valign=top></td></tr>
</table>
</BODY>
</HTML> |
|
超级ASP大分页-我的类我做主
|
<%
'===============================================
'ShowMorePage ASP版本
'本程序可以免费使用、修改，但请保留以上信息
'
'Function
'本程序主要是对数据分页的部分进行了封装，而数据显示部份完全由用户自定义，
'支持URL多个参数:http://www.***.com/***.asp?aa=1&page=9&bb=2
'
'
'Paramers:
'PapgeSize 定义分页每一页的记录数
'GetCurPageNum 返回当前页的记录集数目此属性只读
'GetRS 返回经过分页的Recordset此属性只读
'GetConn 得到数据库连接
'GetSQL 得到查询语句
'Interface of Class
'ShowPage 显示分页导航条,唯一的公用方法
'
'#############类调用样例#################
'创建对象
'Set hjmPage=new ShowMorePage
'得到数据库连接
'hjmPage.getconn=conn
'sql语句
'hjmPage.getsql="select * from shop_books where newsbook=1 order by bookid desc"
'设置每一页的记录条数据为20条,默认显示10条
'hjmPage.pagesize=20
'显示分页信息,可在任意位置调用，可以调用多次
'hjmPage.showpage()
'set rs=hjmPage.getrs() '返回Recordset
'显示数据开始
'这里就可以自定义显示方式了
'for i=1 to hjmPage.GetCurPageNum '当前页的记录数目
'response.write left(trim(rs("bookname")),13)&"...."
'rs.movenext
'next
'显示数据结束
'set hjmPage=nothing
'#############类调用样例#################
'==============================================
Const Btn_First="<font face=""webdings"">9</font>" '定义第一页按钮显示样式
Const Btn_Prev="<font face=""webdings"">3</font>" '定义前一页按钮显示样式
Const Btn_Next="<font face=""webdings"">4</font>" '定义下一页按钮显示样式
Const Btn_Last="<font face=""webdings"">:</font>" '定义最后一页按钮显示样式
Const XD_Align="Center" '定义分页信息对齐方式
Const XD_Width="100%" '定义分页信息框大小
Class ShowMorePage
Private Obj_Conn,Obj_Rs,Str_Sql,int_PageSize,Str_Errors,Int_CurPage,Str_URL,Int_TotalPage,Int_TotalRecord
'==========================================
'PageSize 属性
'设置每一页的分页大小
'==========================================
Public Property Let PageSize(intvalue)
If IsNumeric(intvalue) Then
int_PageSize=CLng(intvalue)
Else
Str_Errors=Str_Errors & "PageSize的参数不正确"
ShowError()
End If
End Property
Public Property Get PageSize
If int_PageSize="" or (not(IsNumeric(int_PageSize))) Then
PageSize=10
Else
PageSize=int_PageSize
End If
End Property
'==========================================
'GetRS 属性
'返回分页后的记录集
'==========================================
Public Property Get GetRs()
if Int_TotalRecord= 0 then Call GetPage()
If not(Obj_Rs.eof and Obj_Rs.BOF) Then
if Int_CurPage<>1 then
if Int_CurPage-1<Int_TotalPage then
Obj_Rs.move (Int_CurPage-1)*PageSize
dim bookmark
bookmark=Obj_Rs.bookmark
else
Int_CurPage=1
end if
end if
End If
Set GetRs=Obj_Rs
End Property
'=======================================
'GetCurPageNum 属性
'返回当前页的记录集数目
'========================================
Public Property Get GetCurPageNum()
dim int_PageNum
int_PageNum = int_PageSize
if Int_TotalRecord= 0 then Call GetPage()
If Int_CurPage>Int_TotalPage Then
Int_CurPage=Int_TotalPage
int_PageNum = Int_TotalRecord-(Int_TotalPage-1)*int_PageSize
ElseIf Int_CurPage=Int_TotalPage Then
int_PageNum = Int_TotalRecord-(Int_TotalPage-1)*int_PageSize
End If
GetCurPageNum = int_PageNum
End Property
'========================================
'GetConn 得到数据库连接
'
'=========================================
Public Property Let GetConn(sconn)
Set Obj_Conn=sconn
End Property
'=========================================
'GetSQL 得到查询语句
'
'=========================================
Public Property Let GetSQL(svalue)
Str_Sql=svalue
End Property
'==========================================
'Class_Initialize 类的初始化
'初始化当前页的值
'
'==========================================
Private Sub Class_Initialize
'========================
'设定一些参数的黙认值
'========================
int_PageSize=10 '设定分页的默认值为10
Int_TotalRecord= 0
'========================
'获取当前面的值
'========================
If request("page")="" Then
Int_CurPage=1
ElseIf not(IsNumeric(request("page"))) Then
Int_CurPage=1
ElseIf CInt(Trim(request("page")))<1 Then
Int_CurPage=1
Else
Int_CurPage=CInt(Trim(request("page")))
End If
End Sub
'============================================
'openRS 打开数据集
'有首页、前一页、下一页、末页、还有数字导航
'
'============================================
Private Sub openRS()
Set Obj_Rs=Server.createobject("adodb.recordset")
Obj_Rs.Open Str_Sql,Obj_Conn,1,1
End Sub
'============================================
'getPage 创建分页导航条
'有首页、前一页、下一页、末页、还有数字导航
'
'============================================
Private Sub GetPage()
If TypeName(Obj_Rs)<>"Object" Then Call openRS()
Int_TotalRecord=Obj_Rs.RecordCount
If Int_TotalRecord<=0 Then
Str_Errors=Str_Errors & "总记录数为零，请输入数据"
Call ShowError()
End If
If Int_TotalRecord mod PageSize =0 Then
Int_TotalPage = Int_TotalRecord \ int_PageSize
Else
Int_TotalPage = Int_TotalRecord \ int_PageSize+1
End If
If Int_CurPage>Int_TotalPage Then
Int_CurPage=Int_TotalPage
End If
End Sub
'=============================================
'ShowPage 创建分页导航条
'有首页、前一页、下一页、末页、还有数字导航
'
'=============================================
Public Sub ShowPage()
Dim str_tmp
Str_URL = GetUrl()
if Int_TotalRecord= 0 then Call GetPage()
'=============================================
'显示分页信息，各个模块根据自己要求更改显求位置
'=============================================
response.write ""
str_tmp=ShowFirstPrv
response.write str_tmp
str_tmp=showNumBtn
response.write str_tmp
str_tmp=ShowNextLast
response.write str_tmp
str_tmp=ShowPageInfo
response.write str_tmp
response.write ""
End Sub
'=============================================
'ShowFirstPrv 显示首页、前一页
'
'
'=============================================
Private Function ShowFirstPrv()
Dim Str_tmp,int_prvpage
If Int_CurPage=1 Then
str_tmp=Btn_First&" "&Btn_Prev
Else
int_prvpage=Int_CurPage-1
str_tmp="<a href="""&Str_URL & "1" & """>" & Btn_First&"</a> <a href=""" & Str_URL & CStr(int_prvpage) & """>" & Btn_Prev&"</a>"
End If
ShowFirstPrv=str_tmp
End Function
'=============================================
'ShowNextLast 下一页、末页
'
'
'=============================================
Private Function ShowNextLast()
Dim str_tmp,int_Nextpage
If Int_CurPage>=Int_TotalPage Then
str_tmp=Btn_Next & " " & Btn_Last
Else
Int_NextPage=Int_CurPage+1
str_tmp="<a href=""" & Str_URL & CStr(int_nextpage) & """>" & Btn_Next&"</a> <a href="""& Str_URL & CStr(Int_TotalPage) & """>" & Btn_Last&"</a>"
End If
ShowNextLast=str_tmp
End Function
'==========================================
'ShowNumBtn 数字导航
'每次显示10页
'
'==========================================
Private Function showNumBtn()
Dim i,str_tmp,m,n
m = Int_CurPage - 4
n = Int_TotalPage
if n>1 then
for i = 1 to 10
if m < 1 then m = 1
if m > n then
exit for
end if
str_tmp=str_tmp & "[<a href=""" & Str_URL & CStr(i) & """>"&i&"</a>] "
m = m + 1
next
end if
showNumBtn=str_tmp
End Function
'=======================================
'ShowPageInfo 分页信息
'更据要求自行修改
'
'=======================================
Private Function ShowPageInfo()
Dim str_tmp
str_tmp="页次:"&Int_CurPage&"/"&Int_TotalPage&"页 共"&Int_TotalRecord&"条记录 "&int_PageSize&"条/每页"
ShowPageInfo=str_tmp
End Function
'============================================
'GetURL 得到当前的URL
'更据URL参数不同，获取不同的结果
'
'============================================
Private Function GetURL()
Dim strUrl,tmp_URL,i,j,search_str,result_url
search_str="page="
strUrl=Request.ServerVariables("URL")
strUrl=split(strUrl,"/")
i=UBound(strUrl,1)
tmp_URL=strUrl(i)'得到当前页文件名
str_params=Trim(Request.ServerVariables("QUERY_STRING"))
If str_params="" Then
result_url=tmp_URL & "?page="
Else
If InstrRev(str_params,search_str)=0 Then
result_url=tmp_URL & "?" & str_params &"&page="
Else
j=InstrRev(str_params,search_str)-2
If j=-1 Then
result_url=tmp_URL & "?page="
Else
str_lparams=Left(str_params,j)
str_rparams=right(str_params,len(str_params)-j-1)
if InStr(str_rparams,"&")<>0 then
str_rparams=right(str_rparams,len(str_rparams)-InStr(str_rparams,"&")+1)
else
str_rparams = ""
end if
result_url=tmp_URL & "?" & str_lparams&str_rparams&"&page="
End If
End If
End If
GetURL=result_url
End Function
'================================================
' 设置 Terminate 事件。
'
'================================================
Private Sub Class_Terminate
Obj_Rs.close
Set Obj_Rs=nothing
Obj_Conn.close
set Obj_Conn = nothing
End Sub
'============================================
'ShowError 错误提示
'
'
'============================================
Private Sub ShowError()
If Str_Errors <> "" Then
Response.Write("" & Str_Errors & "")
Response.End
End If
End Sub
End class
%>
<!--#include file="include/function.asp"-->
<%
dim conn
call dbconnect()
'#############类调用样例#################
'创建对象
Set hjmPage=new ShowMorePage
'得到数据库连接
hjmPage.getconn=conn
'sql语句
hjmPage.getsql="select Top 6 * from shop_books where newsbook=1 order by bookid desc"
'设置每一页的记录条数据为5条
hjmPage.pagesize=2
set rs=hjmPage.getrs() '返回Recordset
'显示分页信息，这个方法可以，在set rs=hjmPage.getrs()以后,可在任意位置调用，可以调用多次
hjmPage.showpage()
'显示数据
Response.Write("<br/>")
for i=1 to hjmPage.GetCurPageNum '当前页的记录数目
'这里就可以自定义显示方式了
%> |
|
将数据库的内容生成WORD文档
|
1。改头，就是象excel似的
Response.Buffer = TRUE
Response.ContentType = "application/vnd.ms-excel" '--excel
Response.ContentType = "application/msword" '--word
excel倒是没事，但word就是总出错。弱！
2。微软的RTF-DOC的例子
它的例子倒是很成功，可根据实际需要改起来，不好弄，格式不好控制。
3。调用word.application对象
在客户端用这种东西Set objWordDoc = CreateObject("Word.Document")来调用word生成，但是要用户改客户端的安全级别设置，不好！格式控制起来也麻烦。我鼓捣了老半天也搞不定。
4。利用FSO生成word文档
不敢说原创，只能说是综合大家的东西，搞成了这个东西。本文主要介绍我的这种方法。
下面主要介绍从数据库中取资料，然后利用FSO生成Word文档的例子，先给出部分代码，最后给出全部代码。
从数据库中读取数据的代码：
<%
'创建RecordSet对象
Set rs = Server.CreateObject("ADODB.Recordset")
'SQL语句根据实际情况调整
sql="select * from People where PeopleId=" & PeopleId
'Open RecordSet，省略了创建及打开connection对象的代码，请自行添加
rs.open sql,conn,3,3
if rs.eof and rs.bof then
'无记录
else
'做点事情，主要是从数据库中获取一些资源
'赋给变量，再用FSO生成
end if
rs.Close
Set rs=Nothing
conn.Close
Set conn = Nothing
%>
用FSO创建word的代码：
<%
'下面生成文件的代码。
Dim fso, MyFile
'创建FSO对象，有些服务器有可能不支持这个对象，那就没戏了
Set fso = CreateObject("Scripting.FileSystemObject")
'文件名
sFileName = "temp.doc"
'生成新文件文件放在当前目录的word/下,当前测试时必须有这个目录
Set MyFile = fso.CreateTextFile(Server.MapPath(".")& "\word\"&sFileName, True)
myString="这里是你预先排好的word文档，要填的地方都空好了，怎么弄底下告诉！"
'将MyString作为新文件的内容写入文件
MyFile.WriteLine(myString)
MyFile.Close '关闭文件
%>
文件已经生成了。注意在iis里把word目录设置为“写入”。
以下将word文档以数据流写出，不让IE自动打开，防止出错误提示。
让word文档以附件的形式打开的代码:
Dim strFilePathConst
adTypeBinary = 1
strFilePath = "word/temp.doc"
Set objStream = Server.CreateObject("ADODB.Stream")
objStream.Open
objStream.Type = adTypeBinary
objStream.LoadFromFile Server.MapPath(strFilePath) 'change the path if necessary
Response.ContentType = "application/octet-stream"
Response.AddHeader "Content-Disposition", "attachment; filename=化工学院教职工数据采集表--"&rs("name")&".doc"
'如果文件名固定，那就直接filename=文件名.doc，这个名字就是用户选“保存”时，出现的名字
Response.BinaryWrite objStream.Read
Response.Flush
objStream.Close
Set objStream = Nothing '写完，释放对象
[Ctrl+A 全部选择 然后拷贝]
发现把attachment去掉，就会用ie直接打开了。不让它直接打开！
以下为从库中取资料并生成Wrod代码：
<%
Sub CreateWord(filename,content)
Dim fso, MyFile
'创建FSO对象，有些服务器有可能不支持这个对象，那就没戏了
Set fso = CreateObject("Scripting.FileSystemObject")
'生成新文件文件放在当前目录的word/下,当前测试时必须有这个目录
Set MyFile = fso.CreateTextFile(filename, True)
MyFile.WriteLine(content)
MyFile.Close '关闭文件
Set fso = Nothing
End Sub
'假设数据库中有如下字段:
'FileName:生成的word文件名
'content:个人资料
Set conn = CreateObject("Adodb.Connection")
strConn = "Driver={Microsoft Access Driver (*.mdb)};dbq=" & Server.Mappath("你的Access库文件名")
conn.Open strConn
'创建RecordSet对象
Set rs = Server.CreateObject("ADODB.Recordset")
'SQL语句根据实际情况调整
sql="select * from [TableName]"
'Open RecordSet，省略了创建及打开connection对象的代码，请自行添加
rs.open sql,conn,3,3
if rs.eof and rs.bof then
Response.Write("对不起数据库中还没有任何记录！")
Response.End
else
sFilePath = "Word\"
Do While Not rs.Eof
sFileName = Server.Mappath(sFilePath & rs("filename"))
sWordContent = rs("content")
Call CreateWord(sFileName,sWordContent)
rs.MoveNext
Loop
end if
rs.Close
Set rs=Nothing
conn.Close
Set conn = Nothing
%>
[Ctrl+A 全部选择 然后拷贝]
注：myString="" 里面到底是什么？
用word做一个你要的格式的文档，都排好了，
把要填的地方做好标记，比如写几个字什么的。
然后“另存为”web页面。本文所说的是文档里没有图片的情况，有的话我也不会。
到你的硬盘里找到这个web页面，打开，查看源文件，ctrl+a,ctrl+c,
在word里，ctrl+N,ctrl+v,ctrl+F，点“替换”标签，
第一步：查找内容填双引号"，替换为填两个双引号""，全部替换即可。
第二步：点“高级”，查找内容里填“特殊字符”的“段落标记”，替换为填“特殊字符”的“不间断空格”，全部替换即可。
然后ctrl+a,ctrl+c,把东西paste在myString=""的两个引号之间。
==========================================
这时.asp文件已经可以执行，不过生成的是空word文档，啥也没填，没用。
在myString后面的引号里，找你那些标记，比如姓名一栏你填的是“西瓜”，
那么现在找到“西瓜”两个字，删除，打"&rs("name")&"，
包括前后两个引号。以此类推，把所有的地方都用库中的纪录搞定。
========================================
哦，现在就行了。基本满足要求了。
注：几个小问题
1。有时保存你的word文档到web页面时，会生成”你的文件名.files"的文件夹。
那你用这个.asp文件动态生成word文档时，会提示“XXXX丢失”，不爽！
解决办法：在你保存的web页面，查看源文件，查找“你的文件名.files“，
相关的地方都删除掉。一般会有<link...>还有style里的。看着删吧。
2。这个.asp文件执行是会出现下载提示框，如果选“打开”的话，
word就会打开生成的这个文档，我发现有时是以“web视图”打开的，
有时是“页面视图”打开的。很是奇怪，仔细对比了一下，发现：
只要在你的myString里找<w:WordDocument>，在后面加上<w:View>Print</w:View>，那么就会以“页面视图”打开了。好了！
附：使IE下载WORD文档
文件名:Download.asp
<%
Dim Stream
Dim Contents
Dim FileName
Dim FileExt
Const adTypeBinary = 1
FileName = Request.QueryString("FileName")
if FileName = "" Then
Response.Write "无效文件名."
Response.End
End if
’ 下面是不希望下载的文件
FileExt = Mid(FileName, InStrRev(FileName, ".") + 1)
Select Case UCase(FileExt)
Case "ASP", "ASA", "ASPX", "ASAX", "MDB"
Response.Write "受保护文件,不能下载."
Response.End
End Select
’ 下载这个文件
Response.Clear
Response.ContentType = "application/octet-stream"
Response.AddHeader "content-disposition", "attachment; filename=" & FileName
Set Stream = server.CreateObject("ADODB.Stream")
Stream.Type = adTypeBinary
Stream.Open
Stream.LoadFromFile Server.MapPath(FileName)
While Not Stream.EOS
Response.BinaryWrite Stream.Read(1024 * 64)
Wend
Stream.Close
Set Stream = Nothing
Response.Flush
Response.End
%>
使用：Download.asp?FileName=/Files/MY.doc
把你的DOC文件放到根目录Files下，你也可以放到其它地方了。
如：
<A HREF="Download.asp?FileName=/Files/MY.doc">点击下载WORD文档</A>
|
|
随机提取N条记录
|
|
随机提取10条记录的例子：
Sql server：
select top 10 * from 表 order by newid()
Access：
SELECT top 10 * FROM 表 ORDER BY Rnd(id)
Rnd(id) 其中的id是自动编号字段，可以利用其他任何数值来完成
比如用姓名字段(UserName)
SELECT top 10 * FROM 表 ORDER BY Rnd(len(UserName))
MySql：
Select * From 表 Order By rand() Limit 10 |
|
用VB 6封装ASP代码, 制作DLL组件
|
启动vb6.0，新建-->Active dll工程。单击"工程"-->引用,选择"microsoft active server pages
object library"
和"microsoft activeX data objects 2.1 library"两项。将类模块的名称改为dcss.将工程的名称
改为yygwy.保存工程文件yygwy.vbp和类文件dcss.cls。
在dcss.cls中写入:
Private myscriptingcontext As ScriptingContext
Private myapplication As Application
Private myrequest As Request
Private myresponse As Response
Private myserver As Server
Private mysession As Session
Public Sub onstartpage(passedscriptingcontext As ScriptingContext)
Set myscriptingcontext = passedscriptingcontext
Set myapplication = myscriptingcontext.Application
Set myrequest = myscriptingcontext.Request
Set myresponse = myscriptingcontext.Response
Set myserver = myscriptingcontext.Server
Set mysession = myscriptingcontext.Session
End Sub
Public Sub onendpage()
Set myscriptingcontext = Nothing
Set myapplication = Nothing
Set myrequest = Nothing
Set myresponse = Nothing
Set myserver = Nothing
Set mysession = Nothing
End Sub
'以上语句是必须的。
'定义两个公有函数
Public Function rsresult(strsql As String) As Recordset
Dim mycnn As Connection
Dim myset As Recordset
Dim strconnstring As String
'strconnstring = "provider=sqloledb.1;
password=;" & "user id=sa;" & "initial catalog=vlog;" & "data source=hpe60;
connect timeout=15"
strconnstring = "driver={sql server};server=yang;uid=sa;pwd=;
database=dcss"
'mycnn.ConnectionString = strconnstring
mycnn.Open strconnstring
myset.ActiveConnection = mycnn
myset.Open strsql, mycnn, 3, adCmdText
Set rsresult = myset
End Function
Public Function datasource() As Variant
datasource = "driver={sql server};server=yang;uid=sa;pwd=; database=dcss"
End Function
编译生成dcss.dll文件。注册regsvr32 路径dcss.dll。
用visual interdev打开global.asa文件.当然了，你也可以在其它文件中使用。
set dcss=server.CreateObject("yygwy.dcss")
oconn=dcss.datasource()
application("strconn")=oconn
在其它的页面中如下调用即可：
set objConn = Server.CreateObject("ADODB.Connection")
objConn.Open application("strconn")
|
|
ASP特殊字符过滤
|
Function ChkInvaildWord(Words)
Const InvaildWords="select|update|delete|insert|@|--|," '需要过滤得字符以“|”隔开，最后结束的字符必须是|
ChkInvaildWord=True
InvaildWord=Split(InvaildWords,"|")
inWords=LCase(Trim(Words))
For i=LBound(InvaildWord) To UBound(InvaildWord)
If Instr(inWords,InvaildWord(i))>0 Then
ChkInvaildWord=True
Exit Function
End If
Next
ChkInvaildWord=False
End Function |
|
仅用xsl和asp实现分页功能
|
asp文件大致结构：
<%@ Language=VBScript %>
<!-- #include file=include/lib.asp -->
<%
cc=server.MapPath("trans.xml")
set source=server.CreateObject("msxml2.domdocument")
source.async=false
source.load(cc)
xslfile=server.MapPath("index.xsl")
set style=server.CreateObject("msxml2.domdocument")
style.async=false
style.load(xslfile)
'Response.write source.transformNode(style)
Response.write gb_html(source.transformNode(style))
Response.End
%>
load进来的xml数据是这样的：
<?xml version="1.0" encoding="GB2312" ?>
<root>
<function>
<PO>里面的标签在后面的xsl文件里被"<xsl:for-each>"</PO>
<PO>……………………</PO>
<PO>……………………</PO>
<PO>……………………</PO>
</function>
</root>
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
xsl文件的内容：
<?xml version="1.0" encoding="GB2312"?>
<xsl:stylesheet version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform">
<xsl:include href="include/ydzhongxin.xsl"/><!-- 嵌入头模板，尾模板 -->
<xsl:param name="yd">7</xsl:param><!-- 调用二级导航条所用参数 -->
<xsl:param name="page"> <xsl:value-of select="count(//PO)"/></xsl:param>
<!-- 定义根模板 -->
<xsl:template match="/">
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312"/>
<link rel="stylesheet" type="text/css" href="include/style.css"/>
<title>结果列表</title>
</head>
<body leftMargin="0" topMargin="0">
<xsl:call-template name="ydtitle"/>
<div align="center">
<xsl:apply-templates select="root/function"/>
<!-- 匹配function模板 -->
</div>
<xsl:call-template name="end"/>
</body>
</html>
</xsl:template>
<!-- 定义function模板 -->
<xsl:template match="function">
<!-- －－－－－－－－－－－－－－－翻页链接开始－－－－－－－－－－－ -->
<xsl:variable name="pagesize">5</xsl:variable><!-- 是分页参数 -->
<xsl:choose>
<xsl:when test="/root/session/page[text()!='']">
<!-- 进入一级choose的一个when条件分支！！！！！
－－－－－－－－－－－－－进入此分支，证明用户已有翻页操作－－－－－－－－－－－－－－ -->
<xsl:variable name="page"><xsl:value-of select="/root/session/page"/></xsl:variable>
<table border="0" cellpadding="2" cellspacing="0" width="630">
<tr>
<td align="right">
<!-- 进入二级choose！！！ -->
<xsl:choose>
<!-- ①id小于等于0的情况，显示最后一页。-->
<xsl:when test="$pid<1">
<a><xsl:attribute name="href">search_jieguo.asp?id=<xsl:value-of select="count
(//PO)"/></xsl:attribute>
[ 首 ]</a>
<a title="前一页"><xsl:attribute name="href">search_jieguo.asp?id=<xsl:value-of
select="$size*2"/></xsl:attribute>[ <<< ] </a>
<a title="后一页">[ >>> ] </a>
<a>[ 尾 ]</a>
</xsl:when>
<!-- ②id位于[0～pagesize]之间的情况，前页正常，后页无。 -->
<xsl:when test="$pid<($size + 1) and $pid>0">
<a><xsl:attribute name="href">search_jieguo.asp?id=<xsl:value-of select="count
(//PO)"/></xsl:attribute>
[ 首 ]</a>
<a title="前一页"><xsl:attribute name="href">search_jieguo.asp?id=<xsl:value-of
select="$pid+$size"/></xsl:attribute>[ <<< ] </a>
<a title="后一页">[ >>> ] </a>
<a>[ 尾 ]</a>
</xsl:when>
<!-- ③id位于[pagesize～count]之间的情况，前页无，后页正常。 -->
<xsl:when test="$pid<count(//PO) and $pid>(count(//PO)-$size)">
<a><xsl:attribute name="href">search_jieguo.asp?id=<xsl:value-of select="count
(//PO)"/></xsl:attribute>
[ 首 ]</a>
<a title="前一页"><xsl:attribute name="href">search_jieguo.asp?id=<xsl:value-of select="count
(//PO)"/></xsl:attribute>[ <<< ] </a>
<a title="后一页"><xsl:attribute name="href">search_jieguo.asp?id=<xsl:value-of select="$pid -
$size"/></xsl:attribute>[ >>> ] </a>
<a><xsl:attribute name="href">search_jieguo.asp?id=<xsl:value-of select="$size"/></xsl:attribute>
[ 尾 ]</a>
</xsl:when>
<!-- ④id等于count的情况，显示首页。 -->
<xsl:when test="$pid=count(//PO)">
<a>[ 首 ]</a>
<a title="前一页">[ <<< ] </a>
<a title="后一页"><xsl:attribute name="href">search_jieguo.asp?id=<xsl:value-of select="count
(//PO)-$size"/></xsl:attribute>[ >>> ] </a>
<a><xsl:attribute name="href">search_jieguo.asp?id=<xsl:value-of select="$size"/></xsl:attribute>
[ 尾 ]</a>
</xsl:when>
<!-- ⑤id大于count的情况，显示首页。 -->
<xsl:when test="$pid>count(//PO)">
<a>[ 首 ]</a>
<a title="前一页">[ <<< ] </a>
<a title="后一页"><xsl:attribute name="href">search_jieguo.asp?id=<xsl:value-of select="count
(//PO)-$size"/></xsl:attribute>[ >>> ] </a>
<a><xsl:attribute name="href">search_jieguo.asp?id=<xsl:value-of select="$size"/></xsl:attribute>
[ 尾 ]</a>
</xsl:when>
<!-- 正常情况 -->
<xsl:otherwise>
<a><xsl:attribute name="href">search_jieguo.asp?id=<xsl:value-of select="count
(//PO)"/></xsl:attribute>
[ 首 ]</a>
<a title="前一页"><xsl:attribute name="href">search_jieguo.asp?id=<xsl:value-of select="$pid +
$size"/></xsl:attribute>[ <<< ] </a>
<a title="后一页"><xsl:attribute name="href">search_jieguo.asp?id=<xsl:value-of select="$pid -
$size"/></xsl:attribute>[ >>> ] </a>
<a><xsl:attribute name="href">search_jieguo.asp?id=<xsl:value-of select="$size"/></xsl:attribute>
[ 尾 ]</a>
</xsl:otherwise>
</xsl:choose>
<!-- －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－ -->
</td>
</tr>
</table><br/>
<!-- －－－－－－－－－遍历符合要求的PO结点－－－－－－－－－－－－－ -->
<xsl:for-each select="PO[position()<=$pid and position()>($pid - $size)]">
<xsl:sort select="PO_ID" order="descending" data-type="number"/>
<xsl:call-template name="PO"/>
<br/><br/><br/>
</xsl:for-each>
<!-- 退出一级choose的一个when条件分支！！！！！ -->
</xsl:when>
<!-- －－－－－－－－－－－－－－－－－－用户直接进入的状态－－－－－－－－－－－－－－－－－－ -->
<xsl:otherwise>
<!-- 进入一级choose的另一个when条件分支！！！！！ -->
<table border="0" cellpadding="2" cellspacing="0" width="630">
<tr><td align="right">
<a>[ 首 ]</a>
<a title="前一页">[ <<< ] </a>
<a title="后一页"><xsl:attribute name="href">search_jieguo.asp?id=<xsl:value-of select="$pid -
$size"/></xsl:attribute>[ >>> ] </a>
<a><xsl:attribute name="href">search_jieguo.asp?id=<xsl:value-of select="$size"/></xsl:attribute>
[ 尾 ]</a>
</td></tr>
</table><br/>
<xsl:for-each select="PO[position()<=$pid and position()>($pid - $size)]">
<xsl:sort select="PO_ID" order="descending" data-type="number"/>
<xsl:call-template name="PO"/>
<br/><br/><br/>
</xsl:for-each>
<!-- 退出一级choose的另一个when条件分支！！！！！ -->
</xsl:otherwise>
</xsl:choose>
<!-- －－－－－－－－－－－－－－翻页链接到此结束－－－－－－－－－－－ -->
<br/>
<xsl:if test="count(//PO)=0">
<div align="center"><b>
<img src="images/msg2.gif" align="absmiddle"/>
</b><font color="#CC0000" face="楷体ＣＳ" size="3"><b>
没有符合当前条件的订单</b></font>
<a><xsl:attribute name="href">lkxx.asp?po_id=<xsl:value-of select="PO_ID"/></xsl:attribute></a>
</div>
><br/><br/>
<input type="button" value="重新输入条件查询" onclick="location.href='search.asp'"/>
</xsl:if>
</xsl:template>
<!-- －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－-->
<xsl:template name="PO">
<table border="1" cellpadding="2" cellspacing="0" width="100%">
<tr>
<td nowrap="nowrap" width="70"> 号码</td>
<td nowrap="nowrap" width="110"> 名称</td>
<td nowrap="nowrap" width="110"> 日期</td>
<td nowrap="nowrap" width="110"> 人员</td>
</tr>
<tr>
<td nowrap="nowrap"> <xsl:value-of select="num"/></td>
<td nowrap="nowrap"> <xsl:value-of select="username"/></td>
<td nowrap="nowrap"> <xsl:value-of select="dt"/></td>
<td nowrap="nowrap"> <xsl:value-of select="men"/></td>
</tr>
</table>
</xsl:template>
</xsl:stylesheet>
|
|
使用javascript+dom+xml实现分页
|
作者：海仔
共有两个文件tmh.htm & tt.xml
源代码如下：
tmh.htm
___________________________________________________
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
<HTML>
<HEAD>
<TITLE> New Document </TITLE>
<META NAME="Generator" CONTENT="EditPlus">
<META NAME="Author" CONTENT="">
<META NAME="Keywords" CONTENT="">
<META NAME="Description" CONTENT="">
<link rel="stylesheet" href="../website.css" type="text/css">
</HEAD>
<BODY>
<script language="javascript">
//****************变量相关定义**************
var pagenum=4; //每页显示几条信息
var page=0 ;
var contpage ;
var BodyText="";
var xmlDoc = new ActiveXObject("Microsoft.XMLDOM");
var mode="member";
var toolBar;
xmlDoc.async="false"
xmlDoc.load("tt.xml")
//***************这个地方是你根据实际取得的字段名称来改了
header="<TABLE border=1><tr><td>姓名</td><td>图标</td><td>IP地址</td><td>email</td><td></td><td>日期</td><td></td><td></td></tr>";
//检索的记录数
maxNum = xmlDoc.getElementsByTagName(mode).length
//每条记录的列数
column=xmlDoc.getElementsByTagName(mode).item(0).childNodes
//每条记录的列数
colNum=column.length
//页数
pagesNumber=Math.ceil(maxNum/pagenum)-1;
pagesNumber2=Math.ceil(maxNum/pagenum);
//上一个页面
function UpPage(page)
{
thePage="前一页";
if(page+1>1) thePage="<A HREF='#' onclick='Javascript:return UpPageGo()'>前一页</A>";
return thePage;
}
function NextPage(page)
{
thePage="后一页";
if(page<pagesNumber) thePage="<A HREF='#' onclick='Javascript:return NextPageGo()'>后一页</A>";
return thePage;
}
function UpPageGo(){
if(page>0) page--;
getContent();
BodyText="";
}
//当前的页数
function currentPage()
{
var cp;
cp="当前是第 "+(page+1)+" 页";
return cp;
}
//总共的页数
function allPage()
{
var ap;
ap='总共 '+(pagesNumber+1)+' 页';
return ap
}
function NextPageGo()
{
if (page<pagesNumber) page++;
getContent();
BodyText="";
}
//显示分页状态栏
function pageBar(page)
{
var pb;
pb=UpPage(page)+" "+NextPage(page)+" "+currentPage()+" "+allPage()+selectPage();
return pb;
}
function changePage(tpage)
{
page=tpage
if(page>=0) page--;
if (page<pagesNumber) page++;
getContent();
BodyText="";
}
function selectPage()
{
var sp;
sp="<select name='hehe' onChange='javascript:changePage(this.options[this.selectedIndex].value)'>";
//sp="<select name='hehe' onChange='alert(this.options[this.selectedIndex].value)'>";
sp=sp+"<option value=''></option>";
for (t=0;t<=pagesNumber;t++)
{
sp=sp+"<option value='"+t+"'>"+(t+1)+"</option>";
}
sp=sp+"</select>"
return sp;
}
function getContent()
{
if (!page) page=0;
n=page*pagenum;
endNum=(page+1)*pagenum;
if (endNum>maxNum) endNum=maxNum;
BodyText=header+BodyText;
for (;n<endNum;n++)
{
BodyText=BodyText+"<TR>";
for (m=0;m<=colNum-1;m++)
{
mName=column.item(m).tagName;
BodyText=BodyText+("<TD>"+xmlDoc.getElementsByTagName(mName).item(n).text+"</TD>");
}
BodyText=BodyText+"</TR>"
mm="";
}
showhtml.innerHTML=BodyText+"</table>"+pageBar(page);
BodyText=""
}
</script>
<div id="showhtml"></div>
<script>
if (maxNum==0)
{
document.write("没有检索到合适的人才信息")
}
else
{
getContent()
}
</script>
</BODY>
</HTML>
//下面是tt.xml的代码
<?xml version="1.0" encoding="GB2312"?>
<rautinee>
<member id='1'>
<name>海仔</name>
<loginName>rautinee</loginName>
<email>rautinee@btamail.net.cn</email></member>
<member id='2'>
<name>刚强</name>
<loginName>hehe</loginName>
<email>rautinee@chinamanagers.com</email></member>
<member id='3'>
<name>金华刚</name>
<loginName>nature_it</loginName>
<email>rautinee_sea@hotmail.com</email></member>
<member id='4'>
<name>的简强</name>
<loginName>tank</loginName>
<email>tank@163.com</email></member>
<member id='7'>
<name>合资</name>
<loginName>kaka</loginName>
<email>kaka@eyou.com</email></member>
<member id='6'>
<name>加个人</name>
<loginName>apple</loginName>
<email>apple@163.com</email></member>
<member id='8'>
<name>null</name>
<loginName>sunny</loginName>
<email>rautinee@eyou.com</email></member>
<member id='10'>
<name>宝贝</name>
<loginName>index</loginName>
<email>rautinee@21cn.com</email></member>
<member id='12'>
<name>null</name>
<loginName>login</loginName>
<email>webmaster@chinamanagers.com</email></member>
<member id='13'>
<name>jiang</name>
<loginName>123</loginName>
<email>japing@chianmanagers.com</email></member>
<member id='14'>
<name>null</name>
<loginName>world</loginName>
<email>rautinee@21cn.com</email></member>
<member id='15'>
<name>null</name>
<loginName>swallow</loginName>
<email>swallow@chinamanagers.com</email></member>
<member id='16'>
<name>魏格</name>
<loginName>hotmail</loginName>
<email>rautinee_sea@hotmail.com</email></member>
<member id='17'>
<name>null</name>
<loginName>wrong</loginName>
<email>wrong@chinamanagers.com</email></member>
<member id='18'>
<name>null</name>
<loginName>leah</loginName>
<email>leah@chinamanagers.com</email></member>
<member id='19'>
<name>null</name>
<loginName>ttth</loginName>
<email>rautinee@21cn.com</email></member>
</rautinee>
|
|
限制某段IP地址
|
function IP2Num(sip)
dim str1,str2,str3,str4
dim num
IP2Num=0
if isnumeric(left(sip,2)) then
str1=left(sip,instr(sip,".")-1)
sip=mid(sip,instr(sip,".")+1)
str2=left(sip,instr(sip,".")-1)
sip=mid(sip,instr(sip,".")+1)
str3=left(sip,instr(sip,".")-1)
str4=mid(sip,instr(sip,".")+1)
num=cint(str1)*256*256*256+cint(str2)*256*256+cint(str3)*256+cint(str4)-1
IP2Num = num
end if
end function
userIPnum = IP2Num(Request.ServerVariables("REMOTE_ADDR"))
if userIPnum > IP2Num("192.168.0.0") and userIPnum < IP2Num("192.168.0.255") then
response.write ("<center>您的IP被禁止</center>")
response.end
end if |
|
ASP编写完整的一个IP所在地搜索类
|
修正了查询方法，查询的方法和追捕的一致；只是追捕会自动更正IP。
还有个函数的书写错误，也已经修正；
包括增加了一个IP地址正确性的验证函数。（只是从格式上判断）
<%
'作者：萧寒雪(S.F.)
'QQ号：410000
Server.ScriptTimeout = &HE10 '&H3C
Response.Buffer = ("S.F." = "S.F.")
Dim IpSearch
'建立对象
Set IpSearch = New clsIpSearch
' 该句建立SQL Server的IP地址库的连接，可使用默认连接，但要保证存在wry.mdb
IpSearch.ConnectionString = "DRIVER={SQL Server};SERVER=hostname:UID=sa;PWD=;DATABASE=Ip"
' 设置要查询的IP，可用默认值，这里设置的是 127.0.0.1
IpSearch.IpAddress = &H7F & "." & &H00 & "." & &H00 & "." & &H01
If Request.QueryString("IP")<>"" Then
If IpSearch.Valid_IP(Request.QueryString("IP")) Then
IpSearch.IpAddress = Trim(Request.QueryString("IP"))
End If
End If
' 取得IP 所在地，反馈值有三个，以逗号分割
' 格式为：所在国家或地区,当地上网地区,提供正确IP地址信息的用户名
Response.Write ("所在地:" & IpSearch.GetIpAddrInfo() & "<br>")
' 取出IP地址
Response.Write ("IP:" & IpSearch.IpAddress & "<br>")
' 将IP地址转换为数值
Response.Write ("IP转换为数值:" & IpSearch.CLongIP(IpSearch.IpAddress) & "<br>")
' 将IP地址转换为数值后还原成IP字符串
Response.Write ("数值还原成IP:" & IpSearch.CStringIP(IpSearch.CLongIP(IpSearch.IpAddress)) & "<br>")
Response.Write ("<hr>")
'这里是测试代码
'dim a,b,c,d
'for a = 0 to 255
' for b= 0 to 255 step 20
' for c=0 to 255 step 20
' for d = 0 to 255 step 20
' IpSearch.IpAddress = a & "." & b & "." & c & "." & d
' Response.Write ("所在地:" & IpSearch.GetIpAddrInfo() & "<br>")
' Response.Write ("IP:" & IpSearch.IpAddress & "<br>")
' Response.Write ("IP转换为数值:" & IpSearch.CLongIP(IpSearch.IpAddress) & "<br>")
' Response.Write ("数值还原成IP:" & IpSearch.CStringIP(IpSearch.CLongIP(IpSearch.IpAddress)) & "<br>")
' Response.Write ("<hr>")
' next
' next
' next
'next
%>
<%
Class clsIpSearch
'##################################
'声明：本程序采用的数据为网络上著名的IP工具软件《追捕》作者“冯志宏”
'先生所精心搜集整理。
'《追捕》数据库的转换方法：
'修改wry.dll 文件后缀名称为 wry.dbf
'方法一：
' 启动Access 数据，选择打开数据库，选择打开的文件类型为“dBASE 5 (*.dbf)”
' 打开wry.dbf文件，选择《工具》菜单下的《数据库实用工具》中的《转换数据库》
' 选择《转换为 Access 97 格式(版本可选)》功能，保存文件即可成为MDB格式。
'方法二：
' 使用SQL Server提供的《导入和导出数据》向导。
' 方法简要说明：在ODBC 控制面板中设置指向wry.dbf的DSN。
' 使用《导入和导出数据》向导，选择其正确的驱动程序和要导入的库即可。
' 或者直接导入由方法一生成的MDB文件入库。
'方法三：
' 使用Access 打开wry.dbf 文件后将自动通过MDB库引用原库数据。
'
'未安装其他数据库平台，其他方法欠考虑。
'###################### 类说明 ####################################
'# IP 所在地搜索类
'# ConnectionString 为数据库连接声明，默认声明同级目录的wry.mdb
'# IpAddress 请设置为进行搜索的IP 地址，默认取当前访问者IP
'# 类建立方法
'# Dim objVal '声明一个变量
'# Set objVal = New clsIpSearch '建立类对象
'# Response.Write (objVal.IpAddress) '显示当前访问者IP
'# IP 搜索类方法列表：
'# .Valid_IP 'IP 地址正确性效验
'# 参数：IP 'IP 数值或者字符串
'# .CLongIP '将IP地址转换为长整型的数值
'# 参数：asNewIP '要转换的IP地址字符串
'# .CStringIP '将长整型的数值转换为IP
'# 参数：anNewIP '要还原为IP地址的数值
'# .GetClientIP '取访问者的IP
'# .GetIpAddrInfo '得到设置过IpAddRess属性的IP所在地
'# 属性列表（自动初始化）：
'# ConnEctionString 'ADo 访问数据库连接说明
'# IpAddress '要操作的IP地址
'# 内部错误处理：
'# 欠缺，未做，请自行补充。
'#################################
Public ConnectionString
Public IpAddress
Private DBConn '连接对象，模块级声明
'────────────────────────────────
' 类初始化
Private Sub Class_initialize()
' 这里建立的是通过“数据转换--方法一”生成的mdb 库文件
ConnectionString="DRIVER={Microsoft Access Driver (*.mdb)};DBQ=" & Server.MapPath("wry.mdb")
IpAddress = GetClientIP()
Set DBConn = OpenConnection()
End Sub
'────────────────────────────────
' 类注销
Private Sub Class_Terminate()
ConnectionString = Null
IpAddress = Null
DBConn.Close
Set DBConn = Nothing
End Sub
'────────────────────────────────
' 建立一个连接
Private Function OpenConnection()
Dim tmpConn
Set tmpConn=Server.CreateObject("ADODB.Connection")
tmpConn.Open ConnectionString
Set OpenConnection=tmpConn
Set tmpConn=nothing
End Function
'────────────────────────────────
' 执行一个SQL命令，并返回一个数据集对象
Private Function SQLExeCute(strSql)
Dim Rs
Set Rs=DBConn.ExeCute(strSQL)
Set SQLExeCute = Rs
Set Rs=nothing
End Function
'────────────────────────────────
'IP 效验
Public Function Valid_IP(ByVal IP)
Dim i
Dim dot_count
Dim test_octet
Dim byte_check
IP = Trim(IP)
' 确认IP长度
If Len(IP) < &H08 Then
Valid_IP = False
'显示错误提示
Exit Function
End If
i = &H01
dot_count = &H00
For i = 1 To Len(IP)
If Mid(IP, i, &H01) = "." Then
' 增加点的记数值
' 并且设置text_octet 值为空
dot_count = dot_count + &H01
test_octet = ""
If i = Len(IP) Then
' 如果点在结尾则IP效验失败
Valid_IP = False
' 显示错误提示
Exit Function
End If
Else
test_octet = test_octet & Mid(IP, i, &H01)
' 使用错误屏蔽来检查数据段值的正确性
On Error Resume Next
' 进行强制类型转换
' 如果转换失败就可通过检查Err是否为真来确认
byte_check = CByte(test_octet)
If (Err) Then
' 强制类型转换产生错误
' 所取段值的数据不为数值
' 或所取段值的数据长度大于&HFF
' 则类型不为byte类型
' IP 地址的正确性为假
Valid_IP = False
Exit Function
End If
End If
Next
' 通过上一步的验证，现在应该要检查小点是否有3个
If dot_count <> &H03 Then
Valid_IP = False
Exit Function
End If
' 一切正常，那么该IP为正确的IP地址
Valid_IP = True
End Function
'────────────────────────────────
' 转换一个数值为IP
Public Function CStringIP(ByVal anNewIP)
Dim lsResults
Dim lnTemp
Dim lnIndex
For lnIndex = &H03 To &H00 Step -&H01
lnTemp = Int(anNewIP / (&H100 ^ lnIndex))
lsResults = lsResults & lnTemp & "."
anNewIP = anNewIP - (lnTemp * (&H100 ^ lnIndex))
Next
lsResults = Left(lsResults, Len(lsResults) - &H01)
CStringIP = lsResults
End function
'────────────────────────────────
' 转换一个IP到数值
Public Function CLongIP(ByVal asNewIP)
Dim lnResults
Dim lnIndex
Dim lnIpAry
lnIpAry = Split(asNewIP, ".", &H04)
For lnIndex = &H00 To &H03
if Not lnIndex = &H03 Then
lnIpAry(lnIndex) = lnIpAry(lnIndex) * (&H100 ^ (&H03 - lnIndex))
End if
lnResults = lnResults + lnIpAry(lnIndex)
Next
CLongIP = lnResults
End function
'────────────────────────────────
' 取Client IP
Public Function GetClientIP()
dim uIpAddr
' 本函数参考webcn.Net/AspHouse 文献<取真实的客户IP>
uIpAddr = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
If uIpAddr = "" Then uIpAddr = Request.ServerVariables("REMOTE_ADDR")
GetClientIP = uIpAddr
uIpAddr = ""
End function
'────────────────────────────────
' 读取IP所在地的信息
Public function GetIpAddrInfo()
Dim tmpIpAddr
Dim IpAddrVal
Dim ic,charSpace
Dim tmpSQL
charSpace = ""
IpAddrVal = IpAddress
If Not Valid_IP(IpAddrVal) Then
GetIpAddrInfo =NULL
Exit Function
End If
'将IP字符串劈开成数组好进行处理
tmpIpAddr = Split(IpAddrVal,".",-1,1)
For ic = &H00 To Ubound(tmpIpAddr)
'补位操作,保证每间隔满足3个字符
Select Case Len(tmpIpAddr(ic))
Case &H01 :charSpace = "00"
Case &H02 :charSpace = "0"
Case Else :charSpace = ""
End Select
tmpIpAddr(ic) = charSpace & tmpIpAddr(ic)
Next
IpAddrVal = tmpIpAddr(&H00) & "." & tmpIpAddr(&H01) & "." & tmpIpAddr(&H02) & "." & tmpIpAddr(&H03)
'以下为查询，IP地址库基于《追捕》的IP数据库,感谢"冯志宏"先生的贡献
'库结构如下：
'CREATE TABLE [dbo].[wry] (
' [STARTIP] [nvarchar] (17) COLLATE Chinese_PRC_CI_AS NULL , --起始IP段
' [ENDIP] [nvarchar] (17) COLLATE Chinese_PRC_CI_AS NULL , --终止IP段
' [COUNTRY] [nvarchar] (16) COLLATE Chinese_PRC_CI_AS NULL , --国家或者地区
' [LOCAL] [nvarchar] (54) COLLATE Chinese_PRC_CI_AS NULL , --本地地址
' [THANK] [nvarchar] (23) COLLATE Chinese_PRC_CI_AS NULL --感谢修正IP地址用户姓名
') ON [PRIMARY]
'经过分析库的数据存放结构，总结出准确的查询方法，具体看下面的查询过程
tmpSQL = "select * from wry where (startIP<='" & IpAddrVal & "') and (ENDIP>='" & IpAddrVal & "') " & _
" and left(startIP," & Len(tmpIpAddr(&H00)) & ") = '" & tmpIpAddr(&H00) & "'" & _
" and left(endip," & Len(tmpIpAddr(&H00)) & ")='" & tmpIpAddr(&H00) & "'"
charSpace = GetDbIpInfo(tmpSQL)
If Len(charSpace)=&H00 Then
GetIpAddrInfo = NULL
Else
GetIpAddrInfo = charSpace
End If
charSpace = Null
tmpSQL = Null
end function
'────────────────────────────────
' 返回数据查询的字符串
Private function GetDbIpInfo(byVal sql)
Dim OpenIpSearchRs
Dim result
Set OpenIpSearchRs = SQLExeCute(sql)
If Not OpenIpSearchRs.Eof Then
result = NullToSpace(OpenIpSearchRs("COUNTRY")) & "," & NullToSpace(OpenIpSearchRs("LOCAL")) & "," &
NullToSpace(OpenIpSearchRs("THANK"))
Else
result = NULL
End If
OpenIpSearchRs.Close
Set OpenIpSearchRs=Nothing
GetDbIpInfo = result
End function
'────────────────────────────────
' 将数据库空记录转换为空字符
Private function NullToSpace(byVal rsStr)
If isNull(rsStr) Then
NullToSpace = ""
Else
NullToSpace = Trim(rsStr)
End If
End Function
End Class
%>
|
|
ASP应用模板生成html文件的一种方法
|
这里惊云下载系统里的html文件生成方法，看了一下满有用的，所以发上来
<%
set rs=server.createobject("adodb.recordset")
rs.open ("select info_list from mb"),conn,1,1
pencat=rs("info_list")
rs.close
tid=request("tid")
currentPage=cint(request("page"))
MaxPerPage=cint(request("MaxPerPage"))
'################ 读取标题 等.. 开始 ################
rs.open "select * from infotype where id="&tid,conn,1,1
if not rs.eof then
ts=rs("ts")
TN=split(rs("tname"),"|")
TI=split(rs("ts"), ",")
for i = 0 to ubound(TN)-1
if i=ubound(TN)-2 and ubound(TN)>1 then
TTY_id=TI(i)
TTY_name=TN(i)
end if
all_type_top_id=TI(i)
all_type_name=TN(i)
thistype=thistype & "-> <a href=""../info/"&TI(i)&"_1.htm"">"&TN(i)&"</a>"
thistitle=thistitle & " - "&TN(i)&""
next
end if
rs.close
sql="select * from infotype where ts like '"&ts&"%'"
rs.open sql,conn,1,1
if not rs.eof then
do while not rs.eof
sqqq=sqqq& ""&rs("id")&", "
rs.MoveNext
loop
end if
rs.close
''########读取下级分类
rs.open "select * from infotype where tn="&tid&" order by id",conn,1,1
if NOT rs.EOF then
TTY="NO"
Tname=all_type_name
do while NOT rs.EOF
TTNN=split(rs("tname"),"|")(rs("tj")-1)
TXlist=TXlist&"<a href=""../info/"&rs("id")&"_1.htm""><font color=""#000000"">"&TTNN&"</font></a><br>"
rs.MoveNext
loop
end if
rs.close
if TTY_id<>"" and TTY<>"NO" then
rs.open "select * from infotype where tn="&TTY_id&" order by id",conn,1,1
if NOT rs.EOF then
Tname=TTY_name
do while NOT rs.EOF
TTNN=split(rs("tname"),"|")(rs("tj")-1)
TXlist=TXlist&"<a href=""../info/"&rs("id")&"_1.htm""><font color=""#000000"">"&TTNN&"</font></a><br>"
rs.MoveNext
loop
end if
rs.close
end if
''########读取本类top10
sql="select * from info where tid in("&sqqq&") order by hits desc"
rs.open sql,conn,1,1
if rs.eof then
Txtop="·还没有文章"
else
do while not rs.eof
h=h+1
Txtop=Txtop&"·<a href=""../info/"&rs("id")&".htm"">"&rs("title")&"</a><br>"
if h>=10 then exit do
rs.movenext
loop
h=0
end if
rs.close
'读取文章列表
sql="select * from info where tid in("&sqqq&") order by date desc"
rs.open sql,conn,1,1
if rs.eof then
lb=lb&"<tr><td width=""100%"" colspan=""3"">对不起! 暂时没有相关文章 @_@</td></tr>"
mpage=1
allshu=0
else
rs.pagesize=MaxPerPage '得到每页数
mpage=rs.pagecount '得到总页数
rs.move (currentPage-1)*MaxPerPage
allshu=rs.recordcount
h=0
do while not rs.eof
h=h+1
lb=lb&"<tr height=""22""><td width=""77%""><img border=""0"" src=""../images/d_2.gif"" width=""11"" height=""11"">["
set rs_type=server.CreateObject("ADODB.RecordSet")
rs_type.open "select * from infotype where id="&rs("tid"),conn,1,1
if not rs_type.EOF then
TN=split(rs_type("tname"),"|")
lb=lb&"<a href="""&rs("tid")&"_1.htm""><font color=""#000000"">"&TN(ubound(TN)-1)&"</font></a></FONT>"
end if
rs_type.close
lb=lb&"] <a href=""../info/"&rs("id")&".htm"">"&rs("title")&"</a></td>"
lb=lb&"<td width=""13%"" align=""center"">"&year(rs("date"))&"-"&month(rs("date"))&"-"&day(rs("date"))&"</td>"
lb=lb&"<td width=""10%"" align=""center"">"&rs("hits")&"</td></tr>"
lb=lb&"<tr><td width=""100%"" height=""1"" bgcolor=""#CCCCCC"" colspan=""3""></td></tr>"
if h>=MaxPerPage then exit do
rs.movenext
loop
end if
rs.close
set rs=nothing
conn.close
set conn=nothing
'#########读取页次
lb=lb&"<table border=""0"" width=""100%"" cellspacing=""0"" cellpadding=""0""><tr><td width=""15%"" nowrap>页次：<b>"¤tPage&"</b>/<b>"&mpage&"</b> 每页<b>"&MaxPerPage&"</b> 文章数<b>"&allshu&"</b></td><td width=""65%"" nowrap><p align=""center"">"
pageno=currentPage
if cint(pageno)>1 then
lb=lb&"<a href=../info/"&tid&"_1.htm title=""最前页"">"
end if
lb=lb&"<font face=""Webdings"">9</font></a> "
if cint(pageno)>1 then
lb=lb&"<a href=../info/"&tid&"_"&pageno-1&".htm title=""上一页"">"
end if
lb=lb&"<font face=""Webdings"">7</font></a>"
pp=cint(pageno)-2
if pp<1 then
pp=1
end if
for pno=pp to mpage
p=p+1
if pno*1=cint(pageno)*1 then
lb=lb&" <font color=""#FF0000"">["&pno&"]</font>"
else
lb=lb&" <a href=../info/"&tid&"_"&pno&".htm>["&pno&"]</a>"
end if
if p>=5 then exit for
next
lb=lb&" "
if cint(pageno)< mpage then
lb=lb&"<a href=../info/"&tid&"_"&pageno+1&".htm title=""下一页"">"
end if
lb=lb&"<font face=""Webdings"">8</font></a> "
if cint(pageno)< mpage then
lb=lb&"<a href=../info/"&tid&"_"&mpage&".htm title=""最后页"">"
end if
lb=lb&"<font face=""Webdings"">:</font></a></p></td><td width=""18%"" nowrap><table cellpadding=""0"" cellspacing=""0"">"
lb=lb&"<form onsubmit=""window.location=this.KKK2.options[this.KKK2.selectedIndex].value; return false;"">"
lb=lb&"<tr><td nowrap>到<select name=""select"" onchange=""javascript:window.location.href=this.options[this.selectedIndex].value"">"
for i=1 to mpage
selected=""
if currentpage=i then
selected=" selected"
end if
lb=lb&"<option value=../info/"&tid&"_"&i&".htm"&selected&">"&i&"</option>"
next
lb=lb&"</select>页</td></td></tr></form></table></td></tr></table>"
'################ 读取完成 ################
pencat=replace(pencat,"T_TITLE",thistitle)
pencat=replace(pencat,"T_NAME",tname)
pencat=replace(pencat,"TXlist",txlist)
pencat=replace(pencat,"TXtop",Txtop)
pencat=replace(pencat,"T_LB",lb)
pencat=replace(pencat,"T_TXT",typetxt)
pencat=replace(pencat,"T_TYPE",thistype)
Set fso = Server.CreateObject("Scripting.FileSystemObject")
Set fout = fso.CreateTextFile(server.mappath("../info/"&tid&"_"¤tPage&".htm"))
fout.Write pencat
fout.close
'************** 生成HTML页 结束 ***************
|
|
Cookie的构成
|
Cookies最初设计时，是为了CGI编程。但是，我们也可以使用Javascript脚本来操纵cookies。在本文里，我们将演示如何使用Javascript脚本来操纵cookies。(如果有需求，我可能会在以后的文章里介绍如何使用Perl进行cookie管理。但是如果实在等不得，那么我现在就教你一手：仔细看看CGI.pm。在这个CGI包里有一个cookie()函数，可以用它建立cookie。但是，还是让我们先来介绍cookies的本质。
在Javascript脚本里，一个cookie 实际就是一个字符串属性。当你读取cookie的值时，就得到一个字符串，里面当前WEB页使用的所有cookies的名称和值。每个cookie除了name名称和value值这两个属性以外，还有四个属性。这些属性是： expires过期时间、 path路径、 domain域、以及 secure安全。
Expires – 过期时间。指定cookie的生命期。具体是值是过期日期。如果想让cookie的存在期限超过当前浏览器会话时间，就必须使用这个属性。当过了到期日期时，浏览器就可以删除cookie文件，没有任何影响。
Path – 路径。指定与cookie关联的WEB页。值可以是一个目录，或者是一个路径。如果/head/index.html 建立了一个cookie，那么在/head/目录里的所有页面，以及该目录下面任何子目录里的页面都可以访问这个cookie。这就是说，在/head/stories/articles 里的任何页面都可以访问/head/index.html建立的cookie。但是，如果/zdnn/ 需要访问/head/index.html设置的cookes，该怎么办？这时，我们要把cookies的path属性设置成“/”。在指定路径的时候，凡是来自同一服务器，URL里有相同路径的所有WEB页面都可以共享cookies。现在看另一个例子：如果想让 /head/filters/ 和/head/stories/共享cookies，就要把path设成“/head”。
Domain – 域。指定关联的WEB服务器或域。值是域名，比如goaler.com。这是对path路径属性的一个延伸。如果我们想让dev.mycompany.com 能够访问bbs.mycompany.com设置的cookies，该怎么办? 我们可以把domain属性设置成“mycompany.com”，并把path属性设置成“/”。FYI：不能把cookies域属性设置成与设置它的服务器的所在域不同的值。
Secure – 安全。指定cookie的值通过网络如何在用户和WEB服务器之间传递。这个属性的值或者是“secure”，或者为空。缺省情况下，该属性为空，也就是使用不安全的HTTP连接传递数据。如果一个 cookie 标记为secure，那么，它与WEB服务器之间就通过HTTPS或者其它安全协议传递数据。不过，设置了secure属性不代表其他人不能看到你机器本地保存的cookie。换句话说，把cookie设置为secure，只保证cookie与WEB服务器之间的数据传输过程加密，而保存在本地的cookie文件并不加密。如果想让本地cookie也加密，得自己加密数据。 |
|
用XML+FSO+JS实现服务器端文件的选择
|
首先在服务器端先创建一个程序可以生成XML文件，以返回客户端，（getfolder.asp）
<%
response.write "<?xml version=""1.0"" encoding=""GB2312""?>"&chr(13)
response.write "<mediafile>"&chr(13)
folders=request("folder")
if folders="/" then
folders=""
end if
dim count
count=0
folders=replace(folders,"..","")
basefolder="../media/"'基准的文件夹路径
newfolder=basefolder&folders
Set fso =server.CreateObject("Scripting.FileSystemObject")
set f=fso.getfolder(server.mappath(newfolder))
set sf=f.subfolders
for each fd in sf'返回指定路径下面的文件夹列表
response.write "<file>"&chr(13)
response.write "<ftype>folder</ftype>"&chr(13)
response.write "<fname>"&fd.name&"</fname>"&chr(13)
response.write "</file>"&chr(13)
count=count+1
next
set sf=nothing
set ff=f.Files
for each fi in ff
fname=fi.name
if instr("asf,wma,wmv",lcase(mid(fname,instrrev(fname,".")+1)))>0 then'设定允许返回的文件类型，防止源码泄露
response.write "<file>"&chr(13)
response.write "<ftype>file</ftype>"&chr(13)
response.write "<fname>"&fname&"</fname>"&chr(13)
response.write "</file>"&chr(13)
count=count+1
end if
next
'如果该目录下没有文件，就发一个空元素
if count=0 then
response.write "<file>"&chr(13)
response.write "<ftype>empty</ftype>"&chr(13)
response.write "<fname>0</fname>"&chr(13)
response.write "</file>"&chr(13)
end if
response.write "</mediafile>"
set ff=nothing
set f=nothing
set fso=nothing
%>
下面就是客户端的JS的功夫了(selectfile.asp)
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
<HTML>
<HEAD>
<TITLE> 选择视频文件 </TITLE>
<style>
td{font-size:9pt}
select{width:210}
.s2{width:250}
</style>
<SCRIPT LANGUAGE="JavaScript">
<!--
/*written by Linzhang Chen ,2003-4-20
转载请注明出处和保留此版权信息 */
//预装载图片
var imgback = new Image();
imgback.src = "images/arrow.gif";
var imgbackgray = new Image();
imgbackgray.src = "images/grayarrow.gif";
var imgfolder = new Image();
imgfolder.src = "images/folder.gif";
var imggrayfolder = new Image();
imggrayfolder.src = "images/grayfolder.gif";
//历史记录数组栈
var arrhistory=new Array();
var hisi=0;
//用来确定要返回文件名
function check()
{
if (document.all.filename.value=="")
{
alert("请先选择文件");
return false;
}
else
{
window.returnValue =document.f1.folder.value+document.all.filename.value;
window.close();
}
}
//取得XML文件的内容
function getuserlist(url)
{ var oXMLDoc = new ActiveXObject('MSXML');
oXMLDoc.url = url;
var ooRoot=oXMLDoc.root;
return ooRoot;
}
//当选中一个文件时，把这个值返回给文本框
function addfile(txt)
{
document.all.filename.value=txt;
}
var first=1;//定义一个全局变量
function userlist(folders,ti)//列出所选框
{document.f1.folder.value=folders;
filebox.document.body.innerHTML="正在加载文件，请稍侯...";
var strshow="";
var timeoutid=null;
var newfolder="";
var arrfolder=new Array();
var arrff=new Array();
var blankstr="";
var oItem;
//确定历史状态
hisi+=ti;
arrhistory[hisi]=folders;
if (hisi==0)
{
arrow.innerHTML="<img src=\"images/grayarrow.gif\">";
}
else
{
arrow.innerHTML="<img src=\"images/arrow.gif\" border=0 style=\"cursor:hand\" onclick=\"userlist('"+arrhistory[hisi-1]+"',-1)\" onmouseover=\"this.src='images/arrow_over.gif'\" onmouseout=\"this.src='images/arrow.gif'\">";
}
//确定当前的文件夹
if (document.f1.folder.value=="")
{
folderid.innerHTML="<img src=\"images/grayfolder.gif\">"
}
else
{newsfolder=checkfolder(document.f1.folder.value)
folderid.innerHTML="<img src=\"images/folder.gif\" border=0 style=\"cursor:hand\" onclick=\"userlist('"+newsfolder+"',1)\" onmouseover=\"this.src='images/folder_over.gif'\" onmouseout=\"this.src='images/folder.gif'\">"
}
//给下拉框赋值
document.all.select.options.length=0;
newfolder=folders;
folderstr=""
var _obj=document.all.select;
var _o=document.createElement("Option");
_o.text="选择文件夹";
_o.value="";
_obj.add(_o);
if (newfolder!="")
{arrfolder=newfolder.split("/")
for(var i=0;i<arrfolder.length-1;i++)
{blankstr+=" ";
folderstr+=arrfolder[i]+"/";
_o=document.createElement("Option");
_o.text=blankstr+arrfolder[i];
_o.value=folderstr;
_obj.add(_o);
}
}
document.all.select.options[document.all.select.options.length-1].selected=true;
url="getfolder.asp.gl?folder="+folders;
oRoot=getuserlist(url)
strshow="<table class=file cellspacing=0 cellpadding=0>";
len=oRoot.children.length;
if (len==1)
{oItem = oRoot.children.item(0);
if(oItem.children.item(0).text=="empty")
strshow="没有文件和文件夹了";
else
{
if(oItem.children.item(0).text=="folder")
{
strshow+="<tr><td><A href=\"javascript:parent.userlist('"+folders+oItem.children.item(1).text+"/"+"',1)\"><img src=\"images/mediafolder.gif\" border=0 >"+oItem.children.item(1).text+"</A></td></tr>";
}
else
{
strshow+="<tr><td><a href=\"javascript:parent.addfile('"+oItem.children.item(1).text+"')\" ><img src=\"images/mediafile.gif\" border=0>"+oItem.children.item(1).text+"</A></td></tr>";
}
}
strshow+="</table>"
}
else{
//数据入栈
for(i=0;i<len;i++)
{ oItem = oRoot.children.item(i);
if(oItem.children.item(0).text=="folder")
{
arrff[i]="<A href=\"javascript:parent.userlist('"+folders+oItem.children.item(1).text+"/"+"',1)\"><img src=\"images/mediafolder.gif\" border=0>"+oItem.children.item(1).text+"</A>";
}
else
{
arrff[i]="<A href=\"javascript:parent.addfile('"+oItem.children.item(1).text+"')\"><img src=\"images/mediafile.gif\" border=0 height=12>"+oItem.children.item(1).text+"</A>";
}
}
//取得要输出的列数
if (len<=6)
{x=1;
y=6;}
else
{x=len/6;
y=6;}
for(var i=0;i<y;i++)
{strshow+="<tr>"
for(var j=0;j<x;j++)
{ponits=j*y+i;
if (ponits>=len)
{
strshow+="<td> </td>";
}
else
{
strshow+="<td>"+arrff[ponits]+"</td>";
}
}
strshow+="</tr>"
}
strshow+="</table>"
}
filebox.document.body.innerHTML=strshow;
}
//-->
</SCRIPT>
<script LANGUAGE="vbscript">
function checkfolder(folderstr)
if (folderstr="" or instr(folderstr,"/")=instrrev(folderstr,"/")) then
checkfolder=""
else
nfolder=left(folderstr,len(folderstr)-1)
checkfolder=left(nfolder,instrrev(nfolder,"/"))
end if
end function
</script>
</HEAD>
<BODY style="margin:0" bgColor=menu onload="javascript:userlist('',0)">
<table width="443" border="0" cellspacing="0">
<tr>
<td height="36"><table width="409" border="0">
<tr>
<td width="73" align="right">查找范围(<u>I</u>):</td>
<td width="214"><select name="select" id="select" size="1" onchange="javascript:userlist(this.value,1);">
</select></td>
<td width="22" valign="baseline" id="arrow" align=right></td>
<td width="20" valign="middle" id="folderid"></td>
<td width="20" align="left"><img src="images/md.gif" width="16" height="15"></td>
<td width="28" align="left"><img src="images/viewtype.gif" width="23" height="14"></td>
</tr>
</table></td>
</tr>
<tr>
<td height="120"><table width="100%" height="100%" border="0">
<tr>
<td width="9"> </td>
<td >
<iframe src="blank.htm" width=415 height=120 id="filebox"></iframe></td>
<td width="13"> </td>
</tr>
</table></td>
</tr>
<tr>
<td height="60"><table width="100%" border="0">
<FORM METHOD=POST ACTION="" name="f1">
<input type="hidden" name="folder" value="">
<tr>
<td width="85" align="right">文件名(<u>N</u>): </td>
<td width="254"><input type="text" id="filename" size="34"></td>
<td><button onclick="javascript:return check()"> 打开(<u>O</U>)</button></td>
</tr>
</FORM>
<tr>
<td align="right">文件类型(<u>T</u>):</td>
<td><select name="select2" class=s2>
<option>流媒体文件(*.asf,*.wmv,*.wma)</option>
</select></td>
<td><input type="button" name="Submit" value=" 取消 " onclick="window.close();"></td>
</tr>
</table></td>
</tr>
</table>
</BODY>
</HTML>
里面还有一个小文件blank.htm用来定义文件和文件夹显示的样式
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
<HTML>
<HEAD>
<TITLE> New Document </TITLE>
<style>
td{font-size:9pt}
body{font-size:9pt}
.file A{COLOR: #000000; TEXT-DECORATION: none;font-size:9pt}
.file A:visited{COLOR: #000000; TEXT-DECORATION: none;font-size:9pt}
.file A:hover {COLOR: #000000; TEXT-DECORATION: none;font-size:9pt}
</style>
</HEAD>
<BODY style="margin: 0pt">
</BODY>
</HTML>
调用的时候用以下函数，就可以实现以假乱真的服务器端选择文件的效果
function selectfile()
{
var arr = showModalDialog("selectfile.asp?temp="+Math.random(), "", "dialogWidth:453px; dialogHeight:252px; status:0;help:1");
if (arr != null)
{
return arr
}
}
该函数最后返回的是选中的文件名,函数里面所使用的几张图片大家就自已从文件选择框上抓了：） |
|
查看服务器Application/Session变量工具
|
<%@LANGUAGE="javascript" CODEPAGE="936"%>
<%
Response.Expires = 0;
Response.Buffer = true;
var tPageStartTime = new Date();
%>
<html>
<head>
<title>网站-Application变量-Session变量</title>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312">
<STYLE type=text/css>
body,td {FONT-SIZE: 10pt; FONT-FAMILY: "Arial", "Helvetica", "sans-serif" }
.Table1 { BORDER-RIGHT: #FF9900 1px solid; BORDER-TOP: #FF9900 1px solid; FONT-SIZE: 9pt; BORDER-LEFT: #FF9900 1px solid; BORDER-BOTTOM: #FF9900 1px solid }
.Table2 { BACKGROUND-COLOR: #FF9900 }
.TR1 { BACKGROUND-color:#FF9955 }
.TD1 { BORDER-RIGHT: #FEDFB3 1px solid; BORDER-TOP: #FEDFB3 1px solid; BORDER-LEFT: #FEDFB3 1px solid; color:#ff9900; BORDER-BOTTOM: #FEDFB3 1px solid; BACKGROUND-COLOR: #FEDFB3}
.TD2 {BACKGROUND-COLOR: #FEEED6;padding:7px;}
</STYLE>
<table width="750" border="0" cellpadding="3" cellspacing="1" class="Table1">
<tr>
<td class="TR1">
<table width="100%" border="0" cellspacing="0" cellpadding="0">
<tr>
<td><font color="#FFFFFF" face="Verdana, Arial, Helvetica, sans-serif"> <strong>服务器Application变量 [共 <%=Application.Contents.Count%> 个]
<script>showTools();</script></strong></font></td>
<td align="right"> </td>
</tr>
</table></td>
</tr>
<tr>
<td>
<table width="100%" border="0" cellpadding="3" cellspacing="1" class="Table2">
<tr>
<td width="35%" class="TD1"> 变量</td>
<td width="65%" class="TD1"> 值</td>
</tr>
<%
var iCount = 0;
var sVarType = "";
var oApplication = new Enumerator(Application.Contents);
var oApp;
for(;!oApplication.atEnd();oApplication.moveNext()){
oApp = oApplication.item();
sVarType = typeof(Application.Contents(oApp));
++iCount;
%>
<tr>
<td align="left" valign="middle" class="TD2"><b><%=oApp%></b><br><i disabled>[<%if(sVarType=="unknown") {Response.Write("Array");}else{Response.Write(sVarType);}%>]</i></td>
<td valign="middle" class="TD2">
<%
try{
if(sVarType=="unknown"){
var oTmp = new VBArray(Application.Contents(oApp));
Response.Write(Server.HTMLEncode(oTmp.toArray()));
}else Response.Write(Server.HTMLEncode(Application.Contents(oApp)));
}catch(e){
Response.Write("<i disabled>[Unknow]</i>");
}
%>
</td>
</tr>
<%
}
if(!iCount){
%>
<tr>
<td align="left" valign="middle" class="TD2" colspan="2">没有Application变量</td>
</tr>
<%
}
%>
</table></td>
</tr>
<tr>
<td height="5" class="TR1" colspan="2"></td>
</tr>
</table>
<br>
<table width="750" border="0" cellpadding="3" cellspacing="1" class="Table1">
<tr>
<td class="TR1">
<table width="100%" border="0" cellspacing="0" cellpadding="0">
<tr>
<td><font color="#FFFFFF" face="Verdana, Arial, Helvetica, sans-serif"> <strong>服务器Session变量 [共 <%=Session.Contents.Count%> 个]
<script>showTools();</script></strong></font></td>
<td align="right">当前会话编号: <%=Session.SessionID%> </td>
</tr>
</table></td>
</tr>
<tr>
<td>
<table width="100%" border="0" cellpadding="3" cellspacing="1" class="Table2">
<tr>
<td width="30%" class="TD1"> 变量</td>
<td width="70%" class="TD1"> 值</td>
</tr>
<%
var iCount = 0;
var sVarType = "";
var oSession = new Enumerator(Session.Contents);
var oSes;
for(;!oSession.atEnd();oSession.moveNext()){
oSes = oSession.item();
sVarType = typeof(Session.Contents(oSes));
++iCount;
%>
<tr>
<td align="left" valign="middle" class="TD2"><b><%=oSes%></b><br><i disabled>[<%if(sVarType=="unknown") {Response.Write("Array");}else{Response.Write(sVarType);}%>]</i></td>
<td valign="middle" class="TD2">
<%
try{
if(sVarType=="unknown"){
var oTmp = new VBArray(Session.Contents(oSes));
Response.Write(Server.HTMLEncode(oTmp.toArray()));
}else Response.Write(Server.HTMLEncode(Session.Contents(oSes)));
}catch(e){ Response.Write("<i disabled>[Unknow]</i>");
}
%>
</td>
</tr>
<%
}
if(!iCount){
%>
<tr>
<td align="left" valign="middle" class="TD2" colspan="2">没有Session变量</td>
</tr>
<%
}
%>
</table></td>
</tr>
<tr>
<td height="5" class="TR1" colspan="2"></td>
</tr>
</table>
<% tPageEndTime = new Date(); %>
<center> <%="<br><br>页面执行时间：约 <font color='#990000'><b>"+((tPageEndTime-tPageStartTime))+"</b></font> 毫秒"%></center>
</body>
</html> |
|
用正则解析图片地址,并利用XMLHTTP组件将其保存
|
现在基于WEB页的HTML的编辑器在新闻系统，文章系统中用得越来越广，一个网页一粘就可以保持原来的样式，同时图片也可以在这个页中保持。但是在使用过程中，如果所粘贴页中的图片被删除，就会在自己的页面上留下一个大大的“X”，影响美观。以前只好把这个图片保存下来，再重新上传到服务器上，这样实在麻烦。能不能让服务器自动去下载图片保存在服务器并且替换页面上的链接？答案是肯定的。
要实现这个功能需要经过三个步骤：
一，取得原页中的图片的地址。方法很多，可以用分割字符串，也可以用正则匹配。实践证明用正则匹配最为简单。经过分析图片的地址都保存在<img>标签中。我们可以先取得所有这个标签。过程如下：
Set objRegExp = New Regexp'设置配置对象
objRegExp.IgnoreCase = True’忽略大小写
objRegExp.Global = True’设置为全文搜索
objRegExp.Pattern = "<img.+?>"'为了确保能准确地取出图片地址所以分为两层配置：首先找到里面的<img>标签，然后再取出里面的图片地址后面的getimgs函数就是实现后一个功能的。
strs=trim(str)
Set Matches =objRegExp.Execute(strs)’开始执行配置
For Each Match in Matches
RetStr = RetStr &getimgs( Match.Value )’执行第二轮的匹配
Next
所有的图片在里面都是这样的src="http://图片的地址"，所以可以这样来取得确切的图片地址：
function getimgs(str)
getimgs=""
Set objRegExp1 = New Regexp
objRegExp1.IgnoreCase = True
objRegExp1.Global = True
objRegExp1.Pattern = "http://.+?"""’取出里面的地址
set mm=objRegExp1.Execute(str)
For Each Match1 in mm
getimgs=getimgs&"||"&left(Match1.Value,len(Match1.Value)-1)’把里面的地址串起来备用
next
end function
取得了所有的图片的地址，我们就可以进行第二步的操作了。
二，下载图片并保存在服务器上。这个又可以分为两个步骤：一个是取得图片的内容，另一个是保存在服务器上。取得图片的内容是通过下面的函数来实现的：
function getHTTPPage(url)
on error resume next
dim http
set http=server.createobject("MSXML2.XMLHTTP")‘使用xmlhttp的方法来获得图片的内容
Http.open "GET",url,false
Http.send()
if Http.readystate<>4 then
exit function
end if
getHTTPPage=Http.responseBody
set http=nothing
if err.number<>0 then err.Clear
end function
取得了图片的内容要保存，给人一种感觉是用FSO来作就可以了，但实际上不行，这样保存程序就会出错，因为FSO不支持流式的文件，所以我们要调用另一个对象：ADO.STREM。具体的过程如下：
function saveimage(from,tofile)
dim geturl,objStream,imgs
geturl=trim(from)
imgs=gethttppage(geturl)'取得图片的具休内容的过程
Set objStream = Server.CreateObject("ADODB.Stream")'建立ADODB.Stream对象，必须要ADO 2.5以上版本
objStream.Type =1'以二进制模式打开
objStream.Open
objstream.write imgs'将字符串内容写入缓冲
objstream.SaveToFile server.mappath(tofile),2'-将缓冲的内容写入文件
objstream.Close()'关闭对象
set objstream=nothing
end function
所以只要用一个循环来把刚才取得的地址中的图片全部保存下来，具体过程如下：
arrimg=split(retstr,"||")'分割字串，取得里面地址列表
allimg=""
newimg=""
for i=1 to ubound(arrimg)
if arrimg(i)<>"" and instr(allimg,arrimg(i))<1 then'看这个图片是否已经下载过
fname=baseurl&cstr(i&mid(arrimg(i),instrrev(arrimg(i),".")))
saveimage(arrimg(i),fname)‘保存地址的函数，过程见上面
allimg=allimg&"||"&arrimg(i)'把保存下来的图片的地址串回起来，以确定要替换的地址
newimg=newimg&"||"&fname'把本地的地址串回起来
end if
next
第三步就是替换原来的地址了。具体的过程就是下面了：
arrnew=split(newimg,"||")'取得原来的图片地址列表
arrall=split(allimg,"||")'取得已经保存下来的图片的地址列表
for i=1 to ubound(arrnew)'执行循环替换原来的地址
strs=replace(strs,arrall(i),arrnew(i))
next
cctv=strs
讲到这里，这个函数的基本过程就是这样了，当然可以对它进行改造就可以实现更多的功能，如：加上图片大小的限制，加上对本地机上的图片下载的限制，以免造成重复下载图片。同时也应该看到这个函数的不足之处是只能处理静态的图片文件，不能适用程序生成的图片。 |
|
论坛帖子附件的防盗链实现
|
作者：DLL
方法一：
<%
'******************************
'Write By: DLL
'NetBuilder 出品
'文件名使用URL参数/表单项传递,项名为FileName,对GIF和JPG直接输出图片流,其他文件则一律弹出下载提示框
'******************************
On Error Resume Next
Response.Buffer = True
Response.Clear
Const HidDir = "../XBB2003DFSDADA/" '根据你的文件所在目录修改
SUB UseStream(FileName,FileNameString)
Dim FileStream,File,FileContentType,IsAttachment
Set FileStream = Server.CreateObject("ADODB.Stream")
FileStream.Open
FileStream.Type = 1
File = server.MapPath(FileName)
FileStream.LoadFromFile(File)
FileContentType = GetContentType(FileName)
If FileContentType <> "image/gif" And FileContentType <> "image/jpeg" Then
IsAttachment = "attachment; "
Else
IsAttachment = ""
End If
Response.AddHeader "Content-Disposition", IsAttachment & "filename=" & FileNameString
Response.AddHeader "Content-Length", FileStream.Size
Response.Charset = "UTF-8"
Response.ContentType = FileContentType
Response.BinaryWrite FileStream.Read
Response.Flush
FileStream.Close
Set FileStream = Nothing
End SUB
Function GetFilePath(FileName,HiddenDir) '限制盗链的函数,当来源地址中的域名和当前文件地址的域名不同时则输出自定义错误图片NoImg.gif,您也可以设置为用Session限制
Dim Server_v1,Server_v2
Server_v1 = Cstr(Request.ServerVariables("HTTP_REFERER"))
Server_v2 = Cstr(Request.ServerVariables("SERVER_NAME"))
’If Server_v1<>"" And Mid(Server_v1,8,Len(Server_v2)) = Server_v2 Then
GetFilePath = HiddenDir & FileName
’Else
’GetFilePath = "NoImg.gif"
’End If
End Function
Function GetContentType(FlName)
Select Case lcase(Right(flName, 4))
Case ".asf"
GetContentType = "video/x-ms-asf"
Case ".avi"
GetContentType = "video/avi"
Case ".doc"
GetContentType = "application/msword"
Case ".zip"
GetContentType = "application/zip"
Case ".xls"
GetContentType = "application/vnd.ms-excel"
Case ".gif"
GetContentType = "image/gif"
Case ".jpg", "jpeg"
GetContentType = "image/jpeg"
Case ".wav"
GetContentType = "audio/wav"
Case ".mp3"
GetContentType = "audio/mpeg3"
Case ".mpg", "mpeg"
GetContentType = "video/mpeg"
Case ".rtf"
GetContentType = "application/rtf"
Case ".htm", "html"
GetContentType = "text/html"
Case ".txt"
GetContentType = "text/plain"
Case Else
GetContentType = "application/octet-stream"
End Select
End Function
Dim FileName,FilePath
FileName = Trim(Request("FileName"))
FilePath = GetFilePath(FileName,HidDir)
If Lcase(Right(FilePath, 4)) = ".gif" Then '如果是GIF文件则可直接用Server.Execute输出它的二进制流.
Response.AddHeader "Content-Disposition", "filename=" & FileName
Response.AddHeader "Content-Length", FileStream.Size
Response.Charset = "UTF-8"
Response.ContentType = GetContentType(FileName)
Server.Execute(FilePath)
If err.Number <> 0 Then
err.Clear
Server.Execute("NoImg2.gif")
Response.End()
End If
Else '如果不是GIF图象则使用ADODB.STREAM对象输出其二进制流
UseStream FilePath,FileName
If Err.Number <> 0 Then
Err.Clear
Server.Execute("NoImg2.gif")
End If
End If
如果程序出错则输出自定义错误图片NoImg2.gif
%>
方法二：
<%
From_url = Cstr(Request.ServerVariables("HTTP_REFERER"))
Serv_url = Cstr(Request.ServerVariables("SERVER_NAME"))
if mid(From_url,8,len(Serv_url)) <> Serv_url then
response.write "非法链接！" '防止盗链
response.end
end if
if Request.Cookies("Logined")="" then
response.redirect "/login.asp" '需要登陆！
end if
Function GetFileName(longname)'/folder1/folder2/file.asp=>file.asp
while instr(longname,"/")
longname = right(longname,len(longname)-1)
wend
GetFileName = longname
End Function
Dim Stream
Dim Contents
Dim FileName
Dim TrueFileName
Dim FileExt
Const adTypeBinary = 1
FileName = Request.QueryString("FileName")
if FileName = "" Then
Response.Write "无效文件名！"
Response.End
End if
FileExt = Mid(FileName, InStrRev(FileName, ".") + 1)
Select Case UCase(FileExt)
Case "ASP", "ASA", "ASPX", "ASAX", "MDB"
Response.Write "非法操作！"
Response.End
End Select
Response.Clear
if lcase(right(FileName,3))="gif" or lcase(right(FileName,3))="jpg" or lcase(right(FileName,3))="png" then
Response.ContentType = "image/*" '对图像文件不出现下载对话框
else
Response.ContentType = "application/ms-download"
end if
Response.AddHeader "content-disposition", "attachment; filename=" & GetFileName(Request.QueryString("FileName"))
Set Stream = server.CreateObject("ADODB.Stream")
Stream.Type = adTypeBinary
Stream.Open
if lcase(right(FileName,3))="pdf" then '设置pdf类型文件目录
TrueFileName = "/the_pdf_file_s/"&FileName
end if
if lcase(right(FileName,3))="doc" then '设置DOC类型文件目录
TrueFileName = "/my_D_O_C_file/"&FileName
end if
if lcase(right(FileName,3))="gif" or lcase(right(FileName,3))="jpg" or lcase(right(FileName,3))="png" then
TrueFileName = "/all_images_/"&FileName '设置图像文件目录
end if
Stream.LoadFromFile Server.MapPath(TrueFileName)
While Not Stream.EOS
Response.BinaryWrite Stream.Read(1024 * 64)
Wend
Stream.Close
Set Stream = Nothing
Response.Flush
Response.End
%>
|
|
|
