asp函数库3-转载来的！用来收藏吧！

<%
'欢迎转载，但请注明来自"菩提树下的杨过(QQ:278919507 Mail:yjmyzz@126.com)
'option explicit

'001.function lpad(desstr,padchar,lenint) 左填充
'002.function rpad(desstr,padchar,lenint) 右填充
'003.function MakeRndPass(passlen,passtype) 生成随机密码
'004.function readFile(filepath) 读文件
'005.function WriteFile(filepath,fileContent) 写文件
'006.function DelFile(filepath) 删除文件
'007.sub alert(str,weburl) 弹出对话框
'008.function max(info) 取最大值
'009.function min(info) 取最小值
'010.function get1stMonth() 返回本月第一天的日期
'011.function get1stYear() 返回本年第一天的日期
'012.function get1stWeek() 返回本周第一天的日期
'013.function get1stQua() 返回本季度第一天的日期
'014.function ShowArticleContent() 分页显示长文章内容
'015.function IsObjInstalled() 检查组件是否已经安装
'016.function isHTTP() 检查字符串是否以HTTP开头或以"/"开头
'017.function strLength() 求字符串长度
'018.function checkNull() 检查str是否为空
'019.function getHTTPPage() 获取远程的网页内容
'020.function SendMailEx() 例如利用Jmail发信，适合于smtp需要验证的情况
'021.Function nohtml(str,strlen) 去掉所有html标记,并截取相应长度的字符串
'022.Function splitCount(str,splitchar) 拆分字符串,取拆分后的子串数
'023.function checkIMG(str) 检查字符中是否有IMG字样
'024.function doWrap() 解决DW显示字段值不能换行的问题
'025.function deleteparm() 删除指定网页参数中的某一项
'026.function findStr() 按分隔符查找字符串，找到返回True
'027.function makeID() 产生20位长度的唯一标识ID
'028.function findparm() 查询网页参数字符中某项的值
'029.function showIMG() 显示图片
'030.function showSWF() 显示flash,rm等
'031.function showRm() 播放rm
'032.function orderImg() 用于列标题排序时后面加上下箭头
'033.function orderURL() 用于列标题排序时生成相应地址
'034.function showPage() 用于显示翻页导航
'035.function DoDelFile() 删除文件,必须使用虚拟路径
'036.function Format_Time() 格式化日期
'037.function outHTML() 显示输出html代码
'038.function inHTML() 显示输出html代码,一般放在input框的值中
'039.IsSelfRefer() 是否从本站提交
'040.Get_SafeStr() 取得安全字符
'041.JimmyCode() 过滤html相关标记
'042.Function makeMonthDir() 上传时生成自动目录
'043.Function imgUpload() 利用aspJpeg,aspUpload上传图片,并自动生成缩略图

'上传图片(需要aspupload,aspjpeg支持,上传时会自动根据参数,按比例)
'参数:
'with small :上传图片时,是否同步生成小的缩略图(true是 false否)
'bigwidth:大图片的规定宽度
'bigheight:大图片的规定高度
'smallwidth:小图片的规定宽度
'smallheight:小图片的规定高度
'virturaluploadPath:上传的虚拟路径
'maxsize:上传图片的最大尺寸(字节,1K=1024字节)
'response.write imgUpload(true,700,400,150,200,"/upload",1024*100)
Function imgUpload

(withSmall,bigWidth,bigHeight,smallWidth,smallHeight,virturluploadPath,maxSize)
imgUpload = ""
dim Upload,Jpeg,tempFile,File,scale
if (not IsObjInstalled("Persits.Upload")) or (not IsObjInstalled("Persits.Jpeg")) then
response.write "<font color=red>尚未安装 ASPUpload 和 ASPJpeg组件 !</font>"
exit function
end if
Set Upload = Server.CreateObject("Persits.Upload")
Set Jpeg = Server.CreateObject("Persits.Jpeg")

Upload.OverwriteFiles = True '如果存在文件,强制overwrite

Upload.SetMaxSize maxSize, True '设置最大上传值 1K为1024,100K为100*1024

on error resume next

Upload.Save '上传到服务器内存中

if Err.Number = 8 then
response.write "<font color=red>文件太大,只允许上传" & formatnumber(maxSize/1024,0)

& "K以内的图片文件!</font>"
exit function
end if

For Each File in Upload.Files
If not(File.ImageType = "JPG" or File.ImageType = "GIF" or File.ImageType ="PNG")

Then
Response.Write "<font color=red>只允许上传有效的图片文件(如

GIF,PNG,JPEG,JPG).</font>"
File.Delete '如果是非法图片,则删除掉
Response.End
Else
tempfile =makeMonthDir(virturluploadPath,true) & MakeID() & File.Ext
imgupload = imgupload & "|" & tempfile
File.SaveAs server.mappath(tempFile) '自动重命名并保存到指定路径中
End If

Jpeg.Open File.Path
scale = resizeImg(Jpeg.OriginalWidth,Jpeg.OriginalHeight,bigwidth,bigheight)
Jpeg.Width = Jpeg.OriginalWidth * Scale
Jpeg.Height = Jpeg.OriginalHeight * Scale
Jpeg.Save makeMonthDir(virturluploadPath,false) & File.FileName '调整大图片大小

if withSmall then
scale = resizeImg

(Jpeg.OriginalWidth,Jpeg.OriginalHeight,smallWidth,smallheight)
Jpeg.Width = Jpeg.OriginalWidth * Scale
Jpeg.Height = Jpeg.OriginalHeight * Scale
Jpeg.Save makeMonthDir(virturluploadPath,false) & "small_" & File.FileName '

调整小图片大小
end if
Next
Set Upload = Nothing
Set Jpeg = Nothing
if left(imgUpload,1)="|" then imgUpload = right(imgupload,len(imgupload)-1)
End Function

'重新设定图片大小,返回百分比
function resizeImg(ox,oy,nx,ny)
resizeimg = 1
If ox<=nx And oy<=ny Then Exit function
dim x,y
'先算x
x = ny * ox / oy
if x > nx then 'x不行
y = nx * oy / ox
resizeImg = y / oy
else
resizeImg = x / ox
end if
resizeImg = formatNumber(resizeImg,4)
end function

'042
'上传时生成自动目录(以2005_6 类似的名称)
Function makeMonthDir(vitualRoot,virtual)
Dim dirName,dirNameV,fso
dirNameV = vitualRoot & "/" & Year(Now()) & "_" & Month(Now())
dirName = server.MapPath(dirNameV)
'response.write DirName & "<br>"
Set fso = server.CreateObject("Scripting.FileSystemObject")
if not fso.FolderExists(dirName) then
fso.CreateFolder(dirName)
end if
set fso = Nothing
If virtual Then
makeMonthDir = dirNameV & "/"
Else
makeMonthDir = dirName & "\"
End if
End Function

'035
' 删除指定的文件,必须传入虚拟路径
Sub DoDelFile(sPathFile)
On Error Resume Next
Dim oFSO
Set oFSO = Server.CreateObject("Scripting.FileSystemObject")
'response.write "<br>" & Server.MapPath(sPathFile)
oFSO.DeleteFile(Server.MapPath(sPathFile))
Set oFSO = Nothing
End Sub

