网页ASP函数大全(摘选)

<%
'***********************************
'功能描述：将日期转换成指定的显示格式
'入口参数：
 'dtDateValue 想显示的日期
 'iDateFormat 日期显示的方式

 'iDataFormat=0 2000-10-10 下午 12:17:45
 'iDataFormat=1 2000-10-10 23:17:45
 'iDataFormat=2 2000-10-10 23:45
 'iDataFormat=3 00-10-10 23:45
 'iDataFormat=4 10-10 23:45
 'iDataFormat=5 2000-10-10
 'iDataFormat=6 00-10-10
 'iDataFormat=7 10-10
 'iDataFormat=8 2000年10月10日
'出口参数：转换后的日期格式
'函数作者：徐仪
'修改时间：2002-9-3
'***********************************

Public Function FormatDT(dtDateValue, iDateFormat)

 Dim nowdate, y, m, d, h, i, s, t, APM, hAPM

 y = Year(dtDateValue)
 m = Month(dtDateValue)
 d = Day(dtDateValue)
 h = Hour(dtDateValue)
 i = Minute(dtDateValue)
 s = Second(dtDateValue)

 IF h > 12 Then
  APM = "下午 "
  hAPM = CStr(CInt(h) Mod 12)
 Else
  APM = "上午 "
  hAPM = h
 End IF
   
 Select Case iDateFormat
  Case 0
   FormatDT = y & "-" & m & "-" & d & " " & APM & hAPM & ":" & i & ":" & s
  Case 1
   FormatDT = y & "-" & m & "-" & d & " " & h & ":" & i & ":" & s
  Case 2
   FormatDT = y & "-" & m & "-" & d & " " & h & ":" & i
  Case 3
   FormatDT = Right(y, 2) & "-" & m & "-" & d & " " & h & ":" & i
  Case 4
   FormatDT = m & "-" & d & " " & h & ":" & i
  Case 5
   FormatDT = y & "-" & m & "-" & d
  Case 6
   FormatDT = Right(y, 2) & "-" & m & "-" & d
  Case 7
   FormatDT = m & "-" & d
  Case 8
   FormatDT = y & "年" & m & "月" & d & "日"
 End Select
    
End Function

'***********************************
'功能描述：将文字转化为用于适合网页显示的格式
'入口参数：
 'sStr 需要转换的字符串
'出口参数：转换后的字符串

'函数作者：徐仪
'修改时间：2002-9-3
'***********************************

Public Function HtmlOut(sStr)

 IF isnull(sStr) or sStr="" Then
  htmlOut=sStr
  exit Function
 End IF

 sStr=Replace(sStr,"  ","　")
 sStr=Replace(sStr," ","`nbsp;")     

 '   sStr=server.asplencode(sStr)
 sStr=Replace(sStr,"nbsp;"," ")
 sStr=Replace(sStr,vbcrlf,"<BR>")
 sStr=Replace(sStr,vbTab," ") 
 '   HtmlOut="　　"&sStr
 HtmlOut=sStr
End Function

'***********************************
'功能描述：跳到用户指定的网页
'入口参数：
 'sHtmlUrl 跳转的新网页

'出口参数：无

'函数作者：徐仪
'修改时间：2002-9-3
'***********************************

Public Function URL(sHtmlUrl)
 
 Response.Write "<meta http-equiv='refresh' content='0; url="&sHtmlUrl&"'>"
 
End Function

'***********************************
'功能描述：显示用户给出的提示信息（弹出窗口）
'入口参数：
 'sMsg 显示日期

'出口参数：无

'函数作者：徐仪
'修改时间：2002-9-3
'***********************************

Public Function MsgBox(sMsg)
 
 Response.Write "<script language=JavaScript>{alert('提示："&sMsg&"！！');location.href = 'javascript:history.go(-1)';}</script>"
 Response.End

End Function

'***********************************
'功能描述：根据用户指定的日期生成对应的中文星期
'入口参数：
 'dtDateValue 显示日期

'出口参数：格式化后的中文星期

