[转]分享我的常用函数库

最新推荐文章于 2021-06-02 21:43:42 发布

lovinglgz

最新推荐文章于 2021-06-02 21:43:42 发布

阅读量2.5k

点赞数

分类专栏： web制作文章标签： function dreamweaver url class server hex

本文链接：https://blog.csdn.net/lovinglgz/article/details/545759

版权

web制作专栏收录该内容

10 篇文章 0 订阅

订阅专栏

<%
function Sqlstr(data)
	sqlstr="'" & replace(data,"'","''") & "'"
end function

'在当前位置设置断点，如果出错则给出错误提示并停止运行，否则提示没错，继续运行

sub Chkerr(place)
	if is_debug = false then exit sub
	if err then
		Response.Write "错误发生在:"&place&"<br />错误描述:"&err.description
		response.End()
	else
		Response.Write "<br />在[<font color=""red"">"&place&"</font>]没有发生错误！"
	end if
end sub

'当前位置输出某个变量值

sub Chkstr(str)
	if is_debug then Response.Write str&"<br />"
end sub

'替换response.write ，偷懒的做法

sub Outputx(str)
	Response.Write str
end sub

'在当前位置停止运行，同时检查错误

sub Debug(dstr)
	if dstr="" then dstr="Debug stops here:--"
	chkerr dstr
	outputx "<br />DEBUG STOPS HERE"
	response.End()
end sub

'输出表格属性，也是一偷懒的做法

sub Table_Alt()
	response.Write(" width=""98%"" border=""1"" align=""center"" cellpadding=""0"" cellspacing=""1"" bordercolorright=""#000000"" bordercolordark=""#ffffff"" ")
end sub

'隐藏该标签，如<table ..... <% Hide_This % > >

sub Hide_This()
	outputx " style=""display:none;"" "
end sub

'禁止某个控件的点击，如<a >,<input ../>等等

sub Disable_Menu()
	response.Write " οnclick=""return false;"" "
end sub

'在当前位置显示一个图片，给出帮助信息，点击后弹出提示框