'036
' ============================================
' 格式化时间(显示)
' 参数：n_Flag
' 1:"yyyy-mm-dd hh:mm:ss"
' 2:"yyyy-mm-dd"
' 3:"hh:mm:ss"
' 4:"yyyy年mm月dd日"
' 5:"yyyymmdd"
' 6:"MM/DD"
' ============================================
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
Case 6
'mm/dd
Format_Time = m & "/" & d
case 7
Format_Time = m & "/" & d & "/" & right(y,2)
End Select
End Function

'037
' ============================================
' 把字符串进行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

'038
' ============================================
' 去除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

'039
' ============================================
' 检测上页是否从本站提交
' 返回: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

'040
' ============================================
' 得到安全字符串,在查询中使用
' ============================================
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

'================================================
' 显示解释函数，返回根据参数允许显示的格式字符串，具体调用方法可从后台管理获得
' 输入参数：
' s_Content : 要转换的数据字符串
' s_Filters : 要过滤掉的格式集，用逗号分隔多个
'================================================
Function jimmycode(s_Content, sFilters)
Dim a_Filter, i, s_Result, s_Filters
jimmycode = s_Content
If IsNull(s_Content) Then Exit Function
If s_Content = "" Then Exit Function
's_Content = Replace(s_Content, Chr(10), "<br>")
s_Result = s_Content
s_Filters = sFilters

' 设置默认过滤
If sFilters = "" Then s_Filters = "script,object"

a_Filter = Split(s_Filters, ",")
For i = 0 To UBound(a_Filter)
s_Result = jimmycodeFilter(s_Result, a_Filter(i))
Next
jimmycode = s_Result
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,s_onchange)
Dim i
InitSelect = "<select name='" & s_FieldName & "' size=1 onChange='" & s_onchange & "'>"
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

%>

<Script Language=JavaScript RunAt=Server>
//===============================================
// 单个过滤
// 输入参数：
// s_Content : 要转换的数据字符串
// s_Filter : 要过滤掉的单个格式
//===============================================
function jimmycodeFilter(html, filter){
switch(filter.toUpperCase()){
case "SCRIPT": // 去除所有客户端脚本javascipt,vbscript,jscript,js,vbs,event,...
html = eWebEditor_execRE("</?script[^>]*>", "", html);
html = eWebEditor_execRE("(javascript|jscript|vbscript|vbs):", "$1：", html);
html = eWebEditor_execRE("on(mouse|exit|error|click|key)", "<I>on$1</I>", html);
html = eWebEditor_execRE("&#", "<I>&#</I>", html);
break;
case "TABLE": // 去除表格<table><tr><td><th>
html = eWebEditor_execRE("</?table[^>]*>", "", html);
html = eWebEditor_execRE("</?tr[^>]*>", "", html);
html = eWebEditor_execRE("</?th[^>]*>", "", html);
html = eWebEditor_execRE("</?td[^>]*>", "", html);
break;
case "CLASS": // 去除样式类class=""
html = eWebEditor_execRE("(<[^>]+) class=[^ |^>]*([^>]*>)", "$1 $2", html) ;
break;
case "STYLE": // 去除样式style=""
html = eWebEditor_execRE("(<[^>]+) style=\"[^\"]*\"([^>]*>)", "$1 $2", html);
break;
case "XML": // 去除XML<?xml>
html = eWebEditor_execRE("<\\?xml[^>]*>", "", html);
break;
case "NAMESPACE": // 去除命名空间<o:p></o:p>
html = eWebEditor_execRE("<\/?[a-z]+:[^>]*>", "", html);
break;
case "FONT": // 去除字体<font></font>
html = eWebEditor_execRE("</?font[^>]*>", "", html);
break;
case "P": // 去除字体<P></P>
html = eWebEditor_execRE("</?p[^>]*>", "", html);
break;
case "IMG": // 去除图片<IMG></IMG>
html = eWebEditor_execRE("</?img[^>]*>", "", html);
break;
case "MARQUEE": // 去除字幕<marquee></marquee>
html = eWebEditor_execRE("</?marquee[^>]*>", "", html);
break;
case "OBJECT": // 去除对象<object><param><embed></object>
html = eWebEditor_execRE("</?object[^>]*>", "", html);
html = eWebEditor_execRE("</?param[^>]*>", "", html);
html = eWebEditor_execRE("</?embed[^>]*>", "", html);
break;
case "HTML":
html = eWebEditor_execRE("</?[^>]*>", "", html);
break;
default:
}
return html;
}

// ============================================
// 执行正则表达式替换
// ============================================
function eWebEditor_execRE(re, rp, content) {
oreg = new RegExp(re, "ig");
r = content.replace(oReg, rp);
return r;
}

</Script>

<%

'034
'用途:翻页函数尾数(用于SqlServer存储过程翻页)
'参数:totalcount(记录总数),totalpage(总页数),pagenumber(显示几个页码),
' mypagesize(每页显示记录数),page(当前页数),style(为"text"时，带快速跳转框)
'示例:call showPage(TotalRecord,totalpage,5,10,page,"text")
function showPage(totalcount,totalpage,pagenumber,mypagesize,page,style)
dim url,parm,i,s_mid
if totalpage<=1 then exit function
if clng(page)<1 then page = 1
if clng(page)>clng(totalpage) then page=totalpage
if pagenumber="" then pagenumber=10
if lcase(trim(style))="" then style="none"
url = request.ServerVariables("url")
parm = request.ServerVariables("Query_String")
parm = deleteparm(parm,"page")
if parm<>"" then
url = url & "?" & parm & "&"
else
url = url & "?"
end if
showPage= "<table width='98%' align=center border=0><tr><td align=left>共有<font

color=red>" & totalcount & "</font>条，第:<font color=red>" & page & "</font>页/共<font

color=red>" & totalpage & "</font>页,<font color=red>" & mypagesize & "</font>/每页</td><td

align=right>"
'处理首页问题
if page>1 then
showPage = showPage & "<a href='" & url & "page=1' title='首页'>"
showPage = showPage & "<img src='/images/first.gif' align=absmiddle border=0></a>"
end if

s_mid = 0
s_mid = clng(pagenumber\2)

if pagenumber mod 2 <>0 then s_mid = s_mid+1

if clng(page)<=clng(totalpage) and clng(page)>=clng(s_mid) then
'处理中间页码的生成问题
for i=page-s_mid+1 to page-s_mid+pagenumber
if i<=totalpage then
if clng(i)=clng(page) then
showPage = showPage & " <font color=red>[" & i & "]</font>"

else
showPage = showPage & " <a href='" & url & "page=" & i & "'>" & i &

"</a>"
end if
end if
next
end if

if page>=1 and clng(page)<clng(s_mid) then
'第一页时的中间页码生成问题
for i=1 to pagenumber
if i<=totalpage then
if clng(i)=clng(page) then
showPage = showPage & " <font color=red>[" & i & "]</font>"

else
showPage = showPage & " <a href='" & url & "page=" & i & "'>" & i &

"</a>"
end if
end if
next
end if

if clng(page)<clng(totalpage) then '不是最后一页
showPage = showPage & " <a href='" & url & "page=" & totalpage & "' title='尾页'>"
showPage = showPage & "<img src='/images/last.gif' align=absmiddle border=0></a>"
end if

showPage = showPage & "</td>"
if style="text" then
if right(url,1)="?" or right(url,1)="&" then url = left(url,len(url)-1)
showPage = showPage & "<form name='frmpage' method='post' action='" & url &

