整理一些我经常用到的函数吧（不断更新）

'**********************************************************************************************
'函数名称: strReplace(Str)
'函数功能: 过滤单引号
'参数说明: Str 
'**********************************************************************************************
Function strReplace(Str)
 dim tempcheckstr
 tempcheckstr=Str
 If Isnull(tempcheckstr) Then
  strReplace = ""
  Exit Function
 End If
 strReplace = Replace(tempcheckstr,"'","''")
End Function

'**********************************************************************************************
'函数名称: Alert(showType,str,url)
'函数功能: 弹出对话框
'参数说明: showType  显示类别  1  返回上一页面   2 转到另一页面   3  关闭窗口 
'          str       错误信息
'          url       转向地址
'**********************************************************************************************
sub Alert(showType,str,url)
    response.Write("<script language=""javascript"">"& vbcrlf)
 response.Write("<!--"& vbcrlf)
 response.Write("window.alert("""& str &""");"& vbcrlf)
     if showType=1 then
      response.Write("window.history.go(-1); "& vbcrlf)
     elseif showType=2 then
     response.Write("window.location.href ="""& url &"""; "& vbcrlf)
     elseif showType=3 then
  response.Write("window.opener=null; "& vbcrlf)
      response.Write("window.close(); "& vbcrlf)
  elseif showType=4 then
     response.Write("top.location.href ="""& url &"""; "& vbcrlf)
     end if
 response.Write("//-->"& vbcrlf)
 response.Write("</script>")
end sub

'**********************************************************************************************
'函数名称: ZeroFill(Num,Num_Length)
'函数功能: 前面补0
'参数说明: Num              要操作的数字     
'          Num_Length       显示的位数
'返回值  : 格式化的字符串
'**********************************************************************************************
Function ZeroFill(Num,Num_Length)
 Dim ZeroFill_i,ZeroFill_ReturnNum
 For ZeroFill_i=len(Num) To Num_Length-1
  ZeroFill_ReturnNum=ZeroFill_ReturnNum&"0"
 Next
 ZeroFill_ReturnNum=ZeroFill_ReturnNum&Num
 ZeroFill=ZeroFill_ReturnNum
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
 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

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

function show(str,i)
  if strLength(str) > i then
     show = left(str,i)&"..."
  else
     show = str
  end if
end function

 

' ============================================
'函数名：RemoveHTML
'作  用：去除HTML标签
'参  数：strHTML ----文章内容
'返回值：替换后的内容
' ============================================
Function RemoveHTML(strHTML)
  Dim objRegExp, Match, Matches
  Set objRegExp = New Regexp

  objRegExp.IgnoreCase = True
  objRegExp.Global = True
  '取闭合的<>
  objRegExp.Pattern = "<.+?>"
  '进行匹配
  Set Matches = objRegExp.Execute(strHTML)

 ' 遍历匹配集合，并替换掉匹配的项目
  For Each Match in Matches
    strHtml=Replace(strHTML,Match.Value,"")
  Next
  RemoveHTML=strHTML
  Set objRegExp = Nothing
End Function

'-----------------------本函数为远程获取内容的函数，URL即为网页地址，asp页面也行-----
Function GetBody(url)
Set Retrieval = CreateObject("Microsoft.XMLHTTP")
With Retrieval
.Open "Get", url, False, "", ""
.Send
GetBody = .ResponseBody
End With
End Function

'--------------------------内码处理的函数，否则发送的邮件可能是乱码
Function BytesToBstr(strBody,CodeBase)
        dim objStream
        set objStream = Server.CreateObject("Adodb.Stream")
        objStream.Type = 1
        objStream.Mode =3
        objStream.Open
        objStream.Write strBody
        objStream.Position = 0
        objStream.Type = 2
        objStream.Charset = CodeBase
        BytesToBstr = objStream.ReadText 
        objStream.Close
        set objStream = nothing
End Function

 

'***********************************************
'函数名：getPicUrl
'作  用：获得信息里的图片地址
'参  数：str  ----信息
'***********************************************
function getPicUrl(str)
    dim content,regstr,url
 content=str&""
 regstr="src=.+?.(gif|jpg)"
 url=Replace(Replace(Replace(RegExp_Execute(regstr,content),"'",""),"""",""),"src=","")
 getPicUrl=url
end function

 

Function RegExp_Execute(patrn, strng)
Dim regEx, Match, Matches,values '建立变量。
Set regEx = New RegExp '建立正则表达式。
regEx.Pattern = patrn '设置模式。
regEx.IgnoreCase = true '设置是否区分字符大小写。
regEx.Global = True '设置全局可用性。
Set Matches = regEx.Execute(strng) '执行搜索。
For Each Match in Matches '遍历匹配集合。
values=values&Match.Value&","
Next
RegExp_Execute = values
End Function

 

''发送电子邮件函数
'siteEmail             发送方邮箱
'smtp                  邮箱主机地址
'emailUserName         邮箱用户名
'emailUserPWD          邮箱密码
'inceptEmail           接受邮件的邮箱地址
'sendName              发送人的名称
'sendTitle             邮件标题
'sendContent           邮件正文
sub EmailSend(siteEmail,smtp,emailUserName,emailUserPWD,inceptEmail,sendName,sendTitle,sendContent)
  dim jmail
  set jmail = CreateObject ("jmail.message") ''创建对象
  jmail.Silent = true ''一般不用改
  jmail.Charset = "gb2312" ''信件的语言编码
  jmail.ContentType = "text/html" ''信件的格式html或纯文本
  jmail.From = siteEmail ''发信人邮箱
  jmail.FromName = sendName ''发信人姓名
  jmail.Subject = sendTitle ''信件主题
  jmail.AddRecipient inceptEmail ''收信人地址
  jmail.Body = sendContent ''信件正文
  jmail.MailServerUserName = emailUserName ''服务器登陆用户名(您的邮件地址)
  jmail.MailServerPassWord = emailUserPWD ''服务器登陆密码(您的邮件密码)
  jmail.Send(smtp) ''服务器地址
  jmail.Close
  set jmail = nothing
end sub

 

'=========================================================
'利用AspJpeg将图片上传后按比例缩放。同时改变文件大小
'http://www.jinhuo.cn/club/archiver/t_7167.html
'http://space.flash8.net/space/html/33/337333_itemid_280395.html
'=========================================================
Function PicEdit(PicName,PicModeWidth,PicModeHeight)
    dim PP,W,H,scale,firstW,firstH,ModeScale,EndH,EndW
 Set PP=New ImgWHInfo 
 W = PP.imgW(Server.Mappath(PicName))    ''原图片宽度
 H = PP.imgH(Server.Mappath(PicName))    ''原图片高度
 
     Dim n_OriginalWidth, n_OriginalHeight '原图片宽度、高度
     Dim n_BuildWidth, n_BuildHeight '缩略图宽度、高度
     Dim div1, div2
     Dim n1, n2
     n_OriginalWidth = PP.imgW(Server.Mappath(PicName))
     n_OriginalHeight = PP.imgH(Server.Mappath(PicName))
     div1 = n_OriginalWidth / n_OriginalHeight
     div2 = n_OriginalHeight / n_OriginalWidth
     n1 = 0
     n2 = 0
     If n_OriginalWidth > PicModeWidth Then
         n1 = n_OriginalWidth / PicModeWidth
     Else
         n_BuildWidth = n_OriginalWidth
     End If
     If n_OriginalHeight > PicModeHeight Then
         n2 = n_OriginalHeight / PicModeHeight
     Else
         n_BuildHeight = n_OriginalHeight
     End If
     If n1 <> 0 Or n2 <> 0 Then
         If n1 > n2 Then
             n_BuildWidth = PicModeWidth
             n_BuildHeight = PicModeWidth * div2
         Else
             n_BuildWidth = PicModeHeight * div1
             n_BuildHeight = PicModeHeight
         End If
     End If

 

 Set PP = nothing
 dim Jpeg,Path
 Set Jpeg = Server.CreateObject("Persits.Jpeg")
 Path = Server.MapPath(PicName)
 Jpeg.open Path
 'Jpeg.Width = EndW
 'Jpeg.Height = EndH
 
 Jpeg.Width = n_BuildWidth
 Jpeg.Height = n_BuildHeight
 Jpeg.Save Server.MapPath(PicName)
 Jpeg.Close:Set Jpeg = Nothing
End Function

 

'判断ip是否合法
function chk_ip(strIP)
    dim boolIsIP
    dim arrIP boolIsIP = True '函数初始值为true
    arrIP = split(strIP, ".") '将输入的IP用"."分割为数组，数组下标从0开始，所以有效IP分割后的数组上界必须为3
    if ubound(arrIP)<>3 then
        boolIsIP = False
    else
        for intLoop = 0 to ubound(arrIP)
            if not isnumeric(arrIP(intLoop)) then '检查数组元素中各项是否为数字，如果不是则不是有效IP
                boolIsIP = False
            else
                if arrIP(intLoop)>255 or arrIP(intLoop)<0 then '检查IP数字是否满足IP的取值范围
                    boolIsIP = False
                end if
            end if
        next
    end if
    chk_ip = boolIsIp
end function