ASP常用函数

最新推荐文章于 2025-04-17 11:14:16 发布

bzmuwei

最新推荐文章于 2025-04-17 11:14:16 发布

阅读量817

点赞数

分类专栏： ASP 文章标签： asp function stylesheet class javascript email

ASP 专栏收录该内容

6 篇文章

订阅专栏

转自：http://blog.youkuaiyun.com/df35wedge/archive/2006/07/05/879097.aspx

<%
function htmlencode2(str)
dim result
dim l
if isNULL(str) then
htmlencode2=""
exit function
end if
l=len(str)
result=""
dim i
for i = 1 to l
select case mid(str,i,1)
case "<"
result=result+"<"
case ">"
result=result+">"
case chr(13)
result=result+"<br>"
case chr(34)
result=result+"""
case "&"
result=result+"&"
case chr(32)
'result=result+" "
if i+1<=l and i-1>0 then
if mid(str,i+1,1)=chr(32) or mid(str,i+1,1)=chr(9) or mid(str,i-1,1)=chr(32) or mid(str,i-1,1)=chr(9) then
result=result+" "
else
result=result+" "
end if
else
result=result+" "
end if
case chr(9)
result=result+" "
case else
result=result+mid(str,i,1)
end select
next
htmlencode2=result
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," "," "),""",chr(34)),">",">"),"<","<")
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," "," "),chr(34),"""),">",">"),"<","<")
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

'***********************************************
'过程名：showpage
'作用：显示“上一页下一页”等信息
'参数：sfilename ----链接地址
'       totalnumber ----总数量
'       maxperpage ----每页数量
'       ShowTotal   ----是否显示总数量
'       ShowAllPages ---是否用下拉列表显示所有页面以供跳转。有某些页面不能使用，否则会出现JS错误。
'       strUnit     ----计数单位
'***********************************************
sub showpage(sfilename,totalnumber,maxperpage,ShowTotal,ShowAllPages,strUnit)
dim n, i,strTemp,strUrl
if totalnumber mod maxperpage=0 then
    n= totalnumber / maxperpage
else
    n= totalnumber / maxperpage+1
end if
strTemp= "<table align='center'><form name='showpages' method='Post' action='" & sfilename & "'><tr><td>"
if ShowTotal=true then
  strTemp=strTemp & "共 <b>" & totalnumber & "</b> " & strUnit & "  "
end if
strUrl=JoinChar(sfilename)
if CurrentPage<2 then
      strTemp=strTemp & "首页上一页 "
else
      strTemp=strTemp & "<a href='" & strUrl & "page=1'>首页</a> "
      strTemp=strTemp & "<a href='" & strUrl & "page=" & (CurrentPage-1) & "'>上一页</a> "
end if

if n-currentpage<1 then
      strTemp=strTemp & "下一页尾页"
else
      strTemp=strTemp & "<a href='" & strUrl & "page=" & (CurrentPage+1) & "'>下一页</a> "
      strTemp=strTemp & "<a href='" & strUrl & "page=" & n & "'>尾页</a>"
end if
   strTemp=strTemp & " 页次：<strong><font color=red>" & CurrentPage & "</font>/" & n & "</strong>页 "
    strTemp=strTemp & " <b>" & maxperpage & "</b>" & strUnit & "/页"
if ShowAllPages=True then
  strTemp=strTemp & " 转到：<select name='page' size='1' οnchange='javascript:submit()'>"
    for i = 1 to n
      strTemp=strTemp & "<option value='" & i & "'"
   if cint(CurrentPage)=cint(i) then strTemp=strTemp & " selected "
   strTemp=strTemp & ">第" & i & "页</option>"
     next
  strTemp=strTemp & "</select>"
end if
strTemp=strTemp & "</td></tr></form></table>"
response.write strTemp
end sub

'********************************************
'函数名：IsValidEmail
'作用：检查Email地址合法性
'参数：email ----要检查的Email地址
'返回值：True ----Email地址合法
'       False ----Email地址不合法
'********************************************
function IsValidEmail(email)
dim names, name, i, c
IsValidEmail = true
names = Split(email, "@")
if UBound(names) <> 1 then
    IsValidEmail = false
    exit function
end if
for each name in names
  if Len(name) <= 0 then
   IsValidEmail = false
      exit function
  end if
  for i = 1 to Len(name)
      c = Lcase(Mid(name, i, 1))
   if InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 and not IsNumeric(c) then
         IsValidEmail = false
         exit function
       end if
    next
    if Left(name, 1) = "." or Right(name, 1) = "." then
       IsValidEmail = false
       exit function
    end if
next
if InStr(names(1), ".") <= 0 then
  IsValidEmail = false
    exit function
end if
i = Len(names(1)) - InStrRev(names(1), ".")
if i <> 2 and i <> 3 then
    IsValidEmail = false
    exit function
end if
if InStr(email, "..") > 0 then
    IsValidEmail = false
end if
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

'**************************************************
'函数名：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+1
            end if
        next
        strLength=t
    else
        strLength=len(str)
    end if
    if err.number<>0 then err.clear
end function

'****************************************************
'函数名：SendMail
'作用：用Jmail组件发送邮件
'参数：ServerAddress ----服务器地址
'        AddRecipient ----收信人地址
'        Subject       ----主题
'        Body          ----信件内容
'        Sender        ----发信人地址
'****************************************************
function SendMail(MailServerAddress,AddRecipient,Subject,Body,Sender,MailFrom)
on error resume next
Dim JMail
Set JMail=Server.CreateObject("JMail.SMTPMail")
if err then
  SendMail= "<br><li>没有安装JMail组件</li>"
  err.clear
  exit function
end if
JMail.Logging=True
JMail.Charset="gb2312"
JMail.ContentType = "text/html"
JMail.ServerAddress=MailServerAddress
JMail.AddRecipient=AddRecipient
JMail.Subject=Subject
JMail.Body=MailBody
JMail.Sender=Sender
JMail.From = MailFrom
JMail.Priority=1
JMail.Execute
Set JMail=nothing
if err then
  SendMail=err.description
  err.clear
else
  SendMail="OK"
end if
end function

'****************************************************
'过程名：WriteErrMsg
'作用：显示错误提示信息
'参数：无
'****************************************************
sub WriteErrMsg()
dim strErr
strErr=strErr & "<html><head><title>错误信息</title><meta http-equiv='Content-Type' content='text/html; charset=gb2312'>" & vbcrlf
strErr=strErr & "<link href='style.css' rel='stylesheet' type='text/css'></head><body>" & vbcrlf
strErr=strErr & "<table cellpadding=2 cellspacing=2 border=0 width=400 class='border' align=center>" & vbcrlf
strErr=strErr & " <tr align='center'><td height='20' class='title'><strong>错误信息</strong></td></tr>" & vbcrlf
strErr=strErr & " <tr><td height='100' class='tdbg' valign='top'><b>产生错误的可能原因：</b><br>" & errmsg &"</td></tr>" & vbcrlf
strErr=strErr & " <tr align='center'><td class='title'><a href='javascript:history.go(-1)'>【返回】</a></td></tr>" & vbcrlf
strErr=strErr & "</table>" & vbcrlf
strErr=strErr & "</body></html>" & vbcrlf
response.write strErr
end sub

'****************************************************
'过程名：WriteSuccessMsg
'作用：显示成功提示信息
'参数：无
'****************************************************
sub WriteSuccessMsg(SuccessMsg)
dim strSuccess
strSuccess=strSuccess & "<html><head><title>成功信息</title><meta http-equiv='Content-Type' content='text/html; charset=gb2312'>" & vbcrlf
strSuccess=strSuccess & "<link href='style.css' rel='stylesheet' type='text/css'></head><body>" & vbcrlf
strSuccess=strSuccess & "<table cellpadding=2 cellspacing=2 border=0 width=400 class='border' align=center>" & vbcrlf
strSuccess=strSuccess & " <tr align='center'><td height='20' class='title'><strong>恭喜你！</strong></td></tr>" & vbcrlf
strSuccess=strSuccess & " <tr><td height='100' class='tdbg' valign='top'><br>" & SuccessMsg &"</td></tr>" & vbcrlf
strSuccess=strSuccess & " <tr align='center'><td class='title'><a href='javascript:history.go(-1)'>【返回】</a></td></tr>" & vbcrlf
strSuccess=strSuccess & "</table>" & vbcrlf
strSuccess=strSuccess & "</body></html>" & vbcrlf
response.write strSuccess
end sub

function dvHTMLEncode(fString)
if not isnull(fString) then
fString = replace(fString, ">", ">")
fString = replace(fString, "<", "<")

    fString = Replace(fString, CHR(32), " ")
    fString = Replace(fString, CHR(9), " ")
    fString = Replace(fString, CHR(34), """)
    fString = Replace(fString, CHR(39), "'")
    fString = Replace(fString, CHR(13), "")
    fString = Replace(fString, CHR(10) & CHR(10), "</P><P> ")
    fString = Replace(fString, CHR(10), "<BR> ")

dvHTMLEncode = fString
end if
end function

function dvHTMLEncode(fString)
if not isnull(fString) then
fString = replace(fString, ">",">")
fString = replace(fString, "<","<")

    fString = Replace(fString, " ",CHR(32))
    fString = Replace(fString, " ", CHR(9))
    fString = Replace(fString, """,CHR(34))
    fString = Replace(fString, "'",CHR(39))
    fString = Replace(fString, "",CHR(13))
    fString = Replace(fString, "</P><P> ",CHR(10) & CHR(10))
    fString = Replace(fString, "<BR> ",CHR(10))

dvHTMLEncode = fString
end if
end function

function nohtml(str)
    dim re
    Set re=new RegExp
    re.IgnoreCase =true
    re.Global=True
    re.Pattern="(/<.[^/<]*/>)"
    str=re.replace(str," ")
    re.Pattern="(/<//[^/<]*/>)"
    str=re.replace(str," ")
    nohtml=str
    set re=nothing
end function