"'><td><input size=2 name='page' value='" & page & "' style='border:1px inset #808080;

font-size: 9pt'> <input name='btnGo' type=submit value='Go' style='font-size: 9pt; border-

style: outset;border-width:1'></td></form></tr></table>"
else
showPage = showPage & "</tr></table>"
end if
Response.write showPage
end function

'033
'用途:用于列标题排序时生成相应地址
'参数:s_field(排序字段名)
'编写:杨俊明 2006-02-18
function orderURL(s_field,s_Page)
dim url,parm,orderway
Url = Request.ServerVariables("URL")
Parm = Request.ServerVariables("Query_String")
s_field = lcase(s_field)
parm = deleteparm(parm,"orderfield")
parm = deleteparm(parm,"page")
if parm = "" then
orderURL = url & "?orderfield=" & s_field & "&page=" & s_Page
else
orderURL = url & "?" & parm & "&orderfield=" & s_field & "&page=" & s_Page
end if
end function

'032
'用途:用于列标题排序时后面加上下箭头
'参数:s_field(排序字段名)))
'编写:杨俊明 2006-02-18
function orderImg(s_field)
dim parm,myfield
Parm = Request.ServerVariables("Query_String")
if parm = "" then exit function
s_field = trim(lcase(s_field))
myfield = findparm(parm,"orderfield")
myfield = lcase(trim(myfield))
if myfield="" then exit function
if myfield = s_field then
if session("sort")="asc" then
response.write "<font color=red>↑</font>"
else
response.write "<font color=red>↓</font>"
end if
end if
end function

'031 播放rm文件
sub showrm(rmpath,iwidth,iheight)
response.write "<OBJECT ID=RVOCX CLASSID='clsid:CFCDAA03-8BE4-11cf-B84B-0020AFBBCCFA'

WIDTH=" & iwidth & " HEIGHT=" & iheight & ">" & vbcrlf
response.write " <PARAM NAME='SRC' VALUE='" & rmpath & "'>" & vbcrlf
response.write " <PARAM NAME='CONTROLS' VALUE='ImageWindow'>" & vbcrlf
response.write " <PARAM NAME='CONSOLE' VALUE='one'>" & vbcrlf
response.write " <PARAM NAME='AUTOSTART' VALUE='true'>" & vbcrlf
response.write " <param name='LOOP' value='true'>" & vbcrlf
response.write " <EMBED SRC="" WIDTH=" & iwidth & " HEIGHT=" & iheight & " NOJAVA=true

CONTROLS=ImageWindow CONSOLE=one AUTOSTART=true>" & vbcrlf
response.write "</OBJECT>"
end sub

'利用java显示3d全景图 ,根目录下,需要放rubberneck.zip rubberneck.properties 两个文件
sub show3D(jpgpath,iwidth,iheight)
response.write "<APPLET name='rubber' archive='rubberneck.zip' code=RubberNeck.class

width=" & iwidth & " height=" & iheight & " MAYSCRIPT=true>" & vbcrlf
response.write " <PARAM name='enablefiltering' value='true'>" & vbcrlf
response.write " <PARAM name='revealhotspots' value='true'>" & vbcrlf
response.write " <PARAM name='incRate' value='100'>" & vbcrlf
response.write " <PARAM name='actions.length' value='1'>" & vbcrlf
response.write " <PARAM name='actions[0]' value='PositionAction'>" & vbcrlf
response.write " <PARAM name='actions[0].time' value='5000'>" & vbcrlf
response.write " <PARAM name='actions[0].isRel' value='true'>" & vbcrlf
response.write " <PARAM name='actions[0].pos.zoom' value='0'>" & vbcrlf
response.write " <PARAM name='actions[0].pos.yaw' value='360'>" & vbcrlf
response.write " <PARAM name='actions[0].pos.pitch' value='0'>" & vbcrlf
response.write " <PARAM name='rooms[0]' value='CylinderRoom'>" & vbcrlf
response.write " <PARAM name='rooms[0].initAction' value='0'>" & vbcrlf
response.write " <PARAM name='rooms[0].image' value='" & jpgpath & "'>" & vbcrlf
response.write " </APPLET>"
end sub

'030
function showSWF(imgpath,iwidth,iheight,cssOver,cssOut,salign,sborder)
showSWF = "<embed wmode='transparent' src='" & imgpath & "'"
if iwidth<>"" then showSWF = showSWF & " width=" & iwidth
if iheight<>"" then showSWF = showSWF & " height=" & iwidth
if cssOver<>"" then showSWF = showSWF & " onmouseover = " & chr(34) &

"this.className='" & cssOver & "'" & chr(34)
if cssOut<>"" then showSWF = showSWF & " onmouseOut = " & chr(34) & "this.className='"

& cssOut & "'" & chr(34) & " class='" & cssout & "'"
if sAlign<>"" then showSWF = showSWF & " align=" & sAlign
if sborder<>"" then showSWF = showSWF & " border=" & sborder
showSWF = showSWF & "></embed>"
response.write showSWF
end function

'029
function showIMG(imgpath,iwidth,iheight,cssOver,cssOut,salign,sborder)
showIMG = "<img src='" & imgpath & "'"
if iwidth<>"" then showIMG = showIMG & " width=" & iwidth
if iheight<>"" then showIMG = showIMG & " height=" & iwidth
if cssOver<>"" then showIMG = showIMG & " onmouseover = " & chr(34) &

"this.className='" & cssOver & "'" & chr(34)
if cssOut<>"" then showIMG = showIMG & " onmouseOut = " & chr(34) & "this.className='"

& cssOut & "'" & chr(34) & " class='" & cssout & "'"
if sAlign<>"" then showIMG = showIMG & " align=" & sAlign
if sborder<>"" then showIMG = showIMG & " border=" & sborder
showIMG = showIMG & ">"
response.write showIMG
end function

function showIMGex(imgpath,iwidth,iheight,cssOver,cssOut,salign,sborder)
showIMGex = "<img src='" & imgpath & "'"
if iwidth<>"" then showIMGex = showIMGex & " width=" & iwidth
if iheight<>"" then showIMGex = showIMGex & " height=" & iwidth
if cssOver<>"" then showIMGex = showIMGex & " onMouseOver = " & chr(34) &

"this.className='" & cssOver & "'" & chr(34)
if cssOut<>"" then showIMGex = showIMGex & " onMouseOut = " & chr(34) &

"this.className='" & cssOut & "'" & chr(34) & " class='" & cssout & "'"
if sAlign<>"" then showIMGex = showIMGex & " align=" & sAlign
if sborder<>"" then showIMGex = showIMGex & " border=" & sborder
showIMGex = showIMGex & ">"
end function

'028
'用途:查询网页参数字符中某项的值
'参数:t_urlparm(IE地址栏参数，可用request.ServerVariables("QUERY_STRING")得到，
' 比如xxx.asp?sex=man&age=18&name=杨 这个地址中参数为"sex=man&age=18&name=杨")
'示例:findparm("sex=man&age=18&name=杨","age")将显示结果18
'编写:杨俊明 QQ:278919507 Email:yjmyzz@126.com 2006-2-9 10:49
function findparm(t_urlparm,t_findparm)
if t_urlparm="" then
findparm=""
exit function
end if
dim temp,kk
temp = split(t_urlparm,"&")
for kk=0 to ubound(temp)
if instr(temp(kk),t_findparm)>0 then
findparm = right(temp(kk),len(temp(kk))-1-len(t_findparm))
exit function
end if
next
end function