'函数作者：徐仪
'修改时间：2002-9-3
'***********************************

Public Function DispChinaWeek(dtDateValue)

 Select Case weekday(dtDateValue)
  Case "1" DispChinaWeek="星期日"
  Case "2" DispChinaWeek="星期一"
  Case "3" DispChinaWeek="星期二"
  Case "4" DispChinaWeek="星期三"
  Case "5" DispChinaWeek="星期四"
  Case "6" DispChinaWeek="星期五"
  Case "7" DispChinaWeek="星期六"
 End Select
 
End Function

'***********************************
'功能描述：在字符串的前或后的位置加上指定的重复的字符串
 '例： Response.Write FillChar("1",3,"0",1)
 '  输出结果 001
 
'入口参数：
 'sStr  要操作的字符串
 'iLen  填充后字符中的总长度
 'sMode  填充文字
 'iPosition 填充的位置 1：加在字符串前面 其他：加在字符串后面

'出口参数：无

'函数作者：徐仪
'修改时间：2002-9-3
'***********************************

Public Function FillChar(sStr,iLen,sFillChar,iPosition)
 if (sFillChar<>"") then
  sStr=trim(sStr)
  sStrLen=len(sStr)
  iAddLen=iLen - sStrLen
  IF (iAddLen<1) Then
   iAddLen=0
  End IF
  IF (iAddLen>=1) Then
   For i=1 to iAddLen
    AddsStr=AddsStr&sFillChar
   Next
  end IF
  
  IF (iPosition=1) Then
   sStr=AddsStr&sStr
  else
   sStr=sStr&AddsStr
  End IF
  FillChar=sStr
 else
  FillChar=sStr
 end if

End Function

'***********************************
'从数据库中提取内容生成下拉菜单
'Conn 为数据库联接
'table为表名
'style下接菜单样式
'column1显示的字段
'column2字段的值

