ASP 常用自写函数

<%
'*************************************************
'函数名：HTMLEncode
'作  用：用于输出的字符串，将文本格式转为HTML格式
'参  数：str   ----原字符串
'返回值：格式后的字符串
'*************************************************
Function HTMLEncode(Str)
if str<>"" then
Str=Replace(Str,"<","&lt;")
Str=Replace(Str,">","&gt;")
Str=Replace(Str," ","&nbsp;")
Str=Replace(Str,Chr(10),"<br>")
HTMLEncode=Str
end if
End Function

'*************************************************
'函数名：HTMLEncode
'作  用：用于输出的字符串，将HTML格式转为文本格式
'参  数：str   ----原字符串
'返回值：格式后的字符串
'*************************************************
Function HTMLEncode(Str)
if str<>"" then
Str=Replace(Str,"&lt;","<")
Str=Replace(Str,"&gt;",">")
Str=Replace(Str,"&nbsp;"," ")
Str=Replace(Str,"<br>",Chr(10))
HTMLEncode=Str
end if
End Function

'*************************************************
'函数名：GetSafeStr
'作  用：得到安全字符串,'防止SQL注入
'****************************************************

Function GetSafeStr(ParaName,ParaType)
       '--- 传入参数 ---
       'ParaName:参数名称-字符型
       'ParaType:参数类型-数字型(1表示以上参数是数字，0表示以上参数为字符)
if ParaName<>"" then
    If ParaType=1 then
              If not isNumeric(ParaName) then
       GetSafeStr=0
            'response.write("<script language='javascript'>")
                     'Response.write "alert('非法操作！')"
      'response.Write("/script>")
                     'Response.end
     else
     GetSafeStr=ParaName
              End if
       Else
              ParaName=trim(ParaName)
     ParaName=replace(ParaName,"'","’")
     ParaName=replace(ParaName,";","；")
     ParaName=replace(ParaName,",","，")
     ParaName=replace(ParaName,"/"," ")
     ParaName=replace(ParaName,"%","")    
              ParaName=replace(ParaName,"<","&lt;")
           ParaName=replace(ParaName,">","&gt;")
           ParaName=replace(ParaName," ","&nbsp;")
     ParaName=replace(ParaName,Chr(10),"<br>")
     GetSafeStr=ParaName
       End if
else
       GetSafeStr=ParaName
end if
End function

'*************************************************
'函数名：IsSafeStr
'作  用：判断是否安全字符串,在注册登录等特殊字段中使用
'参  数：str   ----原字符串
'返回值：true,false
'*************************************************
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

'*************************************************
'函数名：gotTopic
'作  用：截字符串，汉字一个算两个字符，英文算一个字符
'参  数：str   ----原字符串
'       strlen ----截取长度
'返回值：截取后的字符串
'*************************************************
function gotTopic(str,strlen)
if str="" then
 gotTopic=""
else
 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 if
end function

' ============================================
'函数名：IsSelfRefer
'作  用：检测上页是否从本站提交
'返回值: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

'**************************************************
'函数名：Get_TrueLen
'作  用：求字符串实际长度。汉字算两个字符，英文算一个字符。
'参  数：str  ----求长度的字符串
'返回值：字符串长度
'**************************************************

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

'********************************************
'函数名：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

 if InStr(email, "..") > 0 then
    IsValidEmail = false
 end if
end function

'********************************************
'函数名：FormatTime
'作  用 格式化时间(显示)
' 参数：-----n_Flag 1-5
' 1:"yyyy-mm-dd hh:mm:ss"
' 2:"yyyy-mm-dd"
' 3:"hh:mm:ss"
' 4:"yyyy年mm月dd日"
' 5:"yyyymmdd"
' -------s_Time 时间
'********************************************
Function FormatTime(s_Time, n_Flag)
Dim y, m, d, h, mi, s
FormatTime = ""
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
FormatTime = y & "-" & m & "-" & d & " " & h & ":" & mi & ":" & s
Case 2
' yyyy-mm-dd
FormatTime = y & "-" & m & "-" & d
Case 3
' hh:mm:ss
FormatTime = h & ":" & mi & ":" & s
Case 4
' yyyy年mm月dd日
FormatTime = y & "年" & m & "月" & d & "日"
Case 5
' yyyymmdd
FormatTime = y & m & d
End Select
End Function