'027 产生20位长度的唯一标识ID
'response.write makeID()
function makeID()
dim datestr,mytime,myyear,mymonth,myday,i
myyear = cstr(year(date()))
mymonth = cstr(month(date()))
myday = cstr(day(date()))
mymonth = lpad(mymonth,0,2)
makeID = myyear & "_" & mymonth & "_" & myday & "_"
datestr=cstr(now())
i = instr(datestr," ")
mytime = right(datestr,len(datestr)-i)
mytime = replace(mytime,":","_")
randomize
i = Int((9999 - 1000 + 1) * Rnd + 1000)
makeID = makeID & mytime & "_" & i
makeID = replace(makeID,"_","")
end function

'026
'用途:按分隔符查找字符串，找到返回True
'示例:if findStr("1,2,3,13,23","43") then
'response.write findStr("1,2,5,13,23",",","3")
function findStr(strSrc,strSplit,strFind)
dim s_temp,i
findStr = false
if strSrc = "" or isnull(strSrc) then exit function
if strSplit = "" or isnull(strSplit) then exit function
if strFind = "" or isnull(strFind) then exit function
s_temp = split(strSrc,strSplit)
for i = 0 to ubound(s_temp)
if cstr(s_temp(i))=cstr(strFind) then
findStr = True
exit function
end if
next
end function

'025
'用途:删除指定网页参数中的某一项
'编写:杨俊明 2006-2-17 14:29
'示例:response.write deleteparm("abc=3&name=jimmy&sex=male","name")　结果为abc=3&sex=male
'response.write deleteparm("abc=3&name=jimmy&sex=male","name")
function deleteparm(parmlist,findparm)
dim i,parmFront,parmBack
i = instr(parmlist,findparm)
if i>0 then
if i>2 then
parmfront = left(parmlist,i-2)
else
parmfront = ""
end if

parmlist = right(parmlist,len(parmlist)-i+1)
i = instr(parmlist,"&")
if i>0 then
parmback = right(parmlist,len(parmlist)-i)
else
parmback = ""
end if
else
deleteparm = parmlist
exit function
end if

if parmfront<>"" and parmback<>"" then
deleteparm = parmfront & "&" & parmback
else
deleteparm = parmfront & parmback
end if
end function

'024****************************************************
'函数名：doWrap
'作 用：解决DW显示字段值不能换行的问题
'参 数：str，注str不能为NULL值
'编 写:网上搜集
'****************************************************
function doWrap(str)
if str=NULL then
doWrap=""
else
doWrap = Replace((Replace(str, vbCrlf, "<br>")), chr(32)&chr(32), " ")
end if
End Function

'023****************************************************
'函数名：checkIMG(适用于HTML代码)
'作 用：检查字符中是否有IMG字样
'参 数：str，注str不能为NULL值
'编 写:杨俊明
'****************************************************
'response.write checkIMG("<img src=>")
function checkIMG(str)
if isnull(str) then
str=""
end if
checkIMG = false
str = ucase(str)
if instr(str,"<IMG")>=1 then
checkIMG = true
end if
end function

'函数名：checkIMGUBB(适用于UBB代码)
'作 用：检查字符中是否有IMG字样,即检查ubb代码中是否图片
'参 数：str，注str不能为NULL值
'编写:杨俊明 *********************************************
function checkIMGUBB(str)
if isnull(str) then
str=""
end if
checkIMGUBB = false
str = ucase(str)
if instr(str,"[IMG]")>=1 then
checkIMGUBB = true
end if
end function

'022
'用途:拆分字符串,取拆分后的子串数
'示例: response.write splitCount("abc|def|123","|") 结果显示3
'编写:杨俊明
'response.write splitCount("abc|def|123","|")
function splitCount(str,splitchar)
dim temp
if isnull(str) or str="" then
splitCount=0
exit function
end if
temp = split(str,splitchar)
splitCount=ubound(temp)+1
end function

'021
'用途:去掉所有html标记,并截取相应长度的字符串
'示例:response.write nohtmlex("<br><font color=red>abc</font>",3)
'编写:来自互联网
'response.write nohtmlex("<br><font color=red>abc</font>",3)
Function nohtml(str,strlen)
if isnull(str) then str=""
'去掉所有HTML标记
Dim re
Set re=new RegExp
re.IgnoreCase =True
re.Global=True
re.Pattern="<(.[^>]*)>"
're.Pattern="</?[^>]*>"
str=re.Replace(str,"")
set re=Nothing
Dim l,t,c,i
l=Len(str)
t=0
For i=1 to l
c=Abs(Asc(Mid(str,i,1)))
If c>255 Then
t=t+2
Else
t=t+1
End If
If t>=strlen Then
nohtml=left(str,i)&"..."
Exit For
Else
nohtml=str
End If
Next
'nohtml=Replace(nohtml,chr(10),"<br>")
nohtml=Replace(nohtml,chr(13),"<br>")
End Function

'用途:去掉所有html标记,包括回车,空格,并截取相应长度的字符串
'示例:response.write nohtmlex("<br><font color=red>abc</font>",3)
'编写:杨俊明 修改于网上源程序
Function nohtmlEx(str,strlen)
if isnull(str) then str=""
'去掉所有HTML标记
Dim re
Set re=new RegExp
re.IgnoreCase =True
re.Global=True
re.Pattern="<(.[^>]*)>"
're.Pattern="</?[^>]*>"
str=re.Replace(str,"")
set re=Nothing
Dim l,t,c,i
l=Len(str)
t=0
For i=1 to l
c=Abs(Asc(Mid(str,i,1)))
If c>255 Then
t=t+2
Else
t=t+1
End If
If t>=strlen Then
nohtmlEx=left(str,i)
Exit For
Else
nohtmlEx=str
End If
Next
nohtmlEx=Replace(nohtmlEx," ","")
nohtmlEx=Replace(nohtmlEx,"　","")
nohtmlEx=Replace(nohtmlEx,chr(13),"")
nohtmlEx=Replace(nohtmlEx,chr(10),"")
nohtmlEx=Replace(nohtmlEx," ","")
End Function

'020
'用途:例如利用Jmail发信，适合于smtp需要验证的情况　
'示例:
'dim subject,mailaddress,sendername,email,content,fromer,SerEmailUser,SerEmailPass
'subject ="你好，我是CPP114"
'mailaddress = "mail.cpp114.net"
'senderName = "我不是杨过"
'email = "yjmyzz@126.com"
'content = "欢迎访问中华印刷包装网!<br><a

href=http://www.cpp114.com>www.cpp114.com</a><br>发送成功了，苍天啊，大地啊，不容易啊!"
'fromer = "yangjm@cpp114.net"
'SerEmailUser = "yangjm@cpp114.net"
'SerEmailPass = "3power"
'call SendMailEx(subject, mailaddress, senderName,email, content,

