ASP自定义函数集

踏浪行歌

'========取得带端口的URL，推荐使用=========
Function Get_ScriptNameUrl()
If request.servervariables("SERVER_PORT")="80" Then
Get_ScriptNameUrl="http://" & request.servervariables("server_name")&lcase(request.servervariables("script_name"))
Else
Get_ScriptNameUrl="http://" & request.servervariables("server_name")&":"&request.servervariables("SERVER_PORT")&lcase(request.servervariables("script_name"))
End If
End Function



'=========用正则表达式突出显示字符串中查询到的单词的函数=========
Function BoldWord(strContent,word)
If word="" Then
BoldWord = strContent
Exit Function
End IF
dim objRegExp
Set objRegExp=new RegExp
objRegExp.IgnoreCase =true
objRegExp.Global=True

objRegExp.Pattern="(" & word & ")"
strContent=objRegExp.Replace(strContent,"<font color=""#FF0000""><b>$1</b></font>" )

Set objRegExp=Nothing
BoldWord=strContent
End Function



'==========取得用户当前IP地址==========
Function GetIP()
uIP = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
If uIP = "" Then uIP = Request.ServerVariables("REMOTE_ADDR")
GetIp = uIP
End Function

'===========取得当前程序脚本路径=============
Function GetScriptName()
ScriptAddress = CStr(Request.ServerVariables("SCRIPT_NAME"))'取得当前地址
If (Request.QueryString <> "") Then
ScriptAddress = ScriptAddress & "?" & Server.HTMLEncode(Request.QueryString)'取得带参数地址
End If
If Len(ScriptAddress)>250 Then ScriptAddress = Left(ScirptAddress,250)&"..." '进行路径截取，最大为250个字符
GetScriptName = ScriptAddress
End Function




'========返回带参数的Url，多关键字排序时使用==========
' RemoveList 参数：需要从Url中去除的参数，可以是多个，中间请用逗号隔开
Function KeepUrlStr(RemoveList)
ScriptAddress = CStr(Request.ServerVariables("SCRIPT_NAME"))&"?"'取得当前地址,并加入“?”符号
M_ItemUrl = ""
For Each M_item In Request.QueryString
If InStr(RemoveList,M_Item)=0 Then
M_ItemUrl = M_ItemUrl & M_Item &"="& Server.URLEncode(Request.QueryString(""&M_Item&"")) & "&"
End If
Next
KeepUrlStr = ScriptAddress & M_ItemUrl
End Function

'==========过滤HTML代码===========
Function FilterHTML(strToFilter)
Dim strTemp
strTemp = strToFilter
While Instr(1,strTemp,"<") AND Instr(1, strTemp, ">")
strTemp = Left(strTemp, Instr(1, strTemp, "<")-1) & Right(strTemp, Len(strTemp)-Instr(1,strTemp, ">"))
WEnd
FilterHTML = strTemp
End Function

' 以下为常用函数
' ********************************************
' ============================================
' 错误返回处理
' ============================================
Sub Go_Error(str)
Call DBConnEnd()
 Response.Write "<script language=javascript>alert('" & str & "\n\n系统将自动返回前一页面...');history.back();</script>"
 Response.End
End Sub

' ============================================
' 格式化时间(显示)
' 参数：n_Flag
' 1:"yyyy-mm-dd hh:mm:ss"
' 2:"yyyy-mm-dd"
' 3:"hh:mm:ss"
' 4:"yyyy年mm月dd日"
' 5:"yyyymmdd"
' ============================================
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
 End Select
End Function

' ============================================
' 把字符串进行HTML解码,替换server.htmlencode
' 去除Html格式，用于显示输出
' ============================================
Function outHTML(str)
 Dim sTemp
 sTemp = str
 outHTML = ""
 If IsNull(sTemp) = True Then
  Exit Function
 End If
 sTemp = Replace(sTemp, "&", "&amp;")
 sTemp = Replace(sTemp, "<", "&lt;")
 sTemp = Replace(sTemp, ">", "&gt;")
 sTemp = Replace(sTemp, Chr(34), "&quot;")
 sTemp = Replace(sTemp, Chr(10), "<br>")
 outHTML = sTemp
End Function

' ============================================
' 去除Html格式，用于从数据库中取出值填入输入框时
' 注意：value="?"这边一定要用双引号
' ============================================
Function inHTML(str)
 Dim sTemp
 sTemp = str
 inHTML = ""
 If IsNull(sTemp) = True Then
  Exit Function
 End If
 sTemp = Replace(sTemp, "&", "&amp;")
 sTemp = Replace(sTemp, "<", "&lt;")
 sTemp = Replace(sTemp, ">", "&gt;")
 sTemp = Replace(sTemp, Chr(34), "&quot;")
 inHTML = sTemp
End Function

' ============================================
' 检测上页是否从本站提交
' 返回: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

' ============================================
' 得到安全字符串,在查询中使用
' ============================================
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

'排除重复的字符串 
    Function GetNotRepeat(ByVal ArrList As ArrayList) As ArrayList
        Dim i As Integer : Dim TmpArrayList As New ArrayList
        For i = 0 To ArrList.Count - 1
            If Not TmpArrayList.Contains(ArrList(i)) Then
                TmpArrayList.Add(ArrList(i))
            End If
        Next
        Return TmpArrayList
    End Function

'根据文本文件获得每行字符串的数组

    Function GetLineStrByTxtFile(ByVal txtFileName As String) As ArrayList

        Dim fs As IO.FileStream = New IO.FileStream(txtFileName, IO.FileMode.Open, IO.FileAccess.Read)

        Dim sr As IO.StreamReader = New IO.StreamReader(fs, System.Text.Encoding.GetEncoding("GB2312"))

        Dim ArrayStr As Array = sr.ReadToEnd().Split(vbCrLf)

        Dim i As Integer : Dim tmList As New ArrayList

        For i = 0 To ArrayStr.Length - 1

            tmList.Add(ArrayStr.GetValue(i))

        Next

        fs.Close() : Return tmList

    End Function

'生成图象验证码函数

    Sub ValidateCode(ByVal VNum As String)

        Dim Img As System.Drawing.Bitmap

        Dim g As Graphics

        Dim ms As System.IO.MemoryStream

        'gheight为图片宽度,根据字符长度自动更改图片宽度

        Dim gheight As Integer = Int(Len(VNum) * 11.5)

        '创建一个宽度已定，高度为20的图像

        Img = New Bitmap(gheight, 20)

        g = Graphics.FromImage(Img)

        '在矩形内绘制字串（字串，字体，画笔颜色，左上x.左上y）

        g.DrawString(VNum, (New Font("宋体", 12)), (New SolidBrush(Color.Blue)), 3, 3)

        ms = New System.IO.MemoryStream

        Img.Save(ms, System.Drawing.Imaging.ImageFormat.Png)

        Response.ClearContent() '需要输出图象信息 要修改HTTP头

        Response.ContentType = "image/Png"

        Response.BinaryWrite(ms.ToArray())

        g.Dispose()

        Img.Dispose()

        Response.End()

    End Sub $ Y' _6 i. P* U



'将身份证从15位升级为18位的函数

    Function GetNewIDCard(ByVal IDCard As String) As String

        Dim i, S As Integer

        Dim Wi() As String = Split("7,9,10,5,8,4,2,1,6,3,7,9,10,5,8,4,2,1", ",")

        Dim Wf() As String = Split("1,0,X,9,8,7,6,5,4,3,2", ",")

        If Mid(IDCard, 7, 2) >= Mid(Now.AddYears(-14).Year, 3, 2) Then

            IDCard = Mid(IDCard, 1, 6) & "18" & Mid(IDCard, 7, 9)

        Else

            IDCard = Mid(IDCard, 1, 6) & "19" & Mid(IDCard, 7, 9)

        End If

        For i = 0 To 16

            S += Wi(i) * Mid(IDCard, i + 1, 1)

        Next

        Return IDCard & Wf(S Mod 11)

    End Function %>

<%
'===========================
转换字符串带有http://的超级链接字符串为真正的超级链接
'===========================
Function LinkURLs(strInput)
iCurrentLocation = 1
Do While InStr(iCurrentLocation, strInput, "http://", 1) <> 0
iLinkStart = InStr(iCurrentLocation, strInput, "http://", 1)
iLinkEnd = InStr(iLinkStart, strInput, " ", 1)
If iLinkEnd = 0 Then iLinkEnd = Len(strInput) + 1
Select Case Mid(strInput, iLinkEnd - 1, 1)
Case ".", "!", "?"
iLinkEnd = iLinkEnd - 1
End Select
strOutput = strOutput & Mid(strInput, iCurrentLocation, iLinkStart - iCurrentLocation)
strLinkText = Mid(strInput, iLinkStart, iLinkEnd - iLinkStart)
strOutput = strOutput & "<a href="""&strLinkText&""">"&strLinkText&"</a>"
iCurrentLocation = iLinkEnd
Loop
strOutput = strOutput & Mid(strInput, iCurrentLocation)
LinkURLs = strOutput
End Function
strUnlinked = "http://LINE9.com rules! <br>" & vbCrLf
strUnlinked = strUnlinked & "http://pdxpc.com sells great computers!<br>" & vbCrLf

' Here is the before text:
Response.Write "<b>Original Text:</b><br>" & vbCrLf
Response.Write strUnlinked
Response.Write vbCrLf & "<br>" & vbCrLf & vbCrLf

' Here is the text after it gets automatically hyperlinked to itself:
Response.Write "<b>Text After Linking:</b><br>" & vbCrLf
Response.Write LinkURLs(strUnlinked)
%>

<%
''***************************************************
''************函数功能：去掉函数参数中的HTML标记
''***************************************************
Function stripHTML(strtext)
dim arysplit,i,j, strOutput

arysplit=split(strtext,"<")
if len(arysplit(0))>0 then j=1 else j=0
for i=j to ubound(arysplit)
  if instr(arysplit(i),">") then
   arysplit(i)=mid(arysplit(i),instr(arysplit(i),">")+1)
  else
   arysplit(i)="<" & arysplit(i)
  end if
next

strOutput = join(arysplit, "")
strOutput = mid(strOutput, 2-j)
strOutput = replace(strOutput,">",">")
strOutput = replace(strOutput,"<","<")

stripHTML = strOutput
End Function
''************************************************
''**应用方法：StripHTML("string")，其中，string为要去掉HTML标记的字符串
''************************************************
%>

<%
'===========================
'函数功能：去掉函数参数中的HTML标记
'===========================
Function stripHTML(strHTML)
  'Strips the HTML tags from strHTML

Dim objRegExp, strOutput
Set objRegExp = New Regexp

objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "<.+?>"

  'Replace all HTML tag matches with the empty string
strOutput = objRegExp.Replace(strHTML, "")

  'Replace all < and > with < and >
strOutput = Replace(strOutput, "<", "<")
strOutput = Replace(strOutput, ">", ">")

stripHTML = strOutput 'Return the value of strOutput

Set objRegExp = Nothing
End Function
''****************************************************
''**应用方法：StripHTML("string")，其中，string为要去掉HTML标记的字符串
''****************************************************
%>

<%
'===========================
'函数功能：去掉函数参数中的HTML标记
'===========================
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
%>