sub help(str)
	str = "-- 帮助 --     /n/n帮助信息:"&str
	response.Write "<a href=""#"" οnclick=""alert('"&str&"');return false;""><img src=""p/help.gif"" alt="""&replace(replace(str,"/n/n","/n"),"/n","<br />")&""" /></a>"
end sub

'检查输入值，如果为空，则用-替代，可用于防止保存到数据库的为空值，或某值为空时的显示不规则

function Get_Value(x)
	if isnull(x) or x="" then
		get_value = "-"
	else
		get_value = x
	end if
end function

'用CSS定义<H6>，显示系统提示信息，如需要，可提供更详细的使用说明

sub Sys_Tip(msg)
	if len(msg)>0 then response.write "<h6>"&msg&"</h6>"
end sub

'检查当前recordset是否为空

'用if isrb(rs) then 替代 if rs.bof and rs.eof then
'也是一偷懒的方法
function isRb(rs)
	if rs.bof and rs.eof then
		isrb = true
	else
		isrb = false
	end if
end function

'清理以,分割的字符串，清理其中的两个分隔符号，去掉前后的符号

function Clean_Ary(ary_name)
	if left(ary_name,1) = "," then ary_name=mid(ary_name,2,len(ary_name))
	if right(ary_name,1) = "," then ary_name=mid(ary_name,1,len(ary_name)-1)
	do while instr(ary_name,",,")<>0
		ary_name = replace(ary_name,",,",",")
	loop
	clean_ary = ary_name
end function

'去掉输入参数里的HTML标签，这是其中一个函数

Function RemoveHTML_A(strText)
    Dim nPos1
    Dim nPos2
    
    nPos1 = InStr(strText, "<") 
    Do While nPos1>0 
        nPos2 = InStr(nPos1+1, strText, ">") 
        If nPos2>0 Then 
            strText = Left(strText, nPos1 - 1) & Mid(strText, nPos2 + 1) 
        Else 
            Exit Do 
        End If 
        nPos1 = InStr(strText, "<") 
    Loop 
    
    RemoveHTML_A = strText 
End Function

'在新闻标题列表等应用中，只取一定长度的字符，若超过这个长度，则加上...

function GetTitle(title,content,length)
    If length = 0 Then length = 8
	if title = "" or isnull(title) then title = left(RemoveHTML_A(content),30)
	
    If Len(title) > length Then
        GetTitle = Left(title, length) & ".."
    Else
        GetTitle = title
    End If
end function

'关闭和释放记录集对象
sub RsClose(rst)
  if isobject(rst) then 
	rst.close
	set rst = nothing
  end if
end sub

'关闭和释放connetion对象
sub DbClose(conn)
  if isobject(conn) then 
  	conn.close
  	set conn = nothing
  end if
end sub

'这也是种关闭和释放对象的方法，在页末使用
sub EndPage(rs,conn)
	set rs = nothing
	set conn = nothing
end sub

'这是一组时间函数，是我在做取昨天的日期的时候整理的

'判断是否是闰年
Function IsLeapYear(yr)
	If ((yr Mod 4 = 0 ) And (yr Mod 100 <> 0)) Or (yr Mod 400 = 0) Then
		IsLeapYear = True
	Else
		IsLeapYear = False
	End If
End Function

function get_month_last_day(sm)
	redim months(12)
	months(1)="1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31"
	months(2)="1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28"
	if IsLeapYear(year(date())) then months(2) = months(2) &",29"
	months(3)="1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31"
	months(4)="1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30"
	months(5)="1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31"
	months(6)="1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30"
	months(7)="1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31"
	months(8)="1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31"
	months(9)="1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30"
	months(10)="1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31"
	months(11)="1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30"
	months(12)="1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31"

	get_month_last_day = mid(months(sm),len(months(sm))-1,2)

end function

'得到昨天的日期
function get_lastday(this_day)
	'outputx "今天是"&this_day&",今年的第["&datediff("d","2005-1-1",this_day)&"]天<br />"
	syear = year(this_day)
	smonth = month(this_day)
	sday = day(this_day)
	if sday = 1 then
		if smonth = 1 then	'去年
			get_lastday = cstr(cint(syear)-1)&"-12-31"
		else
			get_lastday = syear&"-"& cstr(cint(smonth)-1)&"-"&get_month_last_day(cstr(cint(smonth)-1))
		end if
	else
		get_lastday = syear&"-"&smonth&"-"&cstr(sday-1)
	end if
end function

'一组根据输入值是否为空而返回同值的函数

'检查是否为空，如是则返回"未填写"
function chk_not_input(str)
	if str="" or isnull(str) then
		chk_not_input="未填写"
	else
		chk_not_input=str
	end if
end function

'检查是否为空，返回str类型
function chk_null_str(str)
	if str="" or isnull(str) then
		chk_null_str="未填"
	else
		chk_null_str=str
	end if
end function

'检查是否为空，返回0
function chk_null_0(str)
	if isnull(str) or str="" or str="-" then
		chk_null_0="0"
	else
		chk_null_0=str
	end if
end function

'检查是否为空，为空则用X替换
function chk_null_x(str,x)
	if str="" or isnull(str) then
		chk_null_x=x
	else
		chk_null_x=str
	end if
end function

'检查是否为空，为空则用横线替换
function chk_null_line(str)
	if str="" or isnull(str) then
		chk_null_line="-"
	else
		chk_null_line=str
	end if
end function
%>

Function alert(message,gourl)
	message = replace(message,"'","/'")
	If gourl="" or gourl="-1" then
		Response.Write ("<script language=javascript>alert('" & message & "');history.go(-1)</script>")
	Else
		Response.Write ("<script language=javascript>alert('" & message & "');location='" & gourl &"'</script>")
	End If
	Response.End()
End Function

'''''''''''''''''''''''''''''''''''''''''''禁止站外提交数据'''''''''''''''''''''''''''''''''''''''''''''''''

主要用在一些权限页面（即凭借用户名密码正确登录后能访问的页）上，直接 call outofsite() 调用检查。

注意：这里就使用了上面的 alert(message,gourl) 函数。

Function outofsite()
	Dim server_v1,server_v2
	server_v1=Cstr(Request.ServerVariables("HTTP_REFERER"))
	server_v2=Cstr(Request.ServerVariables("SERVER_NAME"))
	if mid(server_v1,8,len(server_v2))<>server_v2 then
		call alert("/n注意，为确保本站点的安全性：/n● 禁止直接输入网址到达机密页面！/n● 禁止从站点外部非法向本站提交数据！/n● 请使用正确的访问途径合法登录，谢谢合作。","-1")
	end if
End Function

'''''''''''''''''''''''''''''''''''''''''''取得IP地址'''''''''''''''''''''''''''''''''''''''''''''''''

要获得IP值直接使用 call userip() 即可

Function Userip()
    Dim GetClientIP
    '如果客户端用了代理服务器，则应该用ServerVariables("HTTP_X_FORWARDED_FOR")方法
    GetClientIP = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
    If GetClientIP = "" or isnull(GetClientIP) or isempty(GetClientIP) Then
        '如果客户端没用代理，应该用Request.ServerVariables("REMOTE_ADDR")方法
        GetClientIP = Request.ServerVariables("REMOTE_ADDR")
    End If
    Userip = GetClientIP
End function

'''''''''''''''''''''''''''''''''''''''''''简易处理较长文本'''''''''''''''''''''''''''''''''''''''''''''''''

我一般是用在首页的新闻标题调用，主要是中文，所以就用个简易的。

比如提取标题只显示12个字。 call conleft(rs("n_title"),12)

function conleft(contact,i)
if len(contact)>i then  
	contact=left(contact,i)    
	conleft=contact&"..."
else
	conleft=contact
end if
end function

'''''''''''''''''''''''''''''''''''''''''''登陆验证接口函数'''''''''''''''''''''''''''''''''''''''''''''''''

接口有一定的通用性：）

先 call outofsite() 防止外部注册机提交
requestname和requestpwd 分别表示接受用户名和密码的表单对象的名称
tablename、namefield和pwdfield 分别表示数据库中存放用户信息的表、记录用户名的字段和用户密码的字段。（这里密码是MD5加密，否则请修改函数中的MD5()包含）
reurl 表示正确登录后跳转的地址

注意：这里同样使用了上面的 alert(message,gourl) 函数

有人还有就是增加了验证码，这里说明下：主要是先验证码正确，再检测用户名和密码的，所以本函数与有验证码的登录无大关系。

关于这个还有要增强的，就是每次用户名和密码不正确的记录，连上该帐号测试的IP，一起通过JMAIL发送到管理员信箱，这样管理员就能随时掌握登录的情况。

Function chk_regist(requestname,requestpwd,tablename,namefield,pwdfield,reurl)
call outofsite()
dim cn_name,cn_pwd
	cn_name=trim(request.form(""&requestname&""))
	cn_pwd=trim(request.form(""&requestpwd&""))
	if cn_name="" or cn_pwd="" then
		call alert("请将帐号或密码填写完整，谢谢合作。","-1")
		response.end()
	end if
	Set rs = Server.CreateObject ("ADODB.Recordset")
	sql = "Select * from "&tablename&" where "&namefield&"='"&cn_name&"'"
	rs.open sql,conn,1,1
	if rs.eof then
		call alert("警告，非法猜测用户名！","-1")
	else
		if rs(""&pwdfield&"")=md5(cn_pwd) then 
			session("cn_name")=rs(""&namefield&"") '这个地方的session名称可以自己修改
			response.Redirect(reurl)
		else
			call alert("请正确输入用户名和与之吻合的密码。","-1")
		end if
	end if
End Function

'''''''''''''''''''''''''''''''''''''''''''布尔切换值函数'''''''''''''''''''''''''''''''''''''''''''''''''

主要用在一些双向选择的字段类型上，比如产品的推荐和不推荐等

具体如何应用就不详说了，各位慢慢看

function pvouch(tablename,fildname,autoidname,indexid)
dim fildvalue
Set rs = Server.CreateObject ("ADODB.Recordset")
sql = "Select * from "&tablename&" where "&autoidname&"="&indexid
rs.Open sql,conn,2,3
fildvalue=rs(""&fildname&"")
if fildvalue=0 then
	fildvalue=1
else
	fildvalue=0
end if
rs(""&fildname&"")=fildvalue
rs.update
rs.close 
Set rs = Nothing
end function

缔吧-DW暨WEB技术站

Blueidea Web Team
Moderator Of Blueidea Developer forum

Function alert(message,gourl)
	message = replace(message,"'","/'")
	If gourl="" or gourl="-1" then
		Response.Write ("<script language=javascript>alert('" & message & "');history.go(-1)</script>")
	Else
		Response.Write ("<script language=javascript>alert('" & message & "');location='" & gourl &"'</script>")
	End If
	Response.End()
End Function

Function outofsite()
	Dim server_v1,server_v2
	server_v1=Cstr(Request.ServerVariables("HTTP_REFERER"))
	server_v2=Cstr(Request.ServerVariables("SERVER_NAME"))
	if mid(server_v1,8,len(server_v2))<>server_v2 then
		call alert("/n注意，为确保本站点的安全性：/n● 禁止直接输入网址到达机密页面！/n● 禁止从站点外部非法向本站提交数据！/n● 请使用正确的访问途径合法登录，谢谢合作。","-1")
	end if
End Function

'''''''''''''''''''''''''''''''''''''''''''取得IP地址'''''''''''''''''''''''''''''''''''''''''''''''''

要获得IP值直接使用 call userip() 即可

Function Userip()
    Dim GetClientIP
    '如果客户端用了代理服务器，则应该用ServerVariables("HTTP_X_FORWARDED_FOR")方法
    GetClientIP = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
    If GetClientIP = "" or isnull(GetClientIP) or isempty(GetClientIP) Then
        '如果客户端没用代理，应该用Request.ServerVariables("REMOTE_ADDR")方法
        GetClientIP = Request.ServerVariables("REMOTE_ADDR")
    End If
    Userip = GetClientIP
End function

function conleft(contact,i)
if len(contact)>i then  
	contact=left(contact,i)    
	conleft=contact&"..."
else
	conleft=contact
end if
end function

Function chk_regist(requestname,requestpwd,tablename,namefield,pwdfield,reurl)
call outofsite()
dim cn_name,cn_pwd
	cn_name=trim(request.form(""&requestname&""))
	cn_pwd=trim(request.form(""&requestpwd&""))
	if cn_name="" or cn_pwd="" then
		call alert("请将帐号或密码填写完整，谢谢合作。","-1")
		response.end()
	end if
	Set rs = Server.CreateObject ("ADODB.Recordset")
	sql = "Select * from "&tablename&" where "&namefield&"='"&cn_name&"'"
	rs.open sql,conn,1,1
	if rs.eof then
		call alert("警告，非法猜测用户名！","-1")
	else
		if rs(""&pwdfield&"")=md5(cn_pwd) then 
			session("cn_name")=rs(""&namefield&"") '这个地方的session名称可以自己修改
			response.Redirect(reurl)
		else
			call alert("请正确输入用户名和与之吻合的密码。","-1")
		end if
	end if
End Function

function pvouch(tablename,fildname,autoidname,indexid)
dim fildvalue
Set rs = Server.CreateObject ("ADODB.Recordset")
sql = "Select * from "&tablename&" where "&autoidname&"="&indexid
rs.Open sql,conn,2,3
fildvalue=rs(""&fildname&"")
if fildvalue=0 then
	fildvalue=1
else
	fildvalue=0
end if
rs(""&fildname&"")=fildvalue
rs.update
rs.close 
Set rs = Nothing
end function

缔吧-DW暨WEB技术站

Blueidea Web Team
Moderator Of Blueidea Developer forum

 '检查数据是否重复
 Function chkRecord(newValue,chkTable,chkField)
  Dim chkRecordRs,chkRecordSql,chkValue
  If Trim(newValue) = "" Then
   chkValue = false
  Else
   chkRecordSql = "Select ID From "&chkTable&" Where "&chkField&" = '"&newValue&"'"
   Set chkRecordRs = Conn.Execute( chkRecordSql )
   If chkRecordRs.Eof Or chkRecordRs.Bof Then
    chkValue = true
   Else
    chkValue = false
   End If
   Set chkRecordRs = Nothing
  End If  
  chkRecord = chkValue
 End Function

获取在cname表中与id对应的fname的值

  Function getName(id,cname,fname)	
  If IsNumeric(id) Then	
  Dim getNameRs,getNameSql
  getNameSql = "Select "&fname&" From "&cname&" Where Id="&Cint(id)
  Set getNameRs = Conn.Execute (getNameSql)
  If Not(getNameRs.Eof Or getNameRs.Bof) Then
    getName = getNameRs(fname)
  Else
    getName = ""
  End If
 Set getNameRs = Nothing
 Else
 getName = ""
 End If
End Function

凤翱翔于千仞兮，非梧不栖。
士伏处于一方兮，非主不依。
乐躬耕于陇亩兮，吾爱吾庐。
聊寄傲于琴书兮，以待天时。

[img]http://img.bbs4.tom.com/upload_img/375/200503/pic_1111395563.jpg[/img]

function checklink(str)
dim rs,truelink
if (str="http://") then
	str=""
end if
if not (str="") then
	set rs=new regexp
	rs.ignorecase=true
	rs.global=true
	rs.pattern="(http:((/w)+[.]){1,}([A-Za-z]|[0-9]{1,3})(((//[/~]*|//[/~]*)(/w)+)|[.](/w)+)*(((([?](/w)+){1}[=]*))*((/w)+){1}([/&](/w)+[/=](/w)+)*)*)"
	truelink=rs.test(str)
	if truelink=false then
		response.redirect("error.asp?err=site")
		response.end
		set rs=nothing
	end if
end if
end function

电子邮件地址检测

function checkmail(str)
dim rs,truemail
if not (str="") then
	set rs=new regexp
	rs.ignorecase=true
	rs.global=true
	rs.pattern="(/w)+[@]{1}((/w)+[.]){1,3}(/w)+"
	truemail=rs.test(str)
	if truemail=false then
		response.redirect("error.asp?err=email")
		response.end
		set rs=nothing
	end if
end if
end function

仁慈的主啊，请您宽恕我这个有罪之人吧，我又开始潜水拉~~
num2 | To be NO.1

***Lettergraph v1.1 by Ferruh Mavituna
'//NFO//
' Write Letters as images
'//ARGUMENTS//
' valx : Text (alphanumeric)
'//SAMPLE//
' Response.Write P13_Lettergraph("soul")
' >>> Need alphabet folder <<<
'******************************
'Function P13_Lettergraph(valx,folder)
' If folder = "" Then folder ="alphabet"
'******************************
Function P13_Lettergraph(valx)
Dim ix, ix2, valxarr, curletter, lmod
If valx <> "" Then
valxarr = Split(Trim(valx)," ")
For ix2 = 0 to Ubound(valxarr)
For ix = 1 to Len(valxarr(ix2))

curletter = Left(valxarr(ix2),1)
'// Turkish Character Map
If Ucase(curletter) = "&#350;" Then curletter = "s2"
If Ucase(curletter) = "&#286;" Then curletter = "g2"
If Ucase(curletter) = "i" Then curletter = "i2"
If Ucase(curletter) = "&Uuml;" Then curletter = "u2"
If Ucase(curletter) = "&Ouml;" Then curletter = "o2"

If ix2 mod 2 Then lmod = "2" Else lmod = ""

P13_Lettergraph = P13_Lettergraph & "<img src=""13mg/lt" & lmod &"/" & curletter &".gif"" alt=""" & curletter & """ />"
valxarr(ix2) = Right(valxarr(ix2),Len(valxarr(ix2))-1)
Next

If ix2 < Ubound(valxarr) Then P13_Lettergraph = P13_Lettergraph & "<img src=""13mg/lt/dot.gif"" alt=""dot"" />"

Next
End If
End Function

使用:response.write(P13_Lettergraph("123456789")) response.write("123456789")

[这消息被5do8编辑过(最后编辑时间2005-10-27 11:36:31)]

 

Function search(pSearch, pSearchStr)
Dim tempSearch, tempSearchStr, startpos, endpos
startpos = 1
Dim ctr
ctr = 0

Do While (startpos > 0)
endpos = InStr(startpos, LCase(pSearch), LCase(pSearchStr))
If endpos > 0 Then
ctr = ctr + 1
startpos = endpos + Len(pSearchStr)
Else
Exit Do
End If
Loop
search = ctr 
End Function

<%
'Add a name/value pair to a URL
Function QueryStringAdd(ByVal URL, ByVal Name, ByVal Value)
'Start with the existing URL
QueryStringAdd = URL

'Determine whether or not there's a querystring
If (InStr(URL, "?") > 0) Then
'Yes, so append the name/value pair using an ampersand
QueryStringAdd = QueryStringAdd & "&"
Else
'No, so start one off with a question mark
QueryStringAdd = QueryStringAdd & "?"
End If

'And add the URLEncoded name/value pair
QueryStringAdd = QueryStringAdd & Server.URLEncode(Name) & "=" & Server.URLEncode(Value)
End Function


'Remove a name/value pair from a URL
'Usage: AllInstances = False --> Removes the rightmost instance from the URL
' AllInstances = True --> Removes all instances from the URL
Function QueryStringRemove(ByVal URL, ByVal Name, ByVal AllInstances)
Dim PositionQueryString, PageLocation, QueryString, Substring, PositionCurrent, PositionEnd, PositionAmpersand
PositionQueryString = Instr(URL, "?")

'Only process the specified URL if it actually contains a querystring!
If (PositionQueryString > 0) Then
'Split the URL into the page location and querystring
PageLocation = Left(URL, PositionQueryString - 1)
QueryString = Mid(URL, PositionQueryString)

'Build the substring we will be searching for
Substring = Server.URLEncode(Name) & "="

'Find the last (rightmost) instance of the
'specified variable in the querystring
PositionCurrent = InStrRev(QueryString, Substring) - Len(SubString)

If (AllInstances) Then
'Only stop one we've reached the start of the querystring
PositionEnd = 0
Else
'Stop once we've removed the last instance
PositionEnd = PositionCurrent
End If

'Loop until we've reached our set end position
While ((PositionCurrent > 0) And (PositionCurrent >= PositionEnd))
'The substring is present in the URL

PositionCurrent = InStrRev(QueryString, Substring)
If (PositionCurrent > 0) Then
'If a match was found, remove it!

'Find the start of the next querystring variable
'by finding the ampersand that would preceed it
PositionAmpersand = InStr(PositionCurrent, QueryString, "&")

If (PositionAmpersand = 0) Then
'If there isn't another ampersand in the URL then it
'must be the last variable in the querystring so
'only grab the characters from the start of the string
'up until the character before the current position
'(so that any preceeding & or ? is chopped)
QueryString = Left(QueryString, PositionCurrent - 2)
PositionCurrent = Len(QueryString)
Else
'Otherwise grab characters from start of the string
'until the current position, and from after the
'position of the ampersand onwards
QueryString = Left(QueryString, PositionCurrent - 1) & Mid(QueryString, PositionAmpersand + 1)
PositionCurrent = PositionAmpersand
End If
End If
Wend

If QueryString = "?" Then
QueryString = ""
End If

'Return the processed URL
QueryStringRemove = PageLocation & QueryString
Else
QueryStringRemove = URL
End If
End Function


'TEST CODE
'---------
URL = "http://www.testserver.com/tests cript.asp"

'Test adding a variable and removing it
URL = QueryStringAdd(URL,"test","1")
Response.Write URL & "<br />"
URL = QueryStringRemove(URL,"test",False)
Response.Write URL & "<br />"

'Now add a couple of the same name with a different one in the
'middle and remove them individually but in a different order
URL = QueryStringAdd(URL,"test","2")
URL = QueryStringAdd(URL,"dummy","dummyvalue")
URL = QueryStringAdd(URL,"test","3")
Response.Write URL & "<br />"
URL = QueryStringRemove(URL,"test",False)
Response.Write URL & "<br />"
URL = QueryStringRemove(URL,"test",False)
Response.Write URL & "<br />"
URL = QueryStringRemove(URL,"dummy",False)
Response.Write URL & "<br />"

'Now do something similar but remove all
'instances of "test" in a single call
URL = QueryStringAdd(URL,"test","2")
URL = QueryStringAdd(URL,"test","2")
URL = QueryStringAdd(URL,"dummy","dummyvalue")
URL = QueryStringAdd(URL,"test","2")
URL = QueryStringAdd(URL,"test","2")
Response.Write URL & "<br />"
URL = QueryStringRemove(URL,"test",True)
Response.Write URL & "<br />"
%>

在处理get方式递交信息时好使的很!

'*******************************************************************
'replacekeyword(keytext)
'需要和库联接时才能使用
'入口参数：keytext 
'出口参数：replacekeyword
'******************************************************************
function repkeyword(keytext)
	dim rers
	dim db_kewords, db_rewords, arr_kewords, arr_rewords
	set rers = conn.execute("select * from words_key where show=1 order by list_id")
	while not rers.eof
	db_kewords = db_kewords&"|"&rers(1)
	db_rewords = db_rewords&"|"&lcase(rers(2))
	arr_kewords = split(db_kewords,"|")
	arr_rewords = split(db_rewords,"|")
	rers.movenext
	wend
	set rers = nothing
	Dim re
	Set re = new RegExp
	re.IgnoreCase = True
	re.Global = True
	for i = 1 to ubound(arr_kewords)
	re.Pattern="([^""|=|//|//|@]|^)("&arr_kewords(i)&")" 
	keytext = re.Replace(keytext," $1<a href=$2>$2</a>")
	next
	repkeyword = keytext
	set re = Nothing
end function

[生命其实就是一个过程，可悲的是它不能够重新开始，可喜的是它也不需要重新开始.]

Sub LockPage()
Dim http_reffer,server_name
http_reffer=Request.ServerVariables("HTTP_REFERER")
server_name=Request.ServerVariables("SERVER_NAME")
if CheckAgent()=False Then
if http_reffer="" or left(http_reffer,len("http://"&server_name)+1)<>"http://"&server_name&"/" Then
Response.Write("<html><body>")
Response.Write("<form action='' name=checkrefer id=checkrefer method=post>")
Response.Write("</form>")
Response.Write("<script>")
'Response.Write("alert('禁止非法访问');")
Response.Write("document.all.checkrefer.action=document.URL;")
Response.Write("document.all.checkrefer.submit();")
Response.Write("</script>")
Response.Write("</body></html>")
response.end
end If
End If
End Sub

'检查当前访问者是否是蜘蛛人
Function CheckAgent()
Dim user_agent,allow_agent
user_agent=Request.ServerVariables("HTTP_USER_AGENT")
allow_agent=split("Baiduspider,Scooter,ia_archiver,Googlebot,FAST-WebCrawler,MSNBOT,Slurp",",")
CheckAgent=False
for agenti=lbound(allow_agent) to ubound(allow_agent)
if instr(user_agent,allow_agent(agenti))>0 Then
CheckAgent=True
exit For
End If
Next
end Function

'身份证校验
Function CheckidCard(idcard)
Dim LenCard
LenCard=Len(idcard) 
'判断身份证长度
if not (LenCard = 15 Or LenCard = 18) Then 
CheckidCard= "身份证长度不是15位或18位"
exit Function
End If
 '变量声明区
dim WeightedFactor,VerifyCode,area,birthday,lastnum,Ai,i,Total,Modnum,sex,age,province,sexNum,provinceID
WeightedFactor = array(7,9,10,5,8,4,2,1,6,3,7,9,10,5,8,4,2) '为前17位各个数字对应的加权因子
VerifyCode = array(1,0,"x",9,8,7,6,5,4,3,2)  '通过模得到的校验码
area="11北京,12天津,13河北,14山西,15内蒙古,21辽宁,22吉林,23黑龙江,31上海,32江苏,33浙江,34安徽,35福建,36江西,37山东,41河南,42湖北,43湖南,44广东,45广西,46海南,50重庆,51四川,52贵州,53云南,54西藏,61陕西,62甘肃,63青海,64宁夏,65新疆,71台湾,81香港,82澳门,91国外"
'判断地区
provinceID=left(idcard,2)
  if instr(area,provinceID)=0 then
    CheckidCard= "身份证头2位错误"
    exit function
  end If
'补齐15位卡号
if LenCard= 15 then  idcard=left(idcard,6) & "19" & mid(idcard,7,9) 
'判断生日
birthday= mid(idcard,7,4)+"-"+mid(idcard,11,2)+"-"+mid(idcard,13,2)
if not  isdate(birthday) then
CheckidCard=  "生日非法"
exit function
end If
if datediff("yyyy",cdate(birthday),date())<18 then
      CheckidCard=  "你还未满18岁,不可能有身份证的"
       exit function
 end If
'判断检验码
  if len(idcard)=18 then
 lastnum=int(right(idcard,1)) 'lastnum为18位身份证最后一位
    Ai=left(idcard,17) 'Ai为除最后一位字符的字串
    For i = 0 To 16 
      Total = Total + cint(Mid(Ai,i+1,1)) * WeightedFactor(i) 'Total前17位数字与对应的加权因子积的和
    Next 
    Modnum=total mod 11 '此数为模,total除以11后的余数 
    if VerifyCode(Modnum)<>lastnum then
      CheckidCard= "最后一位校验码不对"
      exit function
    end if
  end If
'计算性别
sexNum=mid(idcard,17,1)
sex="男性"
if   (sexNum mod 2) =0 then sex="女性" 
'计算年龄
age=datediff("yyyy",cdate(birthday),date())
'计算省份 
province=mid(area,instr(area,provinceID)+2,3)
province=replace(province,",","")
CheckidCard= "恭喜,身份证通过校验<br/>" & "您为:" & sex & ",来自于:" & province & ",生日为:" & birthday
End Function

'设置页面马上过期
Sub PageNoCache()
Response.Expires = 0  
Response.expiresabsolute = Now() - 1  
Response.addHeader "pragma", "no-cache"  
Response.addHeader "cache-control", "private"  
Response.CacheControl = "no-cache" 
Response.Buffer = True 
Response.Clear
Server.ScriptTimeOut=999999999
End Sub

'把中文變成unicode
function chinese2unicode(Salon)
dim i
dim Salon_one
dim Salon_unicode
if Salon="" then Salon="无"
for i=1 to len(Salon)
Salon_one=Mid(Salon,i,1)
Salon_unicode=Salon_unicode&chr(38)
Salon_unicode=Salon_unicode&chr(35)
Salon_unicode=Salon_unicode&chr(120)
Salon_unicode=Salon_unicode& Hex(ascw(Salon_one))
Salon_unicode=Salon_unicode&chr(59)
Next
chinese2unicode=Salon_unicode
End Function

提供万网、中频、商中、新网、互联、ENOM、DIRECTI全线产品。国外PHP5G空间　500RMB／年(无限MYSQL,无限域名）　国外ASP5G空间　1500RMB／年 QQ:116610 www.gzcom.net

    <%
    dim quizClass,quizOption
    'quizClass=rs("quizLib.quizClass")
                 quizClass=rs("quizClass")
    select case quizClass
        case "radio1"
            response.Write("判断题")
        case "radio2"
            response.Write("单选题")
        case "checkbox"
            response.Write("多选题")
        case "text"
            response.Write("填空题")
    end select
    %>

www.ke8.org

阿宝 2006年到来之前就会火起来

我预测的:D

Function OracleDate( dt ) 
dt = CDate( dt ) ' just to be sure 
OracleDate = Right( "0" & Day(dt), 2 ) & "-" _ 
& UCase( MonthName(Month(dt), True) ) & "-" _ 
& Year(dt)
End Function

查找字符串的次数:

Function search(pSearch, pSearchStr)
Dim tempSearch, tempSearchStr, startpos, endpos
startpos = 1
Dim ctr
ctr = 0

Do While (startpos > 0)
endpos = InStr(startpos, LCase(pSearch), LCase(pSearchStr))
If endpos > 0 Then
ctr = ctr + 1
startpos = endpos + Len(pSearchStr)
Else
Exit Do
End If
Loop
search = ctr 
End Function

不要吝啬,大方点,我已经帖子这么几个吐血的了,怎么有人只copy不共享?寒.闪了~

'// 去调HTML标签 输出
function delhtml(strhtml)
	dim objregexp, stroutput
	set objregexp = new regexp
	objregexp.ignorecase = true
	objregexp.global = true
	objregexp.pattern = "(<[a-za-z].*?>)|(<[//][a-za-z].*?>)"
	stroutput = objregexp.replace(strhtml, "")
	stroutput = replace(stroutput, "<", "&lt;")
	stroutput = replace(stroutput, ">", "&gt;") 
	delhtml = stroutput
	set objregexp = nothing
end function

[生命其实就是一个过程，可悲的是它不能够重新开始，可喜的是它也不需要重新开始.]

'程序参数说明
'PapgeSize      定义分页每一页的记录数
'GetRS       返回经过分页的Recordset此属性只读
'GetConn      得到数据库连接
'GetSQL       得到查询语句
'程序方法说明
'ShowPage      显示分页导航条,唯一的公用方法
'===================================================================
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 Xdownpage
Private XD_PageCount,XD_Conn,XD_Rs,XD_SQL,XD_PageSize,Str_errors,int_curpage,str_URL,int_totalPage,int_totalRecord,XD_sURL

'=================================================================
'PageSize 属性
'设置每一页的分页大小
'=================================================================
Public Property Let PageSize(int_PageSize)
 If IsNumeric(Int_Pagesize) Then
  XD_PageSize=CLng(int_PageSize)
 Else
  str_error=str_error & "PageSize的参数不正确"
  ShowError()
 End If
End Property
Public Property Get PageSize
 If XD_PageSize="" or (not(IsNumeric(XD_PageSize))) Then
  PageSize=10     
 Else
  PageSize=XD_PageSize
 End If
End Property
'=================================================================
'GetRS 属性
'返回分页后的记录集
'=================================================================
Public Property Get GetRs()
 Set XD_Rs=Server.createobject("adodb.recordset")
 XD_Rs.PageSize=PageSize
 XD_Rs.Open XD_SQL,XD_Conn,1,1
 If not(XD_Rs.eof and XD_RS.BOF) Then
  If int_curpage>XD_RS.PageCount Then
   int_curpage=XD_RS.PageCount
  End If
  XD_Rs.AbsolutePage=int_curpage
 End If
 Set GetRs=XD_RS
End Property
'================================================================
'GetConn  得到数据库连接
'================================================================ 
Public Property Let GetConn(obj_Conn)
 Set XD_Conn=obj_Conn
End Property
'================================================================
'GetSQL   得到查询语句
'================================================================
Public Property Let GetSQL(str_sql)
 XD_SQL=str_sql
End Property
'==================================================================
'Class_Initialize 类的初始化
'初始化当前页的值
'================================================================== 
Private Sub Class_Initialize
 '========================
 '设定一些参数的黙认值
 '========================
 XD_PageSize=10  '设定分页的默认值为10
 '========================
 '获取当前面的值
 '========================
 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
'====================================================================
'ShowPage  创建分页导航条
'有首页、前一页、下一页、末页、还有数字导航
'====================================================================
Public Sub ShowPage()
 Dim str_tmp
 XD_sURL = GetUrl()
 int_totalRecord=XD_RS.RecordCount
 If int_totalRecord<=0 Then
  str_error=str_error & "总记录数为零，请输入数据"
  Call ShowError()
 End If
 If int_totalRecord="" then
     int_TotalPage=1
 Else
  If int_totalRecord mod PageSize =0 Then
   int_TotalPage = CLng(int_TotalRecord / XD_PageSize * -1)*-1
  Else
   int_TotalPage = CLng(int_TotalRecord / XD_PageSize * -1)*-1+1
  End If
 End If
 
 If Int_curpage>int_Totalpage Then
  int_curpage=int_TotalPage
 End If
 
 '==================================================================
 '显示分页信息，各个模块根据自己要求更改显求位置
 '==================================================================
 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="""&XD_sURL & "1" & """>" & Btn_First&"</a> <a href=""" & XD_sURL & 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=""" & XD_sURL & CStr(int_nextpage) & """>" & Btn_Next&"</a> <a href="""& XD_sURL & CStr(int_totalpage) & """>" &  Btn_Last&"</a>"
 End If
 ShowNextLast=str_tmp