fromer,serEmailUser,serEmailPass)
Sub SendMailEx(subject, mailaddress, senderName,email, content,

fromer,serEmailUser,serEmailPass)
dim Jmail
Set jmail = Server.CreateObject("JMAIL.Message") '建立发送邮件的对象
jmail.silent = true '屏蔽例外错误，返回FALSE跟TRUE两值
jmail.logging = true '启用邮件日志
jmail.Charset = "GB2312" '邮件的文字编码为国标
jmail.ContentType = "text/html" '邮件的格式为HTML格式
JMail.FromName = senderName '邮件发送者名称
jmail.AddRecipient Email '邮件收件人的地址
jmail.From = fromer '发件人的E-MAIL地址
jmail.MailServerUserName = serEmailUser '登录邮件服务器所需的用户名
jmail.MailServerPassword = serEmailPass '登录邮件服务器所需的密码
jmail.Subject = subject '邮件的标题
jmail.Body = content '邮件的内容
jmail.Priority = 1 '邮件的紧急程序，1 为最快，5 为最慢， 3 为默认值
jmail.Send(mailaddress) '执行邮件发送（通过邮件服务器地址）
jmail.Close() '关闭对象
end Sub

'用途:例如利用Jmail发信，适合于smtp不用验证的情况　
'示例:
'subject = "新闻系统_美女脱衣"
'mailaddress = "61.152.108.148" '换成smtp.cpp114.net也行
'email = "yjm@cpp114.net"
'sender = "我不是杨过"
'content = "您好，收到这封邮件，表示你今天会有好运气!<a href=http://www.baidu.com

target=_blank>百度搜索</a>"
'fromer = "yangjm@cpp114.net"
'call SendMail(subject, mailaddress, email, sender, content, fromer)
Sub SendMail(subject, mailaddress, email, sender, content, fromer)
Set jmail = Server.CreateObject("JMAIL.SMTPMail") '创建一个JMAIL对象
jmail.silent = true 'JMAIL不会抛出例外错误，返回的值为FALSE跟TRUE
jmail.logging = true '启用使用日志
jmail.Charset = "GB2312" '邮件文字的代码为简体中文
jmail.ContentType = "text/html" '邮件的格式为HTML的
jmail.ServerAddress = mailaddress '发送邮件的服务器
jmail.AddRecipient Email '邮件的收件人
jmail.SenderName = sender '邮件发送者的姓名
jmail.Sender = fromer '邮件发送者的邮件地址
jmail.Priority = 1 '邮件的紧急程序，1 为最快，5 为最慢， 3 为默认值
jmail.Subject = subject '邮件的标题
jmail.Body = content '邮件的内容'由于没有用到密抄跟抄送，这里屏蔽掉这两句，如果您有需

要的话，可以在这里恢复
'jmail.AddRecipientBCC Email '密件收件人的地址
'jmail.AddRecipientCC Email '邮件抄送者的地址
jmail.Execute() '执行邮件发送
jmail.Close '关闭邮件对象
End Sub

'019
'用途:获取远程的网页内容
'示例:response.write getHTTPPage("http://www.baidu.com")
'response.write getHTTPPage("http://www.baidu.com")
function getHTTPPage(url)
on error resume next
dim http
set http=Server.createobject("Microsoft.XMLHTTP")
Http.open "GET",url,false
Http.send()
if Http.readystate<>4 then
exit function
end if
getHTTPPage=bytes2BSTR(Http.responseBody)
set http=nothing
if err.number<>0 then err.Clear
end function

Function bytes2BSTR(vIn)
dim strReturn
dim i,ThisCharCode,NextCharCode
strReturn = ""
For i = 1 To LenB(vIn)
ThisCharCode = AscB(MidB(vIn,i,1))
If ThisCharCode < &H80 Then
strReturn = strReturn & Chr(ThisCharCode)
Else
NextCharCode = AscB(MidB(vIn,i+1,1))
strReturn = strReturn & Chr(CLng(ThisCharCode) * &H100 + CInt(NextCharCode))
i = i + 1
End If
Next
bytes2BSTR = strReturn
End Function

'018
'用途:检查str是否为空
Function checkNull(str)
checkNull = False
if trim(str)="" or isnull(str) then
checkNull = True
end if
end Function

'017**************************************************
'函数名：strLength
'作 用：求字符串长度。汉字算两个字符，英文算一个字符。
'参 数：str ----要求长度的字符串
'返回值：字符串长度
'**************************************************
'response.write strLength("中国")
function strLength(str)
ON ERROR RESUME NEXT
dim WINNT_CHINESE
WINNT_CHINESE = (len("中国")=2)
if WINNT_CHINESE then
dim l,t,c
dim 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
end if
next
strLength=t
else
strLength=len(str)
end if
if err.number<>0 then err.clear
end function

'016****************************************************
'函数名：isHTTP
'作 用：检查字符串是否以HTTP开头或以"/"开头
'参 数：str，注str不能为NULL值
'编 写:杨俊明
'****************************************************
'response.write isHTTP("http://")
Function isHTTP(MyString)
if isnull(MyString) then isHTTP = false
if mid(lcase(trim(MyString)),1,7)="http://" or left(MyString,1)="/" then
isHTTP = true
else
isHTTP = False
end if
end function

'015
'作 用：检查组件是否已经安装
'参 数：strClassString ----组件名
'返回值：True ----已经安装
' False ----没有安装
'示例: response.write IsObjInstalled("Adodb.recordset")
'编写:网上搜索
Function IsObjInstalled(strClassString)
On Error Resume Next
IsObjInstalled = False
Err = 0
Dim xTestObj
Set xTestObj = Server.CreateObject(strClassString)
If 0 = Err Then IsObjInstalled = True
Set xTestObj = Nothing
Err = 0
End Function

'014========网上搜集=====================================
'过程名：ShowArticleContent
'作 用：显示文章具体的内容，可以分页显示
'参 数：ShowContentByPage,s_content,MaxPerPage_Content
'调用示例:
'ShowContentByPage="yes" '是否使用文章分页(为No，则表示关闭)
's_content = "一1<font color=red>二2三3四</font>4五六七八九十" '要分页显示的字符串
'MaxPerPage_Content = 15 '每页显示的字数(注意，html源代码也计算在内)
'call ShowArticleContent(ShowContentByPage,s_content,MaxPerPage_Content)
'=================================================
'call ShowArticleContent("yes","123456789",4)有问题
sub ShowArticleContent(ShowContentByPage,s_content,MaxPerPage_Content)
on error resume next
dim ArticleID,strContent,CurrentPage,GoUrl,GoParm
dim ContentLen,MaxPerPage,pages,i,lngBound
dim BeginPoint,EndPoint
GoUrl = request.ServerVariables("url")
GoParm = trim(request.ServerVariables("query_string"))
if isNull(GoPram) then GoParm=""
if instr(GoParm,"ArticlePage")>0 then GoParm = left(GoParm,instr(GoParm,"ArticlePage")

-1)
if right(GoParm,1)="&" then GoParm = left(GoParm,len(GoParm)-1)
if GoParm<>"" then
GoUrl = GoUrl & "?" & GoParm & "&"
else
GoUrl = GoUrl & "?"
end if
ShowContentByPage = ucase(ShowContentByPage)
ArticleID=cint(s_id)
strContent=s_content
ContentLen=len(strContent)
CurrentPage=trim(request("ArticlePage"))
if ShowContentByPage="NO" or ContentLen<=MaxPerPage_Content then
response.write strContent
if ShowContentByPage="YES" then
response.write "</p><p align='center'></p>"
end if
else
if CurrentPage="" then
CurrentPage=1
else
CurrentPage=Cint(CurrentPage)
end if
pages=ContentLen\MaxPerPage_Content
if MaxPerPage_Content*pages<ContentLen then
pages=pages+1
end if
lngBound=MaxPerPage_Content '最大误差范围
if CurrentPage<1 then CurrentPage=1
if CurrentPage>pages then CurrentPage=pages