Public Function makesqlSelect(name,sql,value,Conn,column1,column2)
 SET Re=Server.CreateObject("ADODB.Recordset")

 Re.Open sql,Conn,adOpenStatic, adLockReadOnly, adCmdText

 Response.Write ("<Select  Class=""Select"" name="&name&">")

 While Re.EOF<>true
  IF trim(re(""&column2&""))=trim(value) Then
   Selected=" Selected "
  else
   Selected=" "
  End IF
  Response.Write("<Option" & Selected & "value=""" & trim(re(""&column2&"")) & """>" & trim(re(""&column1&"")) & "</Option>")
  Re.MoveNext 
 wEnd
 SET Re=Nothing 
 Response.Write ("</Select>")
End Function

Function CheckValue(Title,CheckString,Mode,LengMin,LengMax)
 'Mode 说明
 '0 程序检查
 '1 （用户名） 数字、字母、下划线检查
 '2 （密码） 数字、字母检查
 '3 （电子邮件）
 '4 （网站） 
 '5 （电话） 数字中划线
 '6 （邮编） 数字检查
 CharNumDownLinePattern="[a-zA-Z0-9_-]"
 CharNumPattern="[a-zA-Z0-9]"
 EmailPattern="^(\w-)+(\.(\w-)+)*@(\w-)+(\.((\w-)*))*+\.[a-zA-Z]{2,3}$"
 HttpPattern="^[a-zA-z]+://(\w+(-\w+)*)(\.(\w+(-\w+)*))*(\?\S*)?$"
 PhonePattern="^[0-9]+[0-9-]+[0-9]"
 NumPattern="^[0-9]+[0-9]+[0-9]"
 CodePattern="^[0-9]+[0-9]+[0-9]"
 
 ErrLEndown=Title&" 的长度太短了！不能少于"&LengMin&"个字符！<BR>"
 ErrLenUp=Title&" 的长度太长了！不能超过"&LengMax&"个字符！<BR>"
 ErrEqual=Title&" 的长度必须是"&LengMax&"个字符！<BR>"
 ErrEmpty=Title&" 不能不写！<BR>"

 ErrCharNumDownLinePattern=Title&" 的格式错误！"&Title&"只能用字符、数字和下划线组成。<BR>"
 ErrCharNumPattern=Title&" 的格式错误！"&Title&"只能用字符和数字组成。<BR>"
 ErrEmail=Title&" 的格式错误！正确的格式应该是 yourname@domain.com ！<BR>"
 ErrHttp=Title&" 的格式错误！正确的格式应该是 www.yoursite.com ！<BR>"
 ErrPhone=Title&" 的格式错误！"&Title&"只能用数字和中划线组成。注：请不要使用全角的符号！也不要用（）号<BR>"
 ErrNum=Title&" 的格式错误！"&Title&"只能用数字组成。<BR>"
 ErrCode="请不要在 "&Title&" 的输入框中输入<"&"% 或 %"&">！<BR>"
 mode =int(mode)

 if (LengMin) and (LengMin<>LengMax) then
  if (len(CheckString)<LengMin) then
   if (LengMin<>1) then
    CheckMsg = CheckMsg& ErrLEndown
   else
    CheckMsg = CheckMsg& ErrEmpty
   End if
  End if
 End if

 if (LengMax) and (LengMin<>LengMax) then
  if (len(CheckString)>LengMax) then
   CheckMsg = CheckMsg& ErrLenUp
  End if
 End if

 if (LengMin=LengMax) and (LengMin<>0) then
  if (len(CheckString)<>LengMax) then
   CheckMsg = CheckMsg& ErrEqual
  End if
 End if

 Select Case Mode
  Case "1" Pattern=CharNumDownLinePattern
  Case "2" Pattern=CharNumPattern
  Case "3" Pattern=EmailPattern
  Case "4" Pattern=HttpPattern
  Case "5" Pattern=PhonePattern
  Case "6" Pattern=NumPattern
  Case Else Pattern=CodePattern
'  Case "7" week="星期六"
 End Select

 Dim re
 Set re = new RegExp
 re.IgnoreCase = false
 re.global = false
 re.Pattern = Pattern

 ErrMsgCheck=""
 if  (Not  re.Test(CheckString)) and (len(CheckString)>0) then
  Select Case Mode
   Case "1" ErrMsgCheck = ErrCharNumDownLinePattern
   Case "2" ErrMsgCheck = ErrCharNumPattern
   Case "3" ErrMsgCheck = ErrEmail
   Case "4" ErrMsgCheck = ErrHttp
   Case "5" ErrMsgCheck = ErrPhone
   Case "6" ErrMsgCheck = ErrNum
  End Select
 End if
 ErrMsg=ErrMsg&CheckMsg&ErrMsgCheck
End Function
'*********************************
'从数组中提取值生成列表
'name:控件名
'classname:样式名
'value1:传入的值
'Array_x:数组
'iStart:从第几项开始取值
'iEnd:到第几项止
'****************
function makeArraySelect(name,classname,value1,Array_x,iStart,iEnd)
 if classname<>"" then
  classname=" class="&classname
 end if
 response.Write("<select name="""&name&""" "&classname&">"&vbCrLf)
 for i=iStart to iEnd

  if i=value1 then
   selected=" selected "
  else
   selected=""
  end if
  response.Write("<option"&selected&" value="""&i&""">"&Array_x(i)&"</option>")
  
 next
 response.Write("</select>")
End function
'生成日期
Public Function MakeSelectDay (name,value)
 start_value=1
 End_value=31
 code="<select name="&name&" class=select >"
 for i=start_value to End_value
  if (value=i) then
   code=code&"<option value="&i&" SELECTED>"&i&"</option>"
  else
   code=code&"<option value="&i&">"&i&"</option>"
  End if
 next
  code=code&"</select>"
  Response.write code
End Function
'生成月份
Public Function MakeSelectMonth (name,value)
 start_value=1
 End_value=12
 code="<select name="&name&" class=select >"
 for i=start_value to End_value
  if (value=i) then
   code=code&"<option value="&i&" SELECTED>"&i&"</option>"
  else
   code=code&"<option value="&i&">"&i&"</option>"
  End if
 next
 
  code=code&"</select>"
  Response.write code
End Function
'生成年份的下拉菜单
'start_value，生成下拉中的开始年份
'End_value 生成下拉菜单中的结束年份
Public Function MakeSelectYear (name,value,start_value,End_value)
 code="<select name="&name&" size=1>"
 for i=start_value to End_value
  if (value=i) then
   code=code&"<option value="&i&" SELECTED>"&i&"</option>"
  else
   code=code&"<option value="&i&">"&i&"</option>"
  End if
 next
   code=code&"</select>"
 Response.write code
End Function

'*************************************************
'函数名：gotTopic
'作  用：截字符串，汉字一个算两个字符，英文算一个字符
'参  数：str   ----原字符串
'       strlen ----截取长度
'返回值：截取后的字符串
'*************************************************
function gotTopic(str,strlen)
 if str="" then
  gotTopic=""
  exit function
 end if
 dim l,t,c, i
 str=replace(replace(replace(replace(str,"&nbsp;"," "),"&quot;",chr(34)),"&gt;",">"),"&lt;","<")
 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
   gotTopic=left(str,i) & "…"
   exit for
  else
   gotTopic=str
  end if
 next
 gotTopic=replace(replace(replace(replace(gotTopic," ","&nbsp;"),chr(34),"&quot;"),">","&gt;"),"<","&lt;")
end function

'**************************************************
'函数名：strLength
'作  用：求字符串长度。汉字算两个字符，英文算一个字符。
'参  数：str  ----要求长度的字符串
'返回值：字符串长度
'**************************************************
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+2
   else
    t=t+1
            end if
        next
        strLength=t
    else
        strLength=len(str)
    end if
    if err.number<>0 then err.clear
end function

'***************************************************
'函数名：IsObjInstalled
'作  用：检查组件是否已经安装
'参  数：strClassString ----组件名
'返回值：True  ----已经安装
'       False ----没有安装
'***************************************************
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
'***********************************************
'函数名：JoinChar
'作  用：向地址中加入 ? 或 &
'参  数：strUrl  ----网址
'返回值：加了 ? 或 & 的网址
'***********************************************
function JoinChar(strUrl)
 if strUrl="" then
  JoinChar=""
  exit function
 end if
 if InStr(strUrl,"?")<len(strUrl) then
  if InStr(strUrl,"?")>1 then
   if InStr(strUrl,"&")<len(strUrl) then
    JoinChar=strUrl & "&"
   else
    JoinChar=strUrl
   end if
  else
   JoinChar=strUrl & "?"
  end if
 else
  JoinChar=strUrl
 end if
end function

Public Function AlertBack(Msg)
 Response.Write "<script language=JavaScript>{alert('提示："&Msg&"！');location.href = 'javascript:history.go(-1)';}</script>"
 Response.End
End Function

Public Function AlertBack2(Msg)
 Response.Write "<script language=JavaScript>{alert('提示："&Msg&"！');location.href = 'javascript:history.go(-2)';}</script>"
 Response.End
End Function

Public Function  UrlMsg(sHtmlUrl,Msg)
 if Msg<>"" then
 Response.Write "<script language=JavaScript>{alert('提示："&Msg&"！');}</script><meta http-equiv='refresh' content='0; url="&sHtmlUrl&"'>"
else
 Response.Write "<meta http-equiv='refresh' content='0; url="&sHtmlUrl&"'>"
end if
End Function

Public Function AlertClose(Msg)
 Response.Write "<script language=JavaScript>{alert('提示："&Msg&"！！');window.close();}</script>"
 Response.End
End Function

'*******************************************
'功能描述：判断字符串str2是否在str1中
'入口参数：
'str1，str2
'sign字符串分隔符
'出口参数：
'str2在str1中则返回true 否则返回false
'作者：梁忠光
'创建日期：2002-9-10
function str_in(str1,str2,sign)
 dim m_str
 if str1="" then
  str_in=false
  exit function 
 end if
 m_str=split(str1,sign)

 dim count
 count=0
 for count=0 to ubound(m_str)
  if str2=m_str(count) then
   exit for
  end if
 next
 if count>ubound(m_str) then
  str_in=false
 else
  str_in=true
 end if
 
end function

Public Function CloseParentWin(Msg)
 if Msg<>"" then
  Response.Write "<script language=JavaScript>{alert('提示:"&Msg&"！！');parent.window.close();window.returnValue=1;}</script>"
  Response.end
 else
  Response.Write "<script language=JavaScript>{parent.window.close();window.returnValue=1;}</script>"
  Response.end
 end if
End Function

Public Function MsgOut(Msg,href,mode)
 if mode=0 then
  Response.Write "<script language=JavaScript>{alert('提示:"&Msg&"！！');location.href = '"& href &"';}</script>"
  Response.end
 elseif mode=1 then
  Response.Write "<html><LINK href='../css/admin.css' rel=stylesheet type=text/css><meta http-equiv=Content-Type content=text/html; charset=gb2312><SCRIPT LANGUAGE=javascript>alert('" & Msg & " ');window.open('"  & href & "','_self'); </SCRIPT></html>"
 elseif mode=2 then
  Response.Write "<html><LINK href='../css/admin.css' rel=stylesheet type=text/css><meta http-equiv=Content-Type content=text/html; charset=gb2312><head><meta http-equiv=""Content-Type"" content=""text/html; charset=gb2312""></head>"
  Response.Write "<body><BR><BR><p align=""center"">" & Msg & "</p>"
  Response.Write "<p align=""center""><a href=""" & href & """>返回</a></p></body></html>"
 elseif mode=3 then
  Response.Write "<html><meta http-equiv=Content-Type content=text/html; charset=gb2312><head><meta http-equiv=""Content-Type"" content=""text/html; charset=gb2312""></head>"
  Response.Write "<body><BR><BR><p align=""center""><font color=#FF0000>" & Msg & "</font></p>"
  Response.Write "<p align=""center""><a href=""" & href & """>返回</a></p></body></html>" 
 End if
End Function

Sub ShowLastNext(PageCount,Page,Prop)
 Dim query, a, x, temp
 action = "http://" & Request.ServerVariables("HTTP_HOST") & Request.ServerVariables("SCRIPT_NAME")
 if page>1 then
  Response.Write("[<A HREF="&action&"?"&prop&"&"&"Page="&(Page-1)&" class='a1'>上一页</A>]" & vbCrLf)
 End if
 if page<pagecount then
  Response.Write("[<A HREF="&action&"?" & prop & "&" & "Page=" & (Page+1) & " class='a1'>下一页</A>] " & vbCrLf)
 End if
 Response.Write(" 第 " &page& " 页 " &  vbCrLf)
 Response.Write(" 共 " & pageCount & " 页" &  vbCrLf)
End Sub

Sub LastNextPage(pagecount,page,table_style,font_style,button_style)

 Dim query, a, x, temp
 action = "http://" & Request.ServerVariables("HTTP_HOST") & Request.ServerVariables("SCRIPT_NAME")

 query = Split(Request.ServerVariables("QUERY_STRING"), "&")
 For Each x In query
     a = Split(x, "=")
     If StrComp(a(0), "page", vbTextCompare) <> 0 Then
         temp = temp & a(0) & "=" & a(1) & "&"
     End If
 Next

 Response.Write("<table width=98% cellspacing=0 cellpadding=0 border=0 class='"&table_style&"'>" & vbCrLf )  
 Response.Write("<form method=get onsubmit=""document.location = '" & action & "?" & temp & "Page='+ this.page.value;return false;""><TR>" & vbCrLf )
 Response.Write("<TD align=right>" & vbCrLf )
 Response.Write(vbCrLf ) 
  
 if page<=1 then
  'Response.Write ("[第一页] " & vbCrLf)  
  'Response.Write ("[上一页] " & vbCrLf)
 else  
  Response.Write("[<A HREF=" & action & "?" & temp & "Page=1>第一页</A>] " & vbCrLf)
  Response.Write("[<A HREF=" & action & "?" & temp & "Page=" & (Page-1) & ">上一页</A>] " & vbCrLf)
 end if

 if page>=pagecount then
  'Response.Write ("[下一页] " & vbCrLf)
  'Response.Write ("[最后一页]" & vbCrLf)   
 else
  Response.Write("[<A HREF=" & action & "?" & temp & "Page=" & (Page+1) & ">下一页</A>] " & vbCrLf)
  Response.Write("[<A HREF=" & action & "?" & temp & "Page=" & pagecount & ">最后一页</A>]" & vbCrLf)   
 end if
  
 Response.Write(" 第" & "<INPUT Class='input' TYEP=TEXT NAME=page  SIZE=3 Maxlength=3 VALUE=" & page & ">" & "页"  & vbCrLf & "<INPUT type=submit Class='"&button_style&"' style=""font-size: 7pt""  value=GO>")
 Response.Write(" 共 " & pageCount & " 页" &  vbCrLf)   
 Response.Write("</TD>" & vbCrLf )    
 Response.Write("</TR></form>" & vbCrLf )  
 Response.Write("</table>" & vbCrLf )  
End Sub

Function NoCache()
 Response.Expires=0
 Response.ExpiresAbsolute = Now() - 1
 Response.AddHeader "Pragma","No-Cache"
 Response.AddHeader "Cache-Control","Private"
 Response.CacheControl = "No-Cache"
End Function

'插入日志文件
Function Insert_Log(Recorder,Operate,TableName,ModuleName)
 Conn.execute("insert into Wzjt_Log(Recorder,Operate,TableName,ModuleName,IP) values ('"&Recorder&"','"&Operate&"','"&TableName&"','"&ModuleName&"','"&Request.ServerVariables("LOCAL_ADDR")&"')")
End Function

Public Function Num(table,conn,inname,outname,value)
 sql3="select * from " & table &" where "&inname&"='"&value&"'"
 set re=server.createobject("adodb.recordset")
 re.open sql3,conn,1,1 
 if re.recordcount>0 then
  response.Write(re(outname)) 
 end if
 re.close
 set re=nothing
End function

Public Function ChangeSelect(sql,nodisplay,value,conn,name,display)
 Response.Write ("<select enabled=true name='"&name&"' onchange=""change(this.value)"">")
 set re=server.createobject("adodb.recordset")
 re.open sql,conn,1,1 
 if not (re.bof and re.eof) then
  response.write("<option value=""0"">--选择--</option>")
 else
  response.Write("<option value=""0"">目前没有分类</option>")
 end if
 while re.EOF<>true
  if trim(re(nodisplay))=trim(value) then
   selected=" selected "
  else
   selected=" "
  end if
  response.write("<option " & selected & " value=""" & trim(re(nodisplay)) & """>" & trim(re(display)) & "</option>")
  re.MoveNext 
 wend
 re.close
 set re=nothing
 Response.Write ("</select>")
End function

Public Function MakeSelect(sql,nodisplay,value,conn,name,display)
 Response.Write ("<select enabled=true name='"&name&"' class='input'>")
 set re=server.createobject("adodb.recordset")
 re.open sql,conn,1,1 
 if not (re.bof and re.eof) then
  response.write("<option value=""0"">--选择--</option>")
 else
  response.Write("<option value=""0"">目前没有分类</option>")
 end if
 while re.EOF<>true
  if trim(re(nodisplay))=trim(value) then
   selected=" selected "
  else
   selected=" "
  end if
  response.write("<option " & selected & " value=""" & trim(re(nodisplay)) & """>" & trim(re(display)) & "</option>")
  re.MoveNext 
 wend
 re.close
 set re=nothing
 Response.Write ("</select>")
End function

Public Function MsgCloseWin(Msg)
 Response.Write "<script language=JavaScript>{alert('提示:"&Msg&"！！');window.returnValue=1;window.close();}</script>"
 Response.end
End Function
%>