ASP函数库

<%
'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:[e-mail] 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="/blog/>";")
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 = "[e-mail]"
'content = "欢迎访问中华印刷包装网!<br><a href=http://www.cpp114.com>www.cpp114.com</a><br>发送成功了，苍天啊，大地啊，不容易啊!"
'fromer = "[e-mail]"
'SerEmailUser = "[e-mail]"
'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 = "[e-mail]"
'sender = "我不是杨过"
'content = "您好，收到这封邮件，表示你今天会有好运气!<a href=http://www.baidu.com target=_blank>百度搜索</a>"
'fromer = "[e-mail]"
'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=in