dim lngTemp
dim

lngTemp1,lngTemp1_1,lngTemp1_2,lngTemp1_1_1,lngTemp1_1_2,lngTemp1_1_3,lngTemp1_2_1,lngTemp1

_2_2,lngTemp1_2_3
dim

lngTemp2,lngTemp2_1,lngTemp2_2,lngTemp2_1_1,lngTemp2_1_2,lngTemp2_2_1,lngTemp2_2_2
dim

lngTemp3,lngTemp3_1,lngTemp3_2,lngTemp3_1_1,lngTemp3_1_2,lngTemp3_2_1,lngTemp3_2_2
dim

lngTemp4,lngTemp4_1,lngTemp4_2,lngTemp4_1_1,lngTemp4_1_2,lngTemp4_2_1,lngTemp4_2_2
dim lngTemp5,lngTemp5_1,lngTemp5_2
dim lngTemp6,lngTemp6_1,lngTemp6_2

if CurrentPage=1 then
BeginPoint=1
else
BeginPoint=MaxPerPage_Content*(CurrentPage-1)+1

lngTemp1_1_1=instr(BeginPoint,strContent,"</table>",1)
lngTemp1_1_2=instr(BeginPoint,strContent,"</TABLE>",1)
lngTemp1_1_3=instr(BeginPoint,strContent,"</Table>",1)
if lngTemp1_1_1>0 then
lngTemp1_1=lngTemp1_1_1
elseif lngTemp1_1_2>0 then
lngTemp1_1=lngTemp1_1_2
elseif lngTemp1_1_3>0 then
lngTemp1_1=lngTemp1_1_3
else
lngTemp1_1=0
end if

lngTemp1_2_1=instr(BeginPoint,strContent,"<table",1)
lngTemp1_2_2=instr(BeginPoint,strContent,"<TABLE",1)
lngTemp1_2_3=instr(BeginPoint,strContent,"<Table",1)
if lngTemp1_2_1>0 then
lngTemp1_2=lngTemp1_2_1
elseif lngTemp1_2_2>0 then
lngTemp1_2=lngTemp1_2_2
elseif lngTemp1_2_3>0 then
lngTemp1_2=lngTemp1_2_3
else
lngTemp1_2=0
end if

if lngTemp1_1=0 and lngTemp1_2=0 then
lngTemp1=BeginPoint
else
if lngTemp1_1>lngTemp1_2 then
lngtemp1=lngTemp1_2
else
lngTemp1=lngTemp1_1+8
end if
end if

lngTemp2_1_1=instr(BeginPoint,strContent,"</p>",1)
lngTemp2_1_2=instr(BeginPoint,strContent,"</P>",1)
if lngTemp2_1_1>0 then
lngTemp2_1=lngTemp2_1_1
elseif lngTemp2_1_2>0 then
lngTemp2_1=lngTemp2_1_2
else
lngTemp2_1=0
end if

lngTemp2_2_1=instr(BeginPoint,strContent,"<p",1)
lngTemp2_2_2=instr(BeginPoint,strContent,"<P",1)
if lngTemp2_2_1>0 then
lngTemp2_2=lngTemp2_2_1
elseif lngTemp2_2_2>0 then
lngTemp2_2=lngTemp2_2_2
else
lngTemp2_2=0
end if

if lngTemp2_1=0 and lngTemp2_2=0 then
lntTemp2=BeginPoint
else
if lngTemp2_1>lngTemp2_2 then
lngtemp2=lngTemp2_2
else
lngTemp2=lngTemp2_1+4
end if
end if

lngTemp3_1_1=instr(BeginPoint,strContent,"</ur>",1)
lngTemp3_1_2=instr(BeginPoint,strContent,"</UR>",1)
if lngTemp3_1_1>0 then
lngTemp3_1=lngTemp3_1_1
elseif lngTemp3_1_2>0 then
lngTemp3_1=lngTemp3_1_2
else
lngTemp3_1=0
end if

lngTemp3_2_1=instr(BeginPoint,strContent,"<ur",1)
lngTemp3_2_2=instr(BeginPoint,strContent,"<UR",1)
if lngTemp3_2_1>0 then
lngTemp3_2=lngTemp3_2_1
elseif lngTemp3_2_2>0 then
lngTemp3_2=lngTemp3_2_2
else
lngTemp3_2=0
end if

if lngTemp3_1=0 and lngTemp3_2=0 then
lngTemp3=BeginPoint
else
if lngTemp3_1>lngTemp3_2 then
lngtemp3=lngTemp3_2
else
lngTemp3=lngTemp3_1+5
end if
end if

if lngTemp1<lngTemp2 then
lngTemp=lngTemp2
else
lngTemp=lngTemp1
end if
if lngTemp<lngTemp3 then
lngTemp=lngTemp3
end if

if lngTemp>BeginPoint and lngTemp<=BeginPoint+lngBound then
BeginPoint=lngTemp
else
lngTemp4_1_1=instr(BeginPoint,strContent,"</li>",1)
lngTemp4_1_2=instr(BeginPoint,strContent,"</LI>",1)
if lngTemp4_1_1>0 then
lngTemp4_1=lngTemp4_1_1
elseif lngTemp4_1_2>0 then
lngTemp4_1=lngTemp4_1_2
else
lngTemp4_1=0
end if

lngTemp4_2_1=instr(BeginPoint,strContent,"<li",1)
lngTemp4_2_1=instr(BeginPoint,strContent,"<LI",1)
if lngTemp4_2_1>0 then
lngTemp4_2=lngTemp4_2_1
elseif lngTemp4_2_2>0 then
lngTemp4_2=lngTemp4_2_2
else
lngTemp4_2=0
end if

if lngTemp4_1=0 and lngTemp4_2=0 then
lngTemp4=BeginPoint
else
if lngTemp4_1>lngTemp4_2 then
lngtemp4=lngTemp4_2
else
lngTemp4=lngTemp4_1+5
end if
end if

if lngTemp4>BeginPoint and lngTemp4<=BeginPoint+lngBound then
BeginPoint=lngTemp4
else
lngTemp5_1=instr(BeginPoint,strContent,"<img",1)
lngTemp5_2=instr(BeginPoint,strContent,"<IMG",1)
if lngTemp5_1>0 then
lngTemp5=lngTemp5_1
elseif lngTemp5_2>0 then
lngTemp5=lngTemp5_2
else
lngTemp5=BeginPoint
end if

if lngTemp5>BeginPoint and lngTemp5<BeginPoint+lngBound then
BeginPoint=lngTemp5
else
lngTemp6_1=instr(BeginPoint,strContent,"<br>",1)
lngTemp6_2=instr(BeginPoint,strContent,"<BR>",1)
if lngTemp6_1>0 then
lngTemp6=lngTemp6_1
elseif lngTemp6_2>0 then
lngTemp6=lngTemp6_2
else
lngTemp6=0
end if

if lngTemp6>BeginPoint and lngTemp6<BeginPoint+lngBound then
BeginPoint=lngTemp6+4
end if
end if
end if
end if
end if