'***************************************************
'函数名：isFilename
'作  用：判断文件名是否合法
'参  数：aFilename ----文件名
'返回值：true,false
'***************************************************
Function isFilename(aFilename)
  Dim sErrorStr,iNameLength,i
  isFilename=TRUE
  sErrorStr=Array("/","/",":","*","?","""","<",">","|")
  iNameLength=Len(aFilename)
  If iNameLength<1 Or iNameLength=null Then
  isFilename=FALSE
  Else
  For i=0 To 8
  If instr(aFilename,sErrorStr(i)) Then
  isFilename=FALSE
  End If
  Next
  End If
End Function

'***************************************************
'函数名：CheckCardId
'作  用：检查身份证号码
'参  数：e ----身份证号码
'返回值：错误信息，若正确值无反映
'***************************************************
Function CheckCardId(e)
arrVerifyCode = Split("1,0,x,9,8,7,6,5,4,3,2", ",")
Wi = Split("7,9,10,5,8,4,2,1,6,3,7,9,10,5,8,4,2", ",")
Checker = Split("1,9,8,7,6,5,4,3,2,1,1", ",")

If Len(e) < 15 Or Len(e) = 16 Or Len(e) = 17 Or Len(e) > 18 Then
CheckCardId= "身份证号共有 15 码或18位"
CheckCardId = False
Exit Function
End If

Dim Ai
If Len(e) = 18 Then
Ai = Mid(e, 1, 17)
ElseIf Len(e) = 15 Then
Ai = e
Ai = Left(Ai, 6) & "19" & Mid(Ai, 7, 9)
End If
If Not IsNumeric(Ai) Then
CheckCardId= "身份证除最后一位外，必须为数字！"

Exit Function
End If
Dim strYear, strMonth, strDay
strYear = CInt(Mid(Ai, 7, 4))
strMonth = CInt(Mid(Ai, 11, 2))
strDay = CInt(Mid(Ai, 13, 2))
BirthDay = Trim(strYear) + "-" + Trim(strMonth) + "-" + Trim(strDay)
If IsDate(BirthDay) Then
If DateDiff("yyyy",Now,BirthDay) <-140 or cdate(BirthDay)> date() Then

CheckCardId= "身份证输入错误！"
Exit Function
End If
If strMonth > 12 Or strDay > 31 Then
CheckCardId= "身份证输入错误！"
Exit Function
End If
Else
CheckCardId= "身份证输入错误！"
Exit Function
End If
Dim i, TotalmulAiWi
For i = 0 To 16
TotalmulAiWi = TotalmulAiWi + CInt(Mid(Ai, i + 1, 1)) * Wi(i)
Next
Dim modValue
modValue = TotalmulAiWi Mod 11
Dim strVerifyCode
strVerifyCode = arrVerifyCode(modValue)
Ai = Ai & strVerifyCode
CheckCardId = Ai

If Len(e) = 18 And e <> Ai Then
CheckCardId= "身份证号码输入错误！"
Exit Function
End If
End Function

'***************************************************
'函数名：MyRandc
'作  用：生成随机字符
'参  数：n 为字符的个数
'返回值：随机字符
'***************************************************
function MyRandc(n)
   dim thechr
   thechr = ""
   for i=1 to n
       dim zNum,zNum2
       Randomize
       zNum = cint(25*Rnd)
       zNum2 = cint(10*Rnd)
       if zNum2 mod 2 = 0 then
           zNum = zNum + 97
       else
           zNum = zNum + 65
       end if
       thechr = thechr & chr(zNum)
   next
   MyRandc = thechr
end function

'***************************************************
'函数名：MyRandn
'作  用：生成随机数字
'参  数：n 为数字的个数
'返回值：随机数字
'***************************************************
function MyRandn(n)
   dim thechr
   thechr = ""
   for i=1 to n
       dim zNum,zNum2
       Randomize
       zNum = cint(9*Rnd)
       zNum = zNum + 48
       thechr = thechr & chr(zNum)
   next
   MyRandn = thechr
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

 

'****************************************************
'过程名：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)'>&lt;&lt; 返回上一页</a></td></tr>" & vbcrlf
 'strErr=strErr & "</table>" & vbcrlf
 'strErr=strErr & "</body></html>" & vbcrlf
 'response.write strErr

%>

<br />
<br />
<table width="400" height="237" border="1" align="center" cellpadding="5" cellspacing="0" bordercolor="#FAA401" bordercolordark="#FFFFFF" background="../images/ER044_L.jpg" bgcolor="#FDF0C6">
  <tr>
    <th height="30" bgcolor="#FDCE6C"><span style="color:#FF0000; font-size:14px">出 错 啦！</span></th>
  </tr>
  <tr>
    <td height="205" align="center"><table width="96%" height="180" border="0" align="center" cellpadding="0" cellspacing="0" style="line-height:2">
        <tr>
          <td align="center"style="color:#3366FF; font-size:14px"><%=errmsg%></td>
        </tr>
        <tr>
          <td height="20" align="center"style="color:#FF0000; font-size:14px"><a href='javascript:history.go(-1)' style="font-size:12px;">返回上一页</a></td>
        </tr>
      </table>
      </td>
  </tr>
</table>

<%

 response.end
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='css.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:window.close()'>【关 闭】</a></td></tr>" & vbcrlf
 strSuccess=strSuccess & "</table>" & vbcrlf
 strSuccess=strSuccess & "</body></html>" & vbcrlf
 response.write strSuccess
end sub

'***********************************************
'过程名：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 & "&nbsp;&nbsp;"
 end if
 strUrl=JoinChar(sfilename)
   if CurrentPage<2 then
      strTemp=strTemp & "首页 上一页&nbsp;"
   else
      strTemp=strTemp & "<a href='" & strUrl & "page=1'>首页</a>&nbsp;"
      strTemp=strTemp & "<a href='" & strUrl & "page=" & (CurrentPage-1) & "'>上一页</a>&nbsp;"
   end if

   if n-currentpage<1 then
      strTemp=strTemp & "下一页 尾页"
   else
      strTemp=strTemp & "<a href='" & strUrl & "page=" & (CurrentPage+1) & "'>下一页</a>&nbsp;"
      strTemp=strTemp & "<a href='" & strUrl & "page=" & n & "'>尾页</a>"
   end if
    strTemp=strTemp & "&nbsp;页次：<strong><font color=red>" & CurrentPage & "</font>/" & n & "</strong>页 "
    strTemp=strTemp & "&nbsp;<b>" & maxperpage & "</b>" & strUnit & "/页"
 if ShowAllPages=True then
  strTemp=strTemp & "&nbsp;转到：<select name='page' size='1' onchange='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

'****************************************************
'CDONTS.NewMail 邮件发送
'****************************************************
function SendMail2(mailfrom,mailto,mailsubject,mailbody)
 
Set  mail  =  Server.CreateObject("CDONTS.NewMail")
mail.To  =  mailto
mail.From  =  "[e-mail]"
mail.Subject  =  mailsubject
mail.Body  =  mailbody
Mail.Send
 
 'Set mail = Server.CreateObject("CDONTS.NewMail")
 'mail.to = mailto
 'mail.From = mailfrom
 'mail.Subject = mailsubject
 'mail.Body = mailbody
 'mail.Send
end function

'****************************************************
'jmail发信
'****************************************************
function SendMail (FriendEmail,title,bodystr)
Set jmail = Server.CreateObject("JMAIL.Message")   '建立发送邮件的对象
     jmail.silent = true    '屏蔽例外错误，返回FALSE跟TRUE两值j
     jmail.logging = true   '启用邮件日志
     jmail.Charset = "GB2312"     '邮件的文字编码为国标
     jmail.ContentType = "text/html"    '邮件的格式为HTML格式
  jmail.MailServerUserName = "[e-mail]"     '登录邮件服务器所需的用户名
     jmail.MailServerPassword = "webmaster"     '登录邮件服务器所需的密码
     jmail.AddRecipient (FriendEmail)     '邮件收件人的地址
     jmail.From = "[e-mail]"   '发件人的E-MAIL地址
  jmail.FromName = "模具采购网"   ' 发送者姓名
     jmail.Subject = title ' 邮件主题
     jmail.Body = bodystr      '邮件的内容
     JMail.Priority = 1     '邮件的紧急程序，1 为最快，5 为最慢， 3 为默认值
     jmail.Send("mail.abc.com")     '执行邮件发送（通过邮件服务器地址）
     jmail.Close()   '关闭对象
end function

 
'****************************************************
'文件删除函数
'****************************************************
Function deletefile(filename)
if filename<>"" then
 filename=server.mappath(filename)
 set fso=server.CreateObject("scripting.filesystemobject")
 if fso.FileExists(filename) then
  fso.DeleteFile filename
 'else
  'Response.Write "<script language=JavaScript>alert(' 该文件不存在 ');< /script>"
 end if
end if
End Function

'删除文件夹
'strfile=server.MapPath("fileName")
'deletefile(strfile)
%>