我的实用代码收集

来源：互联网发布：日语杂志知乎编辑：程序博客网时间：2024/04/30 22:39

<%
dim BadWords
BadWords="考,Fuck"

'用于信息过滤
Public Function HTMLEncode(strFilter)
If Not IsNull(strFilter) Then
strFilter = replace(strFilter, ">", ">")
strFilter = replace(strFilter, "<", "<")
strFilter = Replace(strFilter, CHR(32), " ") ' 
strFilter = Replace(strFilter, CHR(9), " ") ' 
strFilter = Replace(strFilter, CHR(34), """)
'strFilter = Replace(strFilter, CHR(39), "'") '单引号过滤
strFilter = Replace(strFilter, CHR(13), "")
strFilter = Replace(strFilter, CHR(10) & CHR(10), "</P><P> ")
strFilter = Replace(strFilter, CHR(10), "<BR> ")
'strFilter=ChkBadWords(strFilter)
HTMLEncode = strFilter
End If
End Function

''脏话过虑
Public Function ChkBadWords(strBad)
If IsNull(strBad) Then Exit Function
Dim i
BadWords=split(BadWords,",")
For i = 0 To UBound(BadWords)
If InStr(strBad,BadWords(i))>0 Then
strBad = Replace(strBad,BadWords(i),"***")
End If
Next
ChkBadWords = strBad
End Function

' 获得用户真实IP
Public Function RealIP()
RealIP=Request.ServerVariables("http_x_forwarded_for")
if RealIP="" or Isnull(RealIP) then RealIP=Request.ServerVariables("remote_addr")
End Function

'检验字符串
Public Function Checkstr(Str)
If Isnull(Str) Then CheckStr = "" :Exit Function
Str = Replace(Str,Chr(0),"")
CheckStr = Replace(Str,"'","''")
End Function

==============================================

Function strLen(Str) ' 获得字符串的长度, 配合下面的CutStr(Str,LenNum)
If Trim(Str)="" Or IsNull(str) Then Exit Function
Dim P_len,x
P_len=0
StrLen=0
P_len=Len(Trim(Str))
For x=1 To P_len
If Asc(Mid(Str,x,1))<0 Then ' Asc 返回与字符串的第一个字母对应的 ANSI 字符代码
StrLen=Int(StrLen) + 2
Else
StrLen=Int(StrLen) + 1
End If
Next
End Function

Function CutStr(Str,LenNum) ' 截取相应的字符串
Dim P_num
Dim I,X
If StrLen(Str)<=LenNum Then
Cutstr=Str
Else
P_num=0
X=0
Do While Not P_num > LenNum-2
X=X+1
If Asc(Mid(Str,X,1))<0 Then
P_num=Int(P_num) + 2
Else
P_num=Int(P_num) + 1
End If
Cutstr=Left(Trim(Str),X)&"..."
Loop
End If
End Function

'================================================
' 函数名：RelativePath2RootPath
' 作用：转为根路径格式
' 参数：url ----原URL
' 返回值：转换后的URL
'================================================
Function RelativePath2RootPath(url)
Dim sTempUrl
sTempUrl = url
If Left(sTempUrl, 1) = "/" Then
RelativePath2RootPath = sTempUrl
Exit Function
End If

Dim sFilePath
sFilePath = Request.ServerVariables("SCRIPT_NAME")
sFilePath = Left(sFilePath, InstrRev(sFilePath, "/") - 1)
Do While Left(sTempUrl, 3) = "../"
sTempUrl = Mid(sTempUrl, 4)
sFilePath = Left(sFilePath, InstrRev(sFilePath, "/") - 1)
Loop
RelativePath2RootPath = sFilePath & "/" & sTempUrl
End Function
'================================================
' 函数名：RootPath2DomainPath
' 作用：根路径转为带域名全路径格式
' 参数：url ----原URL
' 返回值：转换后的URL
'================================================
Function RootPath2DomainPath(url)
Dim sHost, sPort
sHost = Split(LCase(Request.ServerVariables("SERVER_PROTOCOL")), "/")(0) & "://" & Request.ServerVariables("HTTP_HOST")
sPort = Request.ServerVariables("SERVER_PORT")
If sPort <> "80" Then
sHost = sHost & ":" & sPort
End If
RootPath2DomainPath = sHost & url
End Function
'================================================
' 函数名：CreatePath 必须有FSO
' 作用：CreatePath("UploadImg/") 按月份自动创建文件夹
' 参数：fromPath ----原文件夹路径
'================================================

Function CreatePath(fromPath)
dim objFso,uploadpath
uploadpath = Year(Now) & "-" & Month(Now) '以年月创建上传文件夹，格式：2005-8
On Error Resume Next
Set objFso = CreateObject("Scripting.FileSystemObject")
If objFso.FolderExists(Server.MapPath(fromPath & uploadpath)) = False Then
objFSO.CreateFolder Server.MapPath(fromPath & uploadpath)
End If
If Err.Number = 0 Then
CreatePath =fromPath & uploadpath & "/"
Else
CreatePath = ""
End If
set objFso=nothing
End Function

'================================================
'过程名：PreventRefresh
'作用：防止刷新页面
'================================================
Sub PreventRefresh()
Dim RefreshTime,isRefresh
RefreshTime = 10 '防止刷新时间,单位（秒）
isRefresh = 1 '是否使用防刷新功能，0=否，1=是
If isRefresh = 1 Then
If (Not IsEmpty(Session("RefreshTime"))) And RefreshTime > 0 Then
If DateDiff("s", Session("RefreshTime"), Now()) < RefreshTime Then
Response.Write "<META http-equiv=Content-Type content=text/html; chaRset=gb2312><meta HTTP-EQUIV=REFRESH CONTENT="&RefreshTime&"><br>本页面起用了防刷新机制，请不要在"&RefreshTime&"秒内连续刷新本页面<BR>正在打开页面，请稍后……"
Response.End
Else
Session("RefreshTime") = Now()
End If
Else
Session("RefreshTime") = Now()
End If
End If
End Sub

Function Html2Ubb(str)
If Str<>"" And Not IsNull(Str) Then
Dim re,tmpstr
Set re=new RegExp
re.IgnoreCase =True
re.Global=True
re.Pattern = "(<STRONG>)":Str = re.Replace(Str,"<b>")
re.Pattern = "(<//STRONG>)":Str = re.Replace(Str,"</b>")
re.Pattern ="(<TBODY>)":Str = re.Replace(Str,"")
re.Pattern ="(<//TBODY>)":Str = re.Replace(Str,"")
re.Pattern ="(<TABLE)":Str = re.Replace(Str,"<table")
re.Pattern ="(TABLE>)":Str = re.Replace(Str,"table>")
re.Pattern ="(<TR)":Str = re.Replace(Str,"<tr")
re.Pattern ="(TR>)":Str = re.Replace(Str,"tr>")
re.Pattern ="(<TD)":Str = re.Replace(Str,"<td")
re.Pattern ="(TD>)":Str = re.Replace(Str,"td>")
re.Pattern ="(<DIV)":Str = re.Replace(Str,"<div")
re.Pattern ="(Div>)":Str = re.Replace(Str,"div>")
re.Pattern ="(<IMG )":Str = re.Replace(Str,"<img ")
re.Pattern ="(<BR)":Str = re.Replace(Str,"<br")
re.Pattern ="(<A )":Str = re.Replace(Str,"<a ")
re.Pattern ="(<//A>)":Str = re.Replace(Str,"</a>")
re.Pattern ="(<FONT )":Str = re.Replace(Str,"<font ")
re.Pattern ="(<//FONT>)":Str = re.Replace(Str,"</font>")
re.Pattern = "(<s+cript(.+?)<//s+cript>)":Str = re.Replace(Str, "")
re.Pattern ="(/{)":Str = re.Replace(Str,"{")
re.Pattern ="(/})":Str = re.Replace(Str,"}")
re.Pattern ="(/$)":Str = re.Replace(Str,"$")
re.Pattern = "(<div(.+?)>)":Str = re.replace(Str,"<div>")
re.Pattern = "(<span(.+?)>)":Str = re.replace(Str,"<span>")
Set Re=Nothing
Html2Ubb = Str
Else
Html2Ubb = ""
End If
End Function

'================================================
'作用：读取图片或者FLASH
'参数：url ----文件URL
' height ----高度
' width ----宽度
'================================================
Function GetFlashAndPic(url,height,width)
Dim sExtName,ExtName,strTemp
sExtName = Split(url, ".")
ExtName = sExtName(UBound(sExtName))
If LCase(ExtName) = "swf" Then
strTemp = "<embed src=""" & url & """ width=" & width & " height=" & height & ">"
Else
strTemp = "<img src=""" & url & """ width=" & width & " height=" & height & " border=0>"
End If
GetFlashAndPic = strTemp
End Function
%>

<%
' 取随机文件名
Function GetRndFileName(sExt)
Dim sRnd
Randomize
sRnd = Int(900 * Rnd) + 100
GetRndFileName = day(now) & hour(now) & minute(now) & second(now) & sRnd & "." & sExt
End Function

' ============================================
' 格式化时间(显示)
' 参数：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

[Code]
<%
'--------------------------------- Author information -------------------------------------------------------------
'File : Function.asp

'-----------------------------------------------------------------------------------------------------------------
'----有返回函数的类型的相关函数集合
'
''~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

'''----------------------------------------------------------------↓转换字符串为数字，无法转换时结果为0
Public Function GetNum(iStr)
Dim s
s=Trim(""&iStr)
If IsNumeric(s) Then GetNum=Clng(s) Else GetNum=0 End If
End Function

'''----------------------------------------------------------------↓过虑用户提交的Get类型字符串
Public Function GetStr(Str)
If Isnull(Str) Then
GetStr = ""
Exit Function
End If
Str = Replace(Str,Chr(0),"")
GetStr = Replace(Str,"'","''")
End Function

'''----------------------------------------------------------------↓ 获得用户IP
Public Function GetIp()
dim vip
vip=Request.ServerVariables("http_x_forwarded_for")
if vip="" or Isnull(vip) then vip=Request.ServerVariables("remote_addr")
GetIp=vip
End Function

'''----------------------------------------------------------------↓过滤26个引起搜索溢出的日文片假名
Public Function EncodeJP(StrHTML)
If StrHTML<>"" Then
StrHTML=Trim(StrHTML)
StrHTML=Replace(StrHTML,"ガ","ガ")
StrHTML=Replace(StrHTML,"ギ","ギ")
StrHTML=Replace(StrHTML,"グ","ア")
StrHTML=Replace(StrHTML,"ゲ","ゲ")
StrHTML=Replace(StrHTML,"ゴ","ゴ")
StrHTML=Replace(StrHTML,"ザ","ザ")
StrHTML=Replace(StrHTML,"ジ","ジ")
StrHTML=Replace(StrHTML,"ズ","ズ")
StrHTML=Replace(StrHTML,"ゼ","ゼ")
StrHTML=Replace(StrHTML,"ゾ","ゾ")
StrHTML=Replace(StrHTML,"ダ","ダ")
StrHTML=Replace(StrHTML,"ヂ","ヂ")
StrHTML=Replace(StrHTML,"ヅ","ヅ")
StrHTML=Replace(StrHTML,"デ","デ")
StrHTML=Replace(StrHTML,"ド","ド")
StrHTML=Replace(StrHTML,"バ","バ")
StrHTML=Replace(StrHTML,"パ","パ")
StrHTML=Replace(StrHTML,"ビ","ビ")
StrHTML=Replace(StrHTML,"ピ","ピ")
StrHTML=Replace(StrHTML,"ブ","ブ")
StrHTML=Replace(StrHTML,"ブ","ブ")
StrHTML=Replace(StrHTML,"プ","プ")
StrHTML=Replace(StrHTML,"ベ","ベ")
StrHTML=Replace(StrHTML,"ペ","ペ")
StrHTML=Replace(StrHTML,"ボ","ボ")
StrHTML=Replace(StrHTML,"ポ","ポ")
StrHTML=Replace(StrHTML,"ヴ","ヴ")
End If
EncodeJP=StrHTML
End Function

'''----------------------------------------------------------------↓过滤HTML/UBB以纯文本显示，带长度参数
Public Function FormatHTML(HtmCode,HtmLen)
If HtmCode<>"" Then
Dim RegX
Set RegX = new RegExp
RegX.IgnoreCase = True
RegX.Global = True
RegX.Pattern = "<(a|select|option|script|style|title)(.*?)>((.| )*?)</(a|select|option|script|style|title)>"
HtmCode = RegX.Replace(HtmCode, " ")
RegX.Pattern = "&(lt|gt|nbsp|quot|copy);"
HtmCode = RegX.Replace(HtmCode, " ")
RegX.Pattern = "<[^>]*>"
HtmCode = RegX.Replace(HtmCode, "")
RegX.Pattern = "/[(img)(.*?)/]((.| )*?)/[/(img)/]"
HtmCode = RegX.Replace(HtmCode, " ")
RegX.Pattern = "/[[^/]]*/]"
HtmCode = RegX.Replace(HtmCode, " ")
HtmCode = Replace(HtmCode,Chr(13)&Chr(10)," ")
RegX.Pattern = "^http://[^ <>]+)"
HtmCode = RegX.Replace(HtmCode, "")
RegX.Pattern = "(　|~|～|`|｀)"
HtmCode = RegX.Replace(HtmCode, " ")
Set RegX=Nothing
FormatHTML = CutStr(HtmCode,HtmLen)
Else
FormatHTML = ""
End If
End Function

'''----------------------------------------------------------------↓过滤HTML左右标签
Public Function UnHTML(Code)
UnHTML = RTrim(Code)
If UnHTML<>Empty Then
UnHTML=Replace(UnHTML,"<","<")
UnHTML=Replace(UnHTML,">",">")
End If
End Function

'''----------------------------------------------------------------↓截取字符串特定长度
Public Function CutStr(Str,StrLen)
CutStr = Trim(Str)
If Len(CutStr)>=StrLen Then CutStr=Left(CutStr,StrLen-1)&"..."
End Function

'''----------------------------------------------------------------↓转换数据库数据为发布时的格式
Public Function HTMLEncode(str)
If Isnull(str) then Exit Function
str = Replace(str,CHR(38),"&") '&
str = Replace(str,CHR(32),"  ") ' 
str = Replace(str,CHR(39),"'")
str = Replace(str,CHR(36),"$")
str = Replace(str, CHR(34),""")
str = Replace(str,">",">")
str = Replace(str,"<","<")
str = Replace(str, CHR(13), "")
str = Replace(str, CHR(9), "        ") '&TAB
str = Replace(str, CHR(10) & CHR(10), "</P><P> ")
str = Replace(str, CHR(10), "<BR> ")
HTMLEncode = str
End Function

'''----------------------------------------------------------------↓简化条件判断
Public Function IIf(ByVal blnBool,ByVal strStr1,ByVal strStr2)
If blnBool Then IIf=strStr1 Else IIf=strStr2 End If
End Function

'''----------------------------------------------------------------↓通过时返回用户名，否则返回为空,传参过虑为Chr1|Chr2|Chr3
Public Function IsPass(ByVal str,ByVal arr)
Dim s,arrChr,i
s=str
arrChr=Split(arr,"|")
For i=0 to Ubound(arrChr)
If Instr(s,arrChr(i))>0 Then
Ispass=""
Exit Function
End If
Next
IsPass=s
End Function

%>
[/Code]