End Function
'====================================================================
'ShowNumBtn  数字导航
'====================================================================
Private Function showNumBtn()
 Dim i,str_tmp
 For i=1 to int_totalpage
  str_tmp=str_tmp & "[<a href=""" & XD_sURL & CStr(i) & """>"&i&"</a>] "
 Next
 showNumBtn=str_tmp
End Function
'====================================================================
'ShowPageInfo  分页信息
'更据要求自行修改
'====================================================================
Private Function ShowPageInfo()
 Dim str_tmp
 str_tmp="页次:"&int_curpage&"/"&int_totalpage&"页 共"&int_totalrecord&"条记录 "&XD_PageSize&"条/每页"
 ShowPageInfo=str_tmp
End Function
'==================================================================
'GetURL  得到当前的URL
'更据URL参数不同，获取不同的结果
'==================================================================
Private Function GetURL()
 Dim strurl,str_url,i,j,search_str,result_url
 search_str="page="
 strurl=Request.ServerVariables("URL")
 Strurl=split(strurl,"/")
 i=UBound(strurl,1)
 str_url=strurl(i)'得到当前页文件名
 str_params=Trim(Request.ServerVariables("QUERY_STRING"))
 If str_params="" Then
  result_url=str_url & "?page="
 Else
  If InstrRev(str_params,search_str)=0 Then
   result_url=str_url & "?" & str_params &"&page="
  Else
   j=InstrRev(str_params,search_str)-2
   If j=-1 Then
    result_url=str_url & "?page="
   Else
    str_params=Left(str_params,j)
    result_url=str_url & "?" & str_params &"&page="
   End If
  End If
 End If
 GetURL=result_url
End Function

'====================================================================
' 设置 Terminate 事件。
'====================================================================
Private Sub Class_Terminate  
 XD_RS.close
 Set XD_RS=nothing
End Sub
'====================================================================
'ShowError  错误提示
'====================================================================
Private Sub ShowError()
 If str_Error <> "" Then
  Response.Write("" & str_Error & "")
  Response.End
 End If
End Sub
End class
set conn = server.CreateObject("adodb.connection")
conn.open "driver={microsoft access driver (*.mdb)};dbq=" & server.Mappath("pages.mdb")
'#############类调用样例#################
'创建对象
Set mypage=new xdownpage
'得到数据库连接
mypage.getconn=conn
'sql语句
mypage.getsql="select * from [test] order by id asc"
'设置每一页的记录条数据为5条
mypage.pagesize=5
'返回Recordset
set rs=mypage.getrs()
'显示分页信息，这个方法可以，在set rs=mypage.getrs()以后,可在任意位置调用，可以调用多次
mypage.showpage()

'显示数据
Response.Write("<br/>")
for i=1 to mypage.pagesize
'这里就可以自定义显示方式了
    if not rs.eof then 
        response.write rs(0) & "<br/>"
        rs.movenext
    else
         exit for
    end if
next
%>

技术太菜！一直在学习中！http://www.dongda-edu.cn

<% 
Class caDataGrid 
   'private variables 
   private pAutoColumns, pConnStr, pSqlStr, intColCnt 
   Private pOutPut, pConn, pRec, x, y, pArray 

   'this runs when you create a reference to the caDataGrid class 
   Private Sub Class_Initialize() 
       Set pConn = server.createobject("adodb.connection") 
       Set pRec = server.createobject("adodb.recordset") 
       intColCnt = 0 
       pAutoColumns = True 
   End Sub 
    
   'Properties - all writable 
   Public Property Let ConnectionString(strConn) 
       pConnStr = strConn 
   End Property 

   Public Property Let AutoColumns(bAutoCols) 
       If bAutoCols = True or bAutoCols = False then 
           pAutoColumns = bAutoCols 
       End IF 
   End Property 

   Public Property Let SqlString(strSql) 
       pSqlStr = strSql 
   End Property 

   'Methods for our class 
   Public Sub AddColumn(strColName) 
       If intColCnt = 0 then 
           pOutPut = "<table width='100%' border=1 cellpadding=0 cellspacing=0>" & vbcrlf 
           pOutPut = pOutPut & "<tr>" & vbcrlf 
       End If 
       pOutPut = pOutPut & "<td><strong>" & strColName & "</strong></td>" & vbcrlf 
       intColCnt = intColCnt + 1 
   End Sub 
    
   Public Sub Bind 
       pConn.Open pConnStr 
       Set pRec = pConn.Execute(pSqlStr) 
       If pAutoColumns = True then 
           'assign column names from returned recordset 
           pOutPut = "<table width='100%' border=1 cellpadding=0 cellspacing=0>" & vbcrlf 
           pOutPut = pOutPut & "<tr>" & vbcrlf 
           Redim pColNames(pRec.Fields.Count) 
           For x = 0 to pRec.Fields.Count - 1 
               pOutPut = pOutPut & "<td>" & pRec.Fields(x).Name & "</td>" & vbcrlf 
           Next 
       End If 
       pOutPut = pOutPut & "</tr>" & vbcrlf 
       pArray = pRec.GetRows 
       For x = 0 to UBound(pArray, 2) 
           pOutPut = pOutPut & "<tr>" & vbcrlf 
           For y = 0 to UBound(pArray, 1) 
   pOutPut = pOutPut & "<td>" & pArray(y, x) & "</td>" & vbcrlf 
           Next 
           pOutPut = pOutPut & "</tr>" & vbcrlf 
       Next 
       pOutPut = pOutPut & "</table>" & vbcrlf 
       Response.Write pOutPut 
   End Sub 
    
   'this runs when we destroy our reference to caDataGrid 
   Private Sub Class_Terminate() 
       pOutPut = "" 
       pRec.Close 
       Set pRec = nothing 
       pconn.close 
       Set pConn = nothing 
   End Sub 

End Class 
%>

function getdata ($month=NULL,$year=NULL,$appointment=array()) {

$month = ( $month ==NULL )? date("n"):$month;
$year = ( $year ==NULL )? date("Y"):$year;

$weekday_cn = array("日","一","二","三","四","五","六");
//
//先判断月份以及是不是2月和闰月
//
//可以用一个数组来代替
//设定数组下标为月份数，值为天数，根据月份数返回对应的值（天数）
//
if ($month !=2) {
   switch ($month) {
   case 1:
       $day = 31;
	   break;
   case 3:
       $day = 31;
	   break;
    case 4:
	   $day = 30;
	   break;
	case 5:
	   $day = 31;
	   break;
	case 6:
	   $day = 30;
	   break;
	case 7:
	   $day = 31;
	   break;
	case 8:
	   $day = 31;
	   break;
	case 9:
	   $day = 30;
	   break;
	case 10:
	   $day = 31;
	   break;
	case 11:
	   $day = 30;
	   break;
	case 12:
	   $day = 31;
	   break;
       }
	 }else{
	 if (date("L",mktime(0,0,0,$month,0,$year))) {
	     $day = 29;
		 }else{
		 $day = 28;
		 }
	}
		 
//得到开始的第一天是星期几
$start_day = (int)date("w",mktime(0,0,0,$month,date("j",mktime(0,0,0,$month,1,$year)),$year));

//日期从1开始计数
$n=1;

//得到今天是几号
$today=(int)date("j");

//打印表头
echo "<table width=/"200/" border=/"0/" cellspacing=/"1/" cellpadding=/"2/" class=/"calendar_table/"><tr class=/"calendar_tr_header/">";

echo "<th colspan=/"7/" scope=/"col/" class=/"calendar_th_header/">".$year."年".$month."月"."</th></tr>/n";
echo "<tr align=/"center/" class=/"calendar_tr_week/">";
for ($i=0;$i<count($weekday_cn);$i++) {
    echo "<th scope=/"col/" class=/"calendar_th_week/">".$weekday_cn[$i]."</th>/n";
    }
	echo "</tr>";
	
//打印第一行
echo "<tr align=/"center/" class=/"calendar_tr_day/"> /n";
for ($i=0;$i<$start_day;$i++) 
echo "<td class=/"calendar_td_day/">&nbsp;</td>/n";
for ($j=0;$j<(7-$start_day);$j++) {
#    $url_n = "<a href=/"".$appointment[$n]."/" class=/"calendar_app_day/">".$n."</a>";
	  $str_n = ( $appointment[$n] ==NULL )?$n:( "<a href=/"".$appointment[$n]."/" class=/"calendar_app_url/">".$n."</a>" );
	  $table_td= ($today ==$n)?("<td class=/"calendar_td_today/"><span class=/"calendar_app_today/">".$str_n."</span></td>"):("<td class=/"calendar_td_day/">".$str_n."</td>"); 
	  echo $table_td;
	  $n++;
	  }
echo "</tr>/n";

//已显示多少天
$m=($n-1);

//根据剩余天数除以7得到的商，用ceil()取整后，确定最后需要显示多少行
for($i=0;$i<(ceil($day-$m)/7);$i++){

  echo "<tr align=/"center/" class=/"calendar_tr_day/"> ";

//每行7天7个单元格
       for ($j=0;$j<7;$j++) {
             if ($n<=$day) {
	             $str_n = ( $appointment[$n] ==NULL )?$n:( "<a href=/"".$appointment[$n]."/" class=/"calendar_app_url/">".$n."</a>" );
				 //显示是否是当日
				 $table_td= ($today ==$n)?("<td class=/"calendar_td_today/"><span class=/"calendar_app_today/">".$n."</span></td>"):("<td class=/"calendar_td_day/">".$n."</td>"); 
	             echo $table_td;
		        $n++;
                }else{
//余下的空格显示	   
	             echo "<td class=/"calendar_td_day/">&nbsp;</td>/n";
	               }
	            } 
        echo "</tr>";
	}
   
echo "</table>";
}

方法有点笨，不过还算能用。也可以从外部定义CSS。
使用方法：
/*
//使用方法
//getdata();
//或给出月份和年度信息
//getdata(1,2006);
//
//CSS控制关键词
//
//calendar_table 整个表格
//calendar_tr_header 表格头部年月信息行
//calendar_th_header 表格头部年月信息单元格
//calendar_tr_week 星期行
//calendar_th_week 星期单元格
//calendar_tr_day 日期行
//calendar_td_day 日期单元格
//calendar_app_url 日程安排链接
//calendar_td_today 显示当日的单元格
//calendar_app_day 有日程安排的单元格
*/

快30的打工仔子

Sub ShowArrayInTable(ArrayToShow)
Dim I ' Simple Looping Var
Dim iArraySize ' Var to store array size

' If you want to know how big an array is, you can use this
' to find out. This even works in VB where they don't have
' to be zero-based. The LBound and UBound return the
' indecies of the lowest and highest array elements so to
' get the size we take the difference and add one since you
' can store a value at both end points.
iArraySize = (UBound(ArrayToShow) - LBound(ArrayToShow)) + 1

Response.Write "<p>The array has " & iArraySize _
& " elements. They are:</p>" & vbCrLf

Response.Write "<table border=""1"">" & vbCrLf

Response.Write "<thead>" & vbCrLf
Response.Write "<tr>" & vbCrLf
Response.Write "<th>Index</th>" & vbCrLf
Response.Write "<th>Value</th>" & vbCrLf
Response.Write "</tr>" & vbCrLf
Response.Write "</thead>" & vbCrLf

Response.Write "<tbody>" & vbCrLf

' Simple loop over a table outputting a row for each element
For I = LBound(ArrayToShow) To UBound(ArrayToShow)
Response.Write "<tr>" & vbCrLf
' Write out the index of the element we're currently on
Response.Write "<td>" & I & "</td>" & vbCrLf
' Write out the value of the element we're currently on
Response.Write "<td>" & ArrayToShow(I) & "</td>" & vbCrLf
Response.Write "</tr>" & vbCrLf
Next 'I
Response.Write "</tbody>" & vbCrLf

Response.Write "</table>" & vbCrLf
End Sub

<% @language="VBscript" %>
<% option explicit %>
<%

'--------------
' Hex2Dgt()
'------------------------------------------
' input: one hex-char 0..9, a..f, A..F
' return: a number 0..15
' note: no error-checking
'------------------------------------------
Function Hex2Dgt(ByVal inHexChar)
If ( inHexChar <= "9" ) Then
Hex2Dgt = Asc(inHexChar) - Asc("0")
Else
Hex2Dgt = Asc(uCase(inHexChar)) - Asc("A") + 10
End If
End Function

'--------------
' Hex2Dec()
'------------------------------------------
' input: a Hex string
' return:
' -2 null string
' -1 error (non-hex char)
' >= 0 the converted value
'------------------------------------------
Function Hex2Dec(ByVal inHex)

Dim oREX : Set oREX = New RegExp
Dim nVal : nVal = 0
Dim i

' test if null-string
'
If ( inHex="") Then
Hex2Dec = -2
Exit Function
End If

' test any non-hex char
'
oREX.Pattern = "[^0-9A-Fa-f]"
If ( oREX.Test(inHex)) Then
Hex2Dec = -1
Exit Function
End If

' now do the conversion
'
For i=1 to Len(inHex)
nVal = nVal * 16 + Hex2Dgt(Mid(inHex,i,1))
Next

Hex2Dec = nVal
set oREX = Nothing

End Function


' test
'
Dim aryHex(6) 
Dim ix

aryHex(0) = "00000000000000000000000000"
aryHex(1) = "7fffffff" ' max for Hex()
aryHex(2) = "ffffffffffff" ' 12-f
aryHex(3) = "deadbeef0123456789bad"
aryHex(4) = ""
aryHex(6) = "hex"

For ix=0 to UBound(aryHex)
Response.Write aryHex(ix) & " : " & Hex2Dec(aryHex(ix)) & "<br/>" & vbCRLF
Next
%>