<%
Rem ==========论坛通用函数=========
function IsValidEmail(email)
dim names, name, i, c
'Check for valid syntax in an email address.
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 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
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
end if
next
strLength=t
else
strLength=len(str)
end if
if err.number<>0 then err.clear
end function
function cutStr(str,strlen)
dim l,t,c
l=len(str)
t=0
for i=1 to l
c=Abs(Asc(Mid(str,i,1)))
if c>255 then
t=t+2
else
t=t+1
end if
if t>=strlen then
cutStr=left(str,i)
exit for
else
cutStr=str
end if
next
cutStr=replace(cutStr,chr(10),"")
end function
Function fixjs(Str)
If Str <>"" Then
str = replace(str,"\", "\\")
Str = replace(str, chr(34), "\""")
Str = replace(str, chr(39),"\'")
Str = Replace(str, chr(13), "\n")
Str = Replace(str, chr(10), "\r")
str = replace(str,"'", "'")
End If
fixjs=Str
End Function
Function enfixjs(Str)
If Str <>"" Then
Str = replace(str,"'", "'")
Str = replace(str,"\""" , chr(34))
Str = replace(str, "\'",chr(39))
Str = Replace(str, "\r", chr(10))
Str = Replace(str, "\n", chr(13))
Str = replace(str,"\\", "\")
End If
enfixjs=Str
End Function
Function Chkurl()
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 Chkurl=True
End Function
'用于论坛本身的过滤，不带脏话过滤
Function iHTMLEncode(fString)
If Not IsNull(fString) Then
fString = replace(fString, ">", ">")
fString = replace(fString, "<", "<")
fString = Replace(fString, CHR(32), " ")
fString = Replace(fString, CHR(9), " ")
fString = Replace(fString, CHR(34), """)
fString = Replace(fString, CHR(39), "'")
fString = Replace(fString, CHR(13), "")
fString = Replace(fString, CHR(10) & CHR(10), "
")
fString = Replace(fString, CHR(10), " ")
iHTMLEncode = fString
End If
End Function
function formathtml(fstring)
if not IsNull(fstring) then
fstring=replace(fstring,vbNewline," ",1,-1,0)
'fstring=" "&fstring
fstring=replace(fstring," "," ")
formathtml=fstring
end if
end function
function HTMLEncode3(fString)
fString=server.htmlencode(fString)
fString=replace(fString,"\","\")
fString=replace(fString,"'","'")
fString=replace(fString,vbCrlf," ")
fString=replace(fString," ","")
HTMLEncode3=fString
end function
' ============================================
' 清除html标记
' ============================================
function clearhtml(str)
Dim UBBStrCnt,LoopN
UBBStrCnt = str
UBBStrCnt = ResumeUBBCode(UBBStrCnt)
'UBBStrCnt = Replace(UBBStrCnt,VbCrLf,chr(3))
dim re
set re = New RegExp
re.Global = True
re.IgnoreCase = True
re.Pattern = "(\)"
UBBStrCnt = re.Replace(UBBStrCnt,"")
UBBStrCnt = KillHTMLScript(UBBStrCnt)
UBBStrCnt = Replace(UBBStrCnt,VbCrLf,"")
clearhtml = KillHTMLLabel(UBBStrCnt)
Set Re = Nothing
End Function
Function ResumeUBBCode(Tstr)
Dim str
str = Tstr
Str = Replace(str," "," ")
Str = Replace(str,VbCrLf,"")
Str = Replace(str," " & VbCrLf,VbCrLf)
Str = Replace(str," " & VbCrLf,VbCrLf)
Str = Replace(str," ",VbCrLf)
Str = Replace(str," ",VbCrLf)
ResumeUBBCode = Str
End Function
Function KillHTMLScript(str)
Dim n,m,str2
str2 = str
n = inStr(str2,"",0)
Else
m = 0
End If
Do while n > 0 and n < m and m > 0
str2 = Left(str2,n-1) & Mid(str2,m+9)
n = inStr(str2,"",0)
Else
m = 0
End If
Loop
KillHTMLScript = str2
End Function
Function KillHTMLObject(str)
Dim n,m,str2
str2 = str
n = inStr(str2,"",0)
Else
m = 0
End If
Do while n > 0 and n < m and m > 0
str2 = Left(str2,n-1) & Mid(str2,m+9)
n = inStr(str2,"",0)
Else
m = 0
End If
Loop
KillHTMLObject = str2
End Function
Function KillHTMLLabel(str)
Dim n,m,str2
n = inStr(str,"<")
m = inStr(str,">")
str2 = str
Do while n > 0 and n < m
str2 = Left(str2,n-1) & Mid(str2,m+1)
n = inStr(str2,"<")
m = inStr(str2,">")
Loop
KillHTMLLabel = str2
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, "&", "&")
sTemp = Replace(sTemp, "<", "<")
sTemp = Replace(sTemp, ">", ">")
sTemp = Replace(sTemp, Chr(34), """)
sTemp = Replace(sTemp, Chr(10), " ")
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, "&", "&")
sTemp = Replace(sTemp, "<", "<")
sTemp = Replace(sTemp, ">", ">")
sTemp = Replace(sTemp, Chr(34), """)
inHTML = sTemp
End Function
'系统分配随机密码
Public Function Createpass()
Dim Ran,i,LengthNum
LengthNum=16
Createpass=""
For i=1 To LengthNum
Randomize
Ran = CInt(Rnd * 2)
Randomize
If Ran = 0 Then
Ran = CInt(Rnd * 25) + 97
Createpass =Createpass& UCase(Chr(Ran))
ElseIf Ran = 1 Then
Ran = CInt(Rnd * 9)
Createpass = Createpass & Ran
ElseIf Ran = 2 Then
Ran = CInt(Rnd * 25) + 97
Createpass =Createpass& Chr(Ran)
End If
Next
End Function
function checkstr(str)
if not IsNull(str) then
str = replace(str,"net user","")
str = replace(str,"xp_cmdshell","")
str = replace(str,"exec%20master.dbo.xp_cmdshell","")
str = replace(str,"net localgroup administrators","")
str = replace(str,"'",chr(39))
str = replace(str,"""","")
str = replace(str,"truncate","")
str = replace(str,"%","")
str = replace(str,"","")
str = replace(str,"alert('"&mess&"');window.history.back();"
response.end
elseif mtype="close" then
response.write ""
response.end
else
response.write ""
response.end
end if
end sub
sub showpage(sfilename,totalnumber,maxperpage)
dim n, i,strTemp
if totalnumber mod maxperpage=0 then
n= totalnumber \ maxperpage
else
n= totalnumber \ maxperpage+1
end if
strTemp= "
"
response.write strTemp
end sub
sub SetPageNo(byref pageno,maxpage)
if trim(pageno&"")="" then
pageno=1
else
if not isnumeric(pageno) then
pageno=1
else
pageno=clng(pageno)
if pageno>maxpage then pageno=maxpage
end if
end if
end sub
%>
<%
dim conn
set conn=Server.CreateObject("ADODB.Connection")
conn.Open "provider=microsoft.jet.oledb.4.0;data source="& Server.MapPath("../database/#chahjjfgag.mdb")
If Err Then
err.Clear
Set Conn = Nothing
Response.Write "数据库连接出错，请检查连接字串。"'注释，需要把这几个字翻译成英文。
Response.End
End If
dim qs,errc,iii
qs=request.servervariables("query_string")
qs=LCase(qs)
'response.write qs
'response.end
dim nothis(17)
nothis(0)="net user"
nothis(1)="xp_cmdshell"
nothis(2)="/add"
nothis(3)="exec%20master.dbo.xp_cmdshell"
nothis(4)="net localgroup administrators"
nothis(5)="select"
nothis(6)="count"
nothis(7)="asc"
nothis(8)="char"
nothis(9)="mid"
nothis(10)="'"
nothis(11)=":"
nothis(12)=""""
nothis(13)="insert"
nothis(14)="delete"
nothis(15)="drop"
nothis(16)="truncate"
nothis(17)="from"
'nothis(18)="%"
errc=false
for iii= 0 to ubound(nothis)
if instr(qs,nothis(iii))<>0 then
errc=true
end if
next
if errc then
response.write ""
response.end
end if
sub delfile(fpaths,furl)
dim filepaths,objFSO
'on error resume next
if len(furl)>8 then
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
filepaths=Server.MapPath(""&fpaths&furl&"")
if objFSO.fileExists(filepaths) then
objFSO.DeleteFile(filepaths)
end if
end if
end sub
%>
<%
Function TripHTML(str)
Dim tags,regEx
tags=Array("font","b","strong","span","input","img","!","!--","script","object","div","table","tr","td","iframe","select","option","html","head","meta","title","p","a") '在这时指定要过滤掉的标签
Set regEx=New RegExp
regEx.IgnoreCase=True
For I=0 To Ubound(tags)
regEx.Pattern=""
'去掉选择的标签！
'regEx.Pattern=""
'去掉所有的标签
Do While regEx.Test(str)
str=regEx.Replace(str,"")
Loop
Next
TripHTML=str
End Function
function requestid(id)
dim goodid
goodid=replace(id,"=","")
if not isnumeric(goodid) then
response.write("")
response.End()
end if
requestid=goodid
end function
function repla(something)
something=replace(something,"<","<")
something=replace(something,">",">")
something=replace(something,"=","")
something=replace(something,vbCrlf," ")
repla=something
end function
%>
在线咨询_上海长海医院眼屈光中心