if CurrentPage=pages then
EndPoint=ContentLen
else
EndPoint=MaxPerPage_Content*CurrentPage
if EndPoint>=ContentLen then
EndPoint=ContentLen
else
lngTemp1_1_1=instr(EndPoint,strContent,"</table>",1)
lngTemp1_1_2=instr(EndPoint,strContent,"</TABLE>",1)
lngTemp1_1_3=instr(EndPoint,strContent,"</Table>",1)
if lngTemp1_1_1>0 then
lngTemp1_1=lngTemp1_1_1
elseif lngTemp1_1_2>0 then
lngTemp1_1=lngTemp1_1_2
elseif lngTemp1_1_3>0 then
lngTemp1_1=lngTemp1_1_3
else
lngTemp1_1=0
end if

lngTemp1_2_1=instr(EndPoint,strContent,"<table",1)
lngTemp1_2_2=instr(EndPoint,strContent,"<TABLE",1)
lngTemp1_2_3=instr(EndPoint,strContent,"<Table",1)
if lngTemp1_2_1>0 then
lngTemp1_2=lngTemp1_2_1
elseif lngTemp1_2_2>0 then
lngTemp1_2=lngTemp1_2_2
elseif lngTemp1_2_3>0 then
lngTemp1_2=lngTemp1_2_3
else
lngTemp1_2=0
end if

if lngTemp1_1=0 and lngTemp1_2=0 then
lngTemp1=EndPoint
else
if lngTemp1_1>lngTemp1_2 then
lngtemp1=lngTemp1_2-1
else
lngTemp1=lngTemp1_1+7
end if
end if

lngTemp2_1_1=instr(EndPoint,strContent,"</p>",1)
lngTemp2_1_2=instr(EndPoint,strContent,"</P>",1)
if lngTemp2_1_1>0 then
lngTemp2_1=lngTemp2_1_1
elseif lngTemp2_1_2>0 then
lngTemp2_1=lngTemp2_1_2
else
lngTemp2_1=0
end if

lngTemp2_2_1=instr(EndPoint,strContent,"<p",1)
lngTemp2_2_2=instr(EndPoint,strContent,"<P",1)
if lngTemp2_2_1>0 then
lngTemp2_2=lngTemp2_2_1
elseif lngTemp2_2_2>0 then
lngTemp2_2=lngTemp2_2_2
else
lngTemp2_2=0
end if

if lngTemp2_1=0 and lngTemp2_2=0 then
lngTemp2=EndPoint
else
if lngTemp2_1>lngTemp2_2 then
lngTemp2=lngTemp2_2-1
else
lngTemp2=lngTemp2_1+3
end if
end if

lngTemp3_1_1=instr(EndPoint,strContent,"</ur>",1)
lngTemp3_1_2=instr(EndPoint,strContent,"</UR>",1)
if lngTemp3_1_1>0 then
lngTemp3_1=lngTemp3_1_1
elseif lngTemp3_1_2>0 then
lngTemp3_1=lngTemp3_1_2
else
lngTemp3_1=0
end if

lngTemp3_2_1=instr(EndPoint,strContent,"<ur",1)
lngTemp3_2_2=instr(EndPoint,strContent,"<UR",1)
if lngTemp3_2_1>0 then
lngTemp3_2=lngTemp3_2_1
elseif lngTemp3_2_2>0 then
lngTemp3_2=lngTemp3_2_2
else
lngTemp3_2=0
end if

if lngTemp3_1=0 and lngTemp3_2=0 then
lngTemp3=EndPoint
else
if lngTemp3_1>lngTemp3_2 then
lngtemp3=lngTemp3_2-1
else
lngTemp3=lngTemp3_1+4
end if
end if

if lngTemp1<lngTemp2 then
lngTemp=lngTemp2
else
lngTemp=lngTemp1
end if
if lngTemp<lngTemp3 then
lngTemp=lngTemp3
end if

if lngTemp>EndPoint and lngTemp<=EndPoint+lngBound then
EndPoint=lngTemp
else
lngTemp4_1_1=instr(EndPoint,strContent,"</li>",1)
lngTemp4_1_2=instr(EndPoint,strContent,"</LI>",1)
if lngTemp4_1_1>0 then
lngTemp4_1=lngTemp4_1_1
elseif lngTemp4_1_2>0 then
lngTemp4_1=lngTemp4_1_2
else
lngTemp4_1=0
end if

lngTemp4_2_1=instr(EndPoint,strContent,"<li",1)
lngTemp4_2_1=instr(EndPoint,strContent,"<LI",1)
if lngTemp4_2_1>0 then
lngTemp4_2=lngTemp4_2_1
elseif lngTemp4_2_2>0 then
lngTemp4_2=lngTemp4_2_2
else
lngTemp4_2=0
end if

if lngTemp4_1=0 and lngTemp4_2=0 then
lngTemp4=EndPoint
else
if lngTemp4_1>lngTemp4_2 then
lngtemp4=lngTemp4_2-1
else
lngTemp4=lngTemp4_1+4
end if
end if

if lngTemp4>EndPoint and lngTemp4<=EndPoint+lngBound then
EndPoint=lngTemp4
else
lngTemp5_1=instr(EndPoint,strContent,"<img",1)
lngTemp5_2=instr(EndPoint,strContent,"<IMG",1)
if lngTemp5_1>0 then
lngTemp5=lngTemp5_1-1
elseif lngTemp5_2>0 then
lngTemp5=lngTemp5_2-1
else
lngTemp5=EndPoint
end if

if lngTemp5>EndPoint and lngTemp5<EndPoint+lngBound then
EndPoint=lngTemp5
else
lngTemp6_1=instr(EndPoint,strContent,"<br>",1)
lngTemp6_2=instr(EndPoint,strContent,"<BR>",1)
if lngTemp6_1>0 then
lngTemp6=lngTemp6_1+3
elseif lngTemp6_2>0 then
lngTemp6=lngTemp6_2+3
else
lngTemp6=EndPoint
end if

if lngTemp6>EndPoint and lngTemp6<EndPoint+lngBound then
EndPoint=lngTemp6
end if
end if
end if
end if
end if
end if
response.write mid(strContent,BeginPoint,EndPoint-BeginPoint)
response.write "</p><p align='center'>"
if CurrentPage>1 then
response.write "<a href=" & Gourl & "ArticlePage=" & CurrentPage-1 & ">上一页

</a> "
end if
for i=1 to pages
if i=CurrentPage then
response.write "<font color='red'>[" & cstr(i) & "]</font> "
else
response.write "<a href=" & Gourl & "ArticlePage=" & i & ">[" & i & "]</a>

"
end if
next
if CurrentPage<pages then
response.write " <a href=" & Gourl & "ArticlePage=" & CurrentPage+1 & ">下一页

</a>"
end if
response.write "</p>"
end if
end sub

'010
'用途:返回本月第一天的日期
'编写:杨俊明 2006-2-10 11:57
function get1stMonth()
get1stMonth = cdate(year(date) & "-" & month(date) & "-1")
end function

'011
'用途:返回本年第一天的日期
'编写:杨俊明 2006-2-10 11:58
function get1stYear()
get1stYear = cdate(year(date) & "-1-1")
end function

'012
'用途:返回本周第一天的日期
'编写:杨俊明 2006-2-10 11:58
'response.write get1stWeek
function get1stWeek()
dim s_weekday
s_weekday = Weekday(date())
if s_weekday>2 then
get1stWeek=date()-(s_weekday-2)
elseif s_weekday=2 then
get1stWeek= date()
else
get1stWeek = date()-6
end if
end function

'013
'用途:返回本季度每一天的日期
'编写:杨俊明 2006-2-10 11:59
function get1stQua()
dim s_month
s_month = month(date())
s_month = s_month \ 3
if s_month<=1 then
get1stQua = year(date) & "-1-1"
elseif s_month<=2 then
get1stQua = year(date) & "-4-1"
elseif s_month<=3 then
get1stQua = year(date) & "-7-1"
else
get1stQua = year(date) & "-10-1"
end if
get1stQua = cdate(get1stQua)
end function

'009
'用途:取最小值，调用示例i=min("12,34,45,67")
'编写:杨俊明 2006-2-10 11:56
'response.write min("12,34,45,67")
function min(info)
dim arr,i
arr=split(info,",")
min=clng(arr(0))
for i=1 to ubound(arr)
if clng(arr(i))<clng(min) then min=clng(arr(i))
next
end function

'008
'用途:取最大值，调用示例i=max("12,34,45,67")
'编写:杨俊明 2006-2-10 11:56
function max(info)
dim arr,i
arr=split(info,",")
max=clng(arr(0))
for i=1 to ubound(arr)
if clng(arr(i))>clng(max) then max=clng(arr(i))
next
end function

'007
'用途:弹出一个对话框(根据用户需要还可跳转到相关地址)
'参数:str(弹出内容),weburl(弹出对话框后,跳转后的地址)
'示例:call alert("你没有权限打开此页","")
'编写:杨俊明 2006-2-10 11:56
sub alert(str,weburl)
if trim(str)="" then exit sub
response.write "<script>alert('" & str & "');</script>"
if trim(weburl) <>"" then response.write "<script>window.location='" & weburl &

"';</script>"
End sub

'001
'用途:用于左填充指定数量的字符,以达到规范长度
'参数:desstr(目标字符),lpad(填充字符),lenint(填充后的字符总长度)
'示例:response.write lpad(4,0,5),结果显示00004
'编写:杨俊明 2006-2-4 20:09 QQ:278919507 Email:yjmyzz@126.com
'response.write lpad(4,0,5)
function lpad(desstr,padchar,lenint)
dim d,p,t
d = cstr(desstr)
p = cstr(padchar)
lpad=""
for t=1 to lenint-len(d)
lpad = p & lpad
next
lpad = lpad & d
end function

'002
'用途:用于右填充指定数量的字符
'参数:desstr(目标字符),lpad(填充字符),lenint(填充后的字符总长度)
'示例:response.write rpad('a',0,5),结果显示a0000
'编写:杨俊明 2006-2-4 20:17 QQ:278919507 Email:yjmyzz@126.com
function rpad(desstr,padchar,lenint)
dim d,p,t
d = cstr(desstr)
p = cstr(padchar)
rpad=""
for t=1 to lenint-len(d)
rpad = p & rpad
next
rpad = d & rpad
end function

'003
'用途:生成指定长度的随机密码
'参数:passlen(密码的长度),passtype(密码类型，可选值有
' passFull,passNumber,passSpecial,passCharNumber,
' passChar,passUpperCharNumber,passLowerCharNumber,passUpperChar,passLowerChar)
'示例:reponse.write makeRndPass(20,"passcharnumber")生成20位由字母和数字组合的密码
'编写:杨俊明 2006-2-8 12:48 QQ:278919507 Email:yjmyzz@126.com
'response.write makeRndPass(20,"passcharnumber")
function MakeRndPass(passlen,passtype)
dim

passFull,passNumber,passSpecial,passCharNumber,passChar,pass,passUpperCharNumber,passLowerC

harNumber,passUpperChar,passLowerChar,ii,jj
passFull = "1234567890!@#$%^&*()[];',./{}:?`~-

=\_+|abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
passNumber = "1234567890"
passSpecial = "!@#$%^&*()[];',./{}:?`~-=\_+|"
passCharNumber = "abcdefghijklmnopqrstuvwxyz1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ"
passUpperCharNumber = "1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ"
passLowerCharNumber = "abcdefghijklmnopqrstuvwxyz1234567890"
passChar = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
passUpperChar = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
passLowerChar = "abcdefghijklmnopqrstuvwxyz"
select case lcase(trim(passType))
case "passfull"
pass = passFull
case "passnumber"
pass = passNumber
case "passspecial"
pass = passSpecial
case "passcharnumber"
pass = passCharNumber
case "passchar"
pass = passChar
case "passupperchar"
pass = passUpperChar
case "passlowerchar"
pass = passLowerChar
case "passuppercharnumber"
pass = passUpperCharNumber
case "passlowercharnumber"
pass = passLowerCharNumber
case else
pass = passlowercharnumber
end select
makeRndPass=""

for ii=1 to cint(passlen)
randomize
jj = int(rnd()*len(pass)+1)
makeRndPass = cstr(makeRndPass) & mid(pass,jj,1)
next
end function

'004
'用途:读取指定的文本文件，返回文件内容
'参数:filepath(包含路径的文件名，支持虚拟路径),fileContent(文件内容)
'示例:response.write readfile("/abc.txt")
'编写:杨俊明 2006-2-8 13:10 QQ:278919507 Email:yjmyzz@126.com
'response.write readfile("/abc.txt")
function readFile(filepath)
readFile = ""
if instr(filepath,"/") then filepath = server.mappath(filepath)
Dim t_keyFile, t_fso, t_f ,ts
set t_fso = Server.CreateObject("Scripting.FileSystemObject")
if t_fso.fileexists(filepath) then
set t_f = t_fso.GetFile(filepath)
set ts = t_f.OpenAsTextStream(1, -2)
Do While not ts.AtEndOfStream
readFile = readFile & ts.ReadLine & vbcrlf
Loop
ts.close
end if
set ts = nothing
set t_f = nothing
set t_fso = nothing
end function

'005
'用途:将指定内容，写入文本文件
'参数:filepath(包含路径的文件名，支持虚拟路径),fileContent(文件内容)
'示例:WriteFile "/abc.txt","abcde" 或WriteFile "c:\abc.txt","abcde"
'编写:杨俊明 2006-2-8 13:10 QQ:278919507 Email:yjmyzz@126.com
'WriteFile "/abc.txt","abcde"
function WriteFile(filepath,fileContent)
dim t_fso,t_keyFile
if instr(filepath,"/") then filepath = server.mappath(filepath)
set t_fso = Server.CreateObject("scripting.FileSystemObject")
set t_keyFile = t_fso.CreateTextFile(filepath, true)
t_keyFile.WriteLine(fileContent)
t_keyFile.Close
set t_keyfile = nothing
set t_fso = nothing
end function

'006
'用途:删除指定文件
'参数:filepath(包含路径的文件名，支持虚拟路径),fileContent(文件内容)
'示例:delFile "/abc.txt"
'编写:杨俊明 2006-2-8 13:21 QQ:278919507 Email:yjmyzz@126.com
'delFile "/abc.txt"
function DelFile(filepath)
dim t_fso
if instr(filepath,"/") then filepath = server.mappath(filepath)
set t_fso = Server.CreateObject("scripting.FileSystemObject")
if t_fso.fileExists(filepath) then
t_fso.deletefile(filepath)
end if
set t_fso=nothing
end function
%>