您的位置:首页 > 网络编程 > ASP

ASP自定义常用函数集合

日期:2006-08-18 15:07:17 点击: 来自: 作者:

'========取得带端口的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 & "nn系统将自动返回前一页面...');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

转换字符串带有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)
%>
'根据文本文件获得每行字符串的数组
    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



'将身份证从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 %>
<%
'===========================
<%
''***************************************************
''************函数功能:去掉函数参数中的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
%>
More..素材图片 Picture Navigation
ASP热门 Class Hot
ASP推荐 Class Commend
版权所有:中国网站资源 2005- 未经授权禁止复制或建立镜像 This Site Tech:XHTML+DIV+CSS+Javascript
CopyRight ® 2005- www.chinaddv.com online services. all rights reserved. ICP06016627
Optimized to 1024x768 to Firefox,Netscape,Opera,MS-IE6+.