<%
'========================================================
'
'FormatDate(DT,tp) ------------------------------------------
'IsInteger(para) ---------------------------
'ChkrequestDate(Para) -----------------------
'ChkPost() ------------------------------------
'IsValidEmail(email)------------------------------------------Email
'MakedownName()--------------------------------
'getIP() ---------------------------------------------------- IP
'LeftTrue(str,n)---------------------------------------
'CheckSql()- ， SQL
'Runtime()---------------------------------------------
'--------------------FSO | --------------------------------
'Checkfolder(folderpath)-------------------------------------
'Deletefolder(folderpath) -----------------------------------
'Filehaveno(FileName) ---------------------------------
'readfilerecord(Filename) ----------- | txt
'WriteString(String,FileName)------------
'-------------------- | |------------------------------------
'Encrypt(theNumber)| Decrypt(theNumber) ID , 8
'UTF2GB(UTFStr) ------------------------- UTF8 GB
'toUTF8(szInput)------------------------- GB UTF8
'c10to2(x)-----------------------------------
'c16to2(x)---------------------------------
'c2to16(x)---------------------------------
'c2to10(x)-----------------------------------
'=========================================================
%>
<%
StartTime=timer()
'
Function FormatDate(DT,tp)
dim Y,M,D
Y=Year(DT)
M=month(DT)
D=Day(DT)
if M<10 then M="0"&M
if D<10 then D="0"&D
select case tp
case 1 FormatDate=Y&" "&M&" "&D&" "
case 2 FormatDate=Y&"/"&M&"/"&D
case 3 FormatDate=M&"/"&D
case 4 FormatDate=Y&"\"&M&"\"&D
case 5 FormatDate=Y&"-"&M&"-"&D
end select
End Function
'--------------------------------
' --- Being-----------------------------
Function IsInteger(para)
dim str
dim l,i
if isNUll(para) then
isInteger=false
exit function
end if
str=cstr(para)
if trim(str)="" then
isInteger=false
exit function
end if
l=len(str)
for i=1 to l
if mid(str,i,1)>"9" or mid(str,i,1)<"0" then
isInteger=false
exit function
end if
next
isInteger=true
if err.number<>0 then err.clear
End Function
'--------------------------------
'
Function ChkrequestDate(Para)
ChkrequestDate=False
If Not (IsNull(Para) Or Trim(Para)="" Or Not IsDate(Para)) Then
ChkrequestDate=True
End If
End Function
'--------------------------------
''Email
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 ChkPost()
dim HTTP_REFERER,SERVER_NAME
dim server_v1,server_v2
chkpost=false
SERVER_NAME=CheckStr(Request.ServerVariables("SERVER_NAME"))
HTTP_REFERER=CheckStr(Request.ServerVariables("HTTP_REFERER"))
server_v1=Cstr(HTTP_REFERER)
server_v2=Cstr(SERVER_NAME)
if mid(server_v1,8,len(server_v2))<>server_v2 then
chkpost=false
else
chkpost=true
end if
End Function
'--------------------------------
'
function MakedownName()
dim fname
randomize
fname = now()
fname = replace(fname,"-","")
fname = replace(fname," ","")
fname = replace(fname,":","")
fname = replace(fname,"PM","")
fname = replace(fname,"AM","")
fname = replace(fname," ","")
fname = replace(fname," ","")
fname = int(fname) + int(((9-1+1)*Rnd + 1)*100000) '6
MakedownName=fname
end function
'--------------------------------
' IP
Function getIP()
Dim strIPAddr
If Request.ServerVariables("HTTP_X_FORWARDED_FOR") = "" OR InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), "unknown") > 0 Then
strIPAddr = Request.ServerVariables("REMOTE_ADDR")
ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",") > 0 Then
strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",")-1)
ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";") > 0 Then
strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";")-1)
Else
strIPAddr = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
End If
getIP = Trim(Mid(strIPAddr, 1, 30))
End Function
'--------------------------------
' SQL , ， SQL
Function CheckSql()
Dim sql_injdata
SQL_injdata = "'|and|exec|insert|select|delete|update|count|*|%|chr|mid|master|truncate|char|declare"
SQL_inj = split(SQL_Injdata,"|")
If Request.QueryString<>"" Then
For Each SQL_Get In Request.QueryString
For SQL_Data=0 To Ubound(SQL_inj)
if instr(Request.QueryString(SQL_Get),Sql_Inj(Sql_DATA))>0 Then
Response.Write "<Script Language='javascript'>{alert(' ！');history.back(-1)}</Script>"
Response.end
end if
next
Next
End If
If Request.Form<>"" Then
For Each Sql_Post In Request.Form
For SQL_Data=0 To Ubound(SQL_inj)
if instr(Request.Form(Sql_Post),Sql_Inj(Sql_DATA))>0 Then
Response.Write "<Script Language='javascript'>{alert(' ！');history.back(-1)} </Script>"
Response.end
end if
next
next
end if
End Function
'--------------------------------
'
Function Runtime()
EndTime=Timer()
If EndTime<StartTime Then
EndTime=EndTime+24*3600
End if
RunTime=(EndTime-StartTime)*1000 '
End Function
'--------------------------------
'
Function Checkfolder(folderpath)
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
If objFSO.FolderExists(Server.MapPath(""&folderpath&"")) Then
Else
objFSO.CreateFolder(Server.MapPath(""&folderpath&""))'
End If
Set objFSO = Nothing
End Function
'--------------------------------
'
Function Deletefolder(folderpath)
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
If objFSO.FolderExists(Server.MapPath(""&folderpath&"")) Then
objFSO.deletefolder(server.MapPath(folderpath))
end if
Set objFSO = Nothing
End Function
'--------------------------------
' , , 8
Function Encrypt(theNumber)
On Error Resume Next
Dim n, szEnc, t, HiN, LoN, i
n = CDbl((theNumber + 1570) ^ 2 - 7 * (theNumber + 1570) - 450)
If n < 0 Then szEnc = "R" Else szEnc = "J"
n = CStr(abs(n))
For i = 1 To Len(n) step 2
t = Mid(n, i, 2)
If Len(t) = 1 Then
szEnc = szEnc & t
Exit For
End If
HiN = (CInt(t) And 240) / 16
LoN = CInt(t) And 15
szEnc = szEnc & Chr(Asc("M") + HiN) & Chr(Asc("C") + LoN)
Next
Encrypt = szEnc
End Function
Function Decrypt(theNumber)
On Error Resume Next
Dim e, n, sign, t, HiN, LoN, NewN, i
e = theNumber
If Left(e, 1) = "R" Then sign = -1 Else sign = 1
e = Mid(e, 2)
NewN = ""
For i = 1 To Len(e) step 2
t = Mid(e, i, 2)
If Asc(t) >= Asc("0") And Asc(t) <= Asc("9") Then
NewN = NewN & t
Exit For
End If
HiN = Mid(t, 1, 1)
LoN = Mid(t, 2, 1)
HiN = (Asc(HiN) - Asc("M")) * 16
LoN = Asc(LoN) - Asc("C")
t = CStr(HiN Or LoN)
If Len(t) = 1 Then t = "0" & t
NewN = NewN & t
Next
e = CDbl(NewN) * sign
Decrypt = CLng((7 + sqr(49 - 4 * (-450 - e))) / 2 - 1570)
End Function
'--------------------------------
' :
' :FileName
' :
Function readfilerecord(Filename)
if instr(filename,".")=0 then exit function
set ffso=server.createobject("scripting.filesystemobject")
if ffso.FileExists(server.mappath(filename))=false then exit function
set re_ffso=ffso.OpenTextFile(server.mappath(filename),1,0,0)
readfilerecord=re_ffso.readall
re_ffso.close
set ffso=nothing
end function
'---------------------------------
' :
' :FileName
' : True, False
Function Filehaveno(FileName)
set ffso=server.createobject("scripting.filesystemobject")
Filehaveno=ffso.FileExists(server.mappath(filename))
set ffso=nothing
End Function
'----------------------------------
' :
' :String( ),FileName( )
' :
Function WriteString(String,FileName)
if string="" then exit function
if filename="" then exit function
if instr(filename,".")=0 then exit function
set ffso=server.createobject("scripting.filesystemobject")
set wfso=ffso.CreateTextFile(server.mappath(filename))
wfso.Writeline(string)
wfso.close
set ffso=nothing
End Function
'---------------------------------------
'
'left ,
Function LeftTrue(str,n)
If len(str)<=n/2 Then
LeftTrue=str
Else
Dim TStr
Dim l,t,c
Dim i
l=len(str)
t=l
TStr=""
t=0
for i=1 to l
c=asc(mid(str,i,1))
If c<0 then c=c+65536
If c>255 then
t=t+2
Else
t=t+1
End If
'If t>n Then exit for '
If t>n Then exit for '
TStr=TStr&(mid(str,i,1))
next
LeftTrue = TStr
End If
End Function
'------------------------------------------
'UTF GB--- UTF8 GB
function UTF2GB(UTFStr)
for Dig=1 to len(UTFStr)
' UTF8 %
if mid(UTFStr,Dig,1)="%" then
'UTF8 8
if len(UTFStr) >= Dig+8 then
GBStr=GBStr & ConvChinese(mid(UTFStr,Dig,9))
Dig=Dig+8
else
GBStr=GBStr & mid(UTFStr,Dig,1)
end if
else
GBStr=GBStr & mid(UTFStr,Dig,1)
end if
next
UTF2GB=GBStr
end function
'UTF8
function ConvChinese(x)
A=split(mid(x,2),"%")
i=0
j=0
for i=0 to ubound(A)
A(i)=c16to2(A(i))
next
for i=0 to ubound(A)-1
DigS=instr(A(i),"0")
Unicode=""
for j=1 to DigS-1
if j=1 then
A(i)=right(A(i),len(A(i))-DigS)
Unicode=Unicode & A(i)
else
i=i+1
A(i)=right(A(i),len(A(i))-2)
Unicode=Unicode & A(i)
end if
next
if len(c2to16(Unicode))=4 then
ConvChinese=ConvChinese & chrw(int("&H" & c2to16(Unicode)))
else
ConvChinese=ConvChinese & chr(int("&H" & c2to16(Unicode)))
end if
next
end function
'
function c2to16(x)
i=1
for i=1 to len(x) step 4
c2to16=c2to16 & hex(c2to10(mid(x,i,4)))
next
end function
'
function c2to10(x)
c2to10=0
if x="0" then exit function
i=0
for i= 0 to len(x) -1
if mid(x,len(x)-i,1)="1" then c2to10=c2to10+2^(i)
next
end function
'
function c16to2(x)
i=0
for i=1 to len(trim(x))
tempstr= c10to2(cint(int("&h" & mid(x,i,1))))
do while len(tempstr)<4
tempstr="0" & tempstr
loop
c16to2=c16to2 & tempstr
next
end function
'
function c10to2(x)
mysign=sgn(x)
x=abs(x)
DigS=1
do
if x<2^DigS then
exit do
else
DigS=DigS+1
end if
loop
tempnum=x
i=0
for i=DigS to 1 step-1
if tempnum>=2^(i-1) then
tempnum=tempnum-2^(i-1)
c10to2=c10to2 & "1"
else
c10to2=c10to2 & "0"
end if
next
if mysign=-1 then c10to2="-" & c10to2
end function
'-------------------------------
'GB UTF8-- GB UTF8
Function toUTF8(szInput)
Dim wch, uch, szRet
Dim x
Dim nAsc, nAsc2, nAsc3
' ，
If szInput = "" Then
toUTF8 = szInput
Exit Function
End If
'
For x = 1 To Len(szInput)
' mid GB
wch = Mid(szInput, x, 1)
' ascW GB Unicode
' ：asc ANSI ，
nAsc = AscW(wch)
If nAsc < 0 Then nAsc = nAsc + 65536
If (nAsc And &HFF80) = 0 Then
szRet = szRet & wch
Else
If (nAsc And &HF000) = 0 Then
uch = "%" & Hex(((nAsc \ 2 ^ 6)) Or &HC0) & Hex(nAsc And &H3F Or &H80)
szRet = szRet & uch
Else
'GB Unicode 0800 - FFFF
uch = "%" & Hex((nAsc \ 2 ^ 12) Or &HE0) & "%" & _
Hex((nAsc \ 2 ^ 6) And &H3F Or &H80) & "%" & _
Hex(nAsc And &H3F Or &H80)
szRet = szRet & uch
End If
End If
Next
toUTF8 = szRet
End Function
%>