【 tulaoshi.com - Web开发 】
%
'===============================================================
' Function For PJblog2
' 更新时间: 2006-6-2
'===============================================================
'*************************************
'防止外部提交
'*************************************
function ChkPost()
dim server_v1,server_v2
chkpost=false
server_v1=Cstr(Request.ServerVariables("HTTP_REFERER"))
server_v2=Cstr(Request.ServerVariables("SERVER_NAME"))
If Mid(server_v1,8,Len(server_v2))server_v2 then
chkpost=False
else
chkpost=True
end If
end function
'*************************************
'IP过滤
'*************************************
function MatchIP(IP)
on error resume next
MatchIP=false
Dim SIp,SplitIP
for each SIp in FilterIP
SIp=replace(SIp,"*","d*")
SplitIP=split(SIp,".")
Dim re, strMatchs,strIP
Set re=new RegExp
re.IgnoreCase =True
re.Global=True
re.Pattern="("&SplitIP(0)&"|)."&"("&SplitIP(1)&"|)."&"("&SplitIP(2)&"|)."&"("&SplitIP(3)&"|)"
Set strMatchs=re.Execute(IP)
strIP=strMatchs(0).SubMatches(0) & "." & strMatchs(0).SubMatches(1)& "." & strMatchs(0).SubMatches(2)& "." & strMatchs(0).SubMatches(3)
if strIP=IP then MatchIP=true:exit function
Set strMatchs=Nothing
Set re=Nothing
next
end function
'*************************************
'获得注册码
'*************************************
Function getcode()
getcode= "img src=""common/getcode.asp"" alt="""" style=""margin-right:40px;""/"
End Function
'*************************************
'限制上传文件类型
'*************************************
Function IsvalidFile(File_Type)
IsvalidFile = False
Dim GName
For Each GName in UP_FileType
If File_Type = GName Then
IsvalidFile = True
Exit For
End If
Next
End Function
'*************************************
'限制插件名称
'*************************************
Function IsvalidPlugins(Plugins_Name)
dim NoAllowNames,NoAllowName
NoAllowNames="user,bloginfo,calendar,comment,search,links,archive,category,contentlist"
NoAllowName=split(NoAllowNames,",")
IsvalidPlugins = true
Dim GName
Plugins_Name=trim(lcase(Plugins_Name))
For Each GName in NoAllowName
If Plugins_Name = GName Then
IsvalidPlugins = false
Exit For
End If
Next
End Function
'*************************************
'检测是否只包含英文和数字
'*************************************
Function IsValidChars(str)
Dim re,chkstr
Set re=new RegExp
re.IgnoreCase =true
re.Global=True
re.Pattern="[^_.a-zA-Zd]"
IsValidChars=True
chkstr=re.Replace(str,"")
if chkstrstr then IsValidChars=False
set re=nothing
End Function
'*************************************
'检测是否只包含英文和数字
'*************************************
Function IsvalidValue(ArrayN,Str)
IsvalidValue = false
Dim GName
For Each GName in ArrayN
If Str = GName Then
IsvalidValue = true
Exit For
End If
Next
End Function
'*************************************
'检测是否有效的数字
'*************************************
Function IsInteger(Para)
IsInteger=False
If Not (IsNull(Para) Or Trim(Para)="" Or Not IsNumeric(Para)) Then
IsInteger=True
End If
End Function
'*************************************
'用户名检测
'*************************************
Function IsValidUserName(byVal UserName)
on error resume next
Dim i,c
Dim VUserName
IsValidUserName = True
For i = 1 To Len(UserName)
c = Lcase(Mid(UserName, i, 1))
If InStr("$!?#^%@~`&*();:+='"" ", c) 0 Then
IsValidUserName = False
Exit Function
End IF
Next
For Each VUserName in Register_UserName
If UserName = VUserName Then
IsValidUserName = False
Exit For
End If
Next
End Function
'*************************************
'检测是否有效的E-mail地址
'*************************************
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
'*************************************
'加亮关键字
'*************************************
Function highlight(byVal strContent,byRef arrayWords)
Dim intCounter,strTemp,intPos,intTagLength,intKeyWordLength,bUpdate
if len(arrayWords)1 then highlight=strContent:exit function
For intPos = 1 to Len(strContent)
bUpdate = False
If Mid(strContent, intPos, 1) = "" Then
On Error Resume Next
intTagLength = (InStr(intPos, strContent, "", 1) - intPos)
if err then
highlight=strContent
err.clear
end if
strTemp = strTemp & Mid(strContent, intPos, intTagLength)
intPos = intPos + intTagLength
End If
If arrayWords "" Then
intKeyWordLength = Len(arrayWords)
If LCase(Mid(strContent, intPos, intKeyWordLength)) = LCase(arrayWords) Then
strTemp = strTemp & "span class=""high1""" & Mid(strContent, intPos, intKeyWordLength) & "/span"
intPos = intPos + intKeyWordLength - 1
bUpdate = True
End If
End If
If bUpdate = False Then
strTemp = strTemp & Mid(strContent, intPos, 1)
End If
Next
highlight = strTemp
End Function
'*************************************
'过滤超链接
'*************************************
Function checkURL(ByVal ChkStr)
Dim str:str=ChkStr
str=Trim(str)
If IsNull(str) Then
checkURL = ""
Exit Function
End If
Dim re
Set re=new RegExp
re.IgnoreCase =True
re.Global=True
re.Pattern="(d)(ocument.cookie)"
Str = re.replace(Str,"$1ocument cookie")
re.Pattern="(d)(ocument.write)"
Str = re.replace(Str,"$1ocument write")
re.Pattern="(s)(cript:)"
Str = re.replace(Str,"$1cript ")
re.Pattern="(s)(cript)"
Str = re.replace(Str,"$1cript")
re.Pattern="(o)(bject)"
Str = re.replace(Str,"$1bject")
re.Pattern="(a)(pplet)"
Str = re.replace(Str,"$1pplet")
re.Pattern="(e)(mbed)"
Str = re.replace(Str,"$1mbed")
Set re=Nothing
Str = Replace(Str, "", "")
Str = Replace(Str, "", "")
checkURL=Str
end function
'*************************************
'过滤文件名字
'*************************************
Function FixName(UpFileExt)
If IsEmpty(UpFileExt) Then Exit Function
FixName = Ucase(UpFileExt)
FixName = Replace(FixName,Chr(0),"")
FixName = Replace(FixName,".","")
FixName = Replace(FixName,"ASP","")
FixName = Replace(FixName,"ASA","")
FixName = Replace(FixName,"ASPX","")
FixName = Replace(FixName,"CER","")
FixName = Replace(FixName,"CDX","")
FixName = Replace(FixName,"HTR","")
End Function
'*************************************
'过滤特殊字符
'*************************************
Function CheckStr(byVal ChkStr)
Dim Str:Str=ChkStr
If IsNull(Str) Then
CheckStr = ""
Exit Function
End If
Str = Replace(Str, "&", "&")
Str = Replace(Str,"'","'")
Str = Replace(Str,"""",""")
Dim re
Set re=new RegExp
re.IgnoreCase =True
re.Global=True
re.Pattern="(w)(here)"
Str = re.replace(Str,"$1here")
re.Pattern="(s)(elect)"
Str = re.replace(Str,"$1elect")
re.Pattern="(i)(nsert)"
Str = re.replace(Str,"$1nsert")
re.Pattern="(c)(reate)"
Str = re.replace(Str,"$1reate")
re.Pattern="(d)(rop)"
Str = re.replace(Str,"$1rop")
re.Pattern="(a)(lter)"
Str = re.replace(Str,"$1lter")
re.Pattern="(d)(elete)"
Str = re.replace(Str,"$1elete")
re.Pattern="(u)(pdate)"
Str = re.replace(Str,"$1pdate")
re.Pattern="(s)(or)"
Str = re.replace(Str,"$1or")
Set re=Nothing
CheckStr=Str
End Function
'*************************************
'恢复特殊字符
'*************************************
Function UnCheckStr(ByVal Str)
If IsNull(Str) Then
UnCheckStr = ""
Exit Function
End If
Str = Replace(Str,"'","'")
Str = Replace(Str,""","""")
Dim re
Set re=new RegExp
re.IgnoreCase =True
re.Global=True
re.Pattern="(w)(here)"
str = re.replace(str,"$1here")
re.Pattern="(s)(elect)"
str = re.replace(str,"$1elect")
re.Pattern="(i)(nsert)"
str = re.replace(str,"$1nsert")
re.Pattern="(c)(reate)"
str = re.replace(str,"$1reate")
re.Pattern="(d)(rop)"
str = re.replace(str,"$1rop")
re.Pattern="(a)(lter)"
str = re.replace(str,"$1lter")
re.Pattern="(d)(elete)"
str = re.replace(str,"$1elete")
re.Pattern="(u)(pdate)"
str = re.replace(str,"$1pdate")
re.Pattern="(s)(or)"
Str = re.replace(Str,"$1or")
Set re=Nothing
Str = Replace(Str, "&", "&")
UnCheckStr=Str
End Function
'*************************************
'转换HTML代码
'*************************************
Function HTMLEncode(ByVal reString)
Dim Str:Str=reString
If Not IsNull(Str) Then
Str = Replace(Str, "", "")
Str = Replace(Str, "", "")
Str = Replace(Str, CHR(9), " ")
Str = Replace(Str, CHR(39), "'")
Str = Replace(Str, CHR(32)&CHR(32), " ")
Str = Replace(Str, CHR(34), """)
Str = Replace(Str, CHR(13), "")
Str = Replace(Str, CHR(10), "br/")
HTMLEncode = Str
End If
End Function
'*************************************
'转换最新评论和日志HTML代码
'*************************************
Function CCEncode(ByVal reString)
Dim Str:Str=reString
If Not IsNull(Str) Then
Str = Replace(Str, "", "")
Str = Replace(Str, "", "")
Str = Replace(Str, CHR(9), " ")
Str = Replace(Str, CHR(39), "'")
Str = Replace(Str, CHR(32)&CHR(32), " ")
Str = Replace(Str, CHR(34), """)
Str = Replace(Str, CHR(13), "")
Str = Replace(Str, CHR(10), " ")
CCEncode = Str
End If
End Function
'*************************************
'反转换HTML代码
'*************************************
Function HTMLDecode(ByVal reString)
Dim Str:Str=reString
If Not IsNull(Str) Then
Str = Replace(Str, "", "")
Str = Replace(Str, "", "")
Str = Replace(Str, " ", CHR(9))
Str = Replace(Str, "'", CHR(39))
Str = Replace(Str, " ",CHR(32)&CHR(32))
Str = Replace(Str, """, CHR(34))
Str = Replace(Str, "", CHR(13))
Str = Replace(Str, "br/", CHR(10))
HTMLDecode = Str
End If
End Function
'*************************************
'恢复&字符
'*************************************
function ClearHTML(ByVal reString)
Dim Str:Str=reString
If Not IsNull(Str) Then
Str = Replace(Str, "&", "&")
ClearHTML = Str
End If
End Function
'*************************************
'过滤textarea
'*************************************
Function UBBFilter(ByVal reString)
Dim Str:Str=reString
If Not IsNull(Str) Then
Str = Replace(Str, "/textarea", "/textarea")
UBBFilter = Str
End If
End Function
'*************************************
'过滤HTML代码
'*************************************
Function EditDeHTML(byVal Content)
EditDeHTML=Content
IF Not IsNull(EditDeHTML) Then
EditDeHTML=UnCheckStr(EditDeHTML)
EditDeHTML=Replace(EditDeHTML,"&","&")
EditDeHTML=Replace(EditDeHTML,"","")
EditDeHTML=Replace(EditDeHTML,"","")
EditDeHTML=Replace(EditDeHTML,chr(34),""")
EditDeHTML=Replace(EditDeHTML,chr(39),"'")
End IF
End Function
'*************************************
'日期转换函数
'*************************************
Function DateToStr(DateTime,ShowType)
Dim DateMonth,DateDay,DateHour,DateMinute,DateWeek,DateSecond
Dim FullWeekday,shortWeekday,Fullmonth,Shortmonth,TimeZone1,TimeZone2
TimeZone1="+0800"
TimeZone2="+08:00"
FullWeekday=Array("Sunday","Monday","Tuesday","Wednesday","Thursday","Friday","Saturday")
shortWeekday=Array("Sun","Mon","Tue","Wed","Thu","Fri","Sat")
Fullmonth=Array("January","February","March","April","May","June","July","August","September","October","November","December")
Shortmonth=Array("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec")
DateMonth=Month(DateTime)
DateDay=Day(DateTime)
DateHour=Hour(DateTime)
DateMinute=Minute(DateTime)
DateWeek=weekday(DateTime)
DateSecond=Second(DateTime)
If Len(DateMonth)2 Then DateMonth="0"&DateMonth
If Len(DateDay)2 Then DateDay="0"&DateDay
If Len(DateMinute)2 Then DateMinute="0"&DateMinute
Select Case ShowType
Case "Y-m-d"
DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay
Case "Y-m-d H:I A"
Dim DateAMPM
If DateHour12 Then
DateHour=DateHour-12
DateAMPM="PM"
Else
DateHour=DateHour
DateAMPM="AM"
End If
If Len(DateHour)2 Then DateHour="0"&DateHour
DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay&" "&DateHour&":"&DateMinute&" "&DateAMPM
Case "Y-m-d H:I:S"
If Len(DateHour)2 Then DateHour="0"&DateHour
If Len(DateSecond)2 Then DateSecond="0"&DateSecond
DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay&" "&DateHour&":"&DateMinute&":"&DateSecond
Case "YmdHIS"
DateSecond=Second(DateTime)
If Len(DateHour)2 Then DateHour="0"&DateHour
If Len(DateSecond)2 Then DateSecond="0"&DateSecond
DateToStr=Year(DateTime)&DateMonth&DateDay&DateHour&DateMinute&DateSecond
Case "ym"
DateToStr=Right(Year(DateTime),2)&DateMonth
Case "d"
DateToStr=DateDay
Case "ymd"
DateToStr=Right(Year(DateTime),4)&DateMonth&DateDay
Case "mdy"
Dim DayEnd
select Case DateDay
Case 1
DayEnd="st"
Case 2
DayEnd="nd"
Case 3
DayEnd="rd"
Case Else
DayEnd="th"
End Select
DateToStr=Fullmonth(DateMonth-1)&" "&DateDay&DayEnd&" "&Right(Year(DateTime),4)
Case "w,d m y H:I:S"
DateSecond=Second(DateTime)
If Len(DateHour)2 Then DateHour="0"&DateHour
If Len(DateSecond)2 Then DateSecond="0"&DateSecond
DateToStr=shortWeekday(DateWeek-1)&","&DateDay&" "& Left(Fullmonth(DateMonth-1),3) &" "&Right(Year(DateTime),4)&" "&DateHour&":"&DateMinute&":"&DateSecond&" "&TimeZone1
Case "y-m-dTH:I:S"
If Len(DateHour)2 Then DateHour="0"&DateHour
If Len(DateSecond)2 Then DateSecond="0"&DateSecond
DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay&"T"&DateHour&":"&DateMinute&":"&DateSecond&TimeZone2
Case Else
If Len(DateHour)2 Then DateHour="0"&DateHour
DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay&" "&DateHour&":"&DateMinute
End Select
End Function
'*************************************
'分页函数
'*************************************
dim FirstShortCut,ShortCut
FirstShortCut=false
Function MultiPage(Numbers,Perpage,Curpage,Url_Add,aname,Style)
CurPage=Int(Curpage)
Numbers=Int(Numbers)
Dim URL
URL=Request.ServerVariables("Script_Name")&Url_Add
MultiPage=""
Dim Page,Offset,PageI
' If Int(Numbers)Int(PerPage) Then
Page=9
Offset=4
Dim Pages,FromPage,ToPage
If Numbers Mod Cint(Perpage)=0 Then
Pages=Int(Numbers/Perpage)
Else
Pages=Int(Numbers/Perpage)+1
End If
FromPage=Curpage-Offset
ToPage=Curpage+Page-Offset-1
If PagePages Then
FromPage=1
ToPage=Pages
Else
If FromPage1 Then
Topage=Curpage+1-FromPage
FromPage=1
If (ToPage-FromPage)Page And (ToPage-FromPage)Pages Then ToPage=Page
ElseIF TopagePages Then
FromPage =Curpage-Pages +ToPage
ToPage=Pages
If (ToPage-FromPage)Page And (ToPage-FromPage)Pages Then FromPage=Pages-Page+1
End If
End If
MultiPage="div class=""page"" style="""&Style&"""ul"
'if Curpage1 then MultiPage=MultiPage&"li class=""PageL""a href="""&Url&"page=1"" class=""PageLbutton"" title=""第一页""/a/li"
MultiPage=MultiPage&"li class=""pageNumber"""
if Curpage1 then MultiPage=MultiPage&"a href="""&Url&"page=1"" title=""第一页"" style=""text-decoration:none""/a | "
if not FirstShortCut then ShortCut=" accesskey="",""" else ShortCut=""
if Curpage1 then MultiPage=MultiPage&"a href="""&Url&"page="&CurPage-1&""" title=""上一页"" style=""text-decoration:none;"""&ShortCut&"/a"
For PageI=FromPage TO ToPage
If PageICurPage Then
MultiPage=MultiPage&"a href="""&Url&"page="&PageI&aname&""""&PageI&"/a | "
Else
MultiPage=MultiPage&"strong"&PageI&"/strong"
if PageIPages then MultiPage=MultiPage&" | "
End If
Next
if not FirstShortCut then ShortCut=" accesskey="".""" else ShortCut=""
if Curpagepages then MultiPage=MultiPage&"a href="""&Url&"page="&CurPage+1&""" title=""下一页"" style=""text-decoration:none"""&ShortCut&"/a"
if Curpagepages then MultiPage=MultiPage&"a href="""&Url&"page="&Pages&aname&""" title=""最后一页"" style=""text-decoration:none""/a"
MultiPage=MultiPage&"/li"
'If Int(Pages)Int(Page) Then
' MultiPage=MultiPage&"li.../lilia href="""&Url&"page="&Pages&aname&""""&pages&"/a/li"
'End If
'if Curpagepages then MultiPage=MultiPage&"li class=""PageR""a href="""&Url&"page="&Pages&aname&""" class=""PageRbutton"" title=""最后一页""/a/li"
MultiPage=MultiPage&"/ul/div"
' End If
FirstShortCut=true
End Function
'*************************************
'切割内容 - 按行分割
'*************************************
Function SplitLines(byVal Content,byVal ContentNums)
Dim ts,i,l
ContentNums=int(ContentNums)
If IsNull(Content) Then Exit Function
i=1
ts = 0
For i=1 to Len(Content)
l=Lcase(Mid(Content,i,5))
If l="br/" Then
ts=ts+1
End If
l=Lcase(Mid(Content,i,4))
If l="br" Then
ts=ts+1
End If
l=Lcase(Mid(Content,i,3))
If l="p" Then
ts=ts+1
End If
If tsContentNums Then Exit For
Next
If tsContentNums Then
Content=Left(Content,i-1)
End If
SplitLines=Content
End Function
当前1/2页
12下一页
