📄 function.asp
字号:
<%
'脚本超时
Server.ScriptTimeout=600
Session.Timeout = 50
Function Add_Root_Dir(f_Path)
Dim f_All_Path
If Left(f_Path,1)="/" Then
f_All_Path = G_VIRTUAL_ROOT_DIR & f_Path
Else
f_All_Path = G_VIRTUAL_ROOT_DIR & "/" & f_Path
End If
If Trim(G_VIRTUAL_ROOT_DIR) <> "" Then
f_All_Path = "/" & f_All_Path
End If
Add_Root_Dir = f_All_Path
End Function
Function Lose_Html(f_Str)
Dim regEx
if Not IsNull(f_Str) Then
f_Str=f_Str&""
Set regEx = New RegExp
regEx.Pattern = "<\/*[^<>]*>"
regEx.IgnoreCase = True
regEx.Global = True
f_Str = regEx.Replace(f_Str,"")
Lose_Html = f_Str
Else
Lose_Html=""
End If
End Function
Function Intercept_Char(f_Str,f_Length,f_Flag)
'f_Flag为1，一个中文字符的长度算1；f_Flag为2，一个中文字符的长度算2
Dim f_Str_Total_Len,f_i,f_Str_Curr_Len,f_One_Char
If f_Length = 0 Or f_Str = "" Or IsNull(f_Str) Then
Intercept_Char = ""
Exit Function
End If
f_Str=Replace(Replace(Replace(Replace(f_Str," "," "),""",Chr(34)),">",">"),"<","<")
f_Str_Total_Len = Len(f_Str)
If f_Flag = 1 Then
If f_Length>=f_Str_Total_Len Then
Intercept_Char = f_Str
Else
Intercept_Char = Left(f_Str,f_Length)
End If
Else
For f_i = 1 To f_Str_Total_Len
f_One_Char = Mid(f_Str,f_i,1)
If Abs(Asc(f_One_Char)) > 255 then
f_Str_Curr_Len=f_Str_Curr_Len+2
Else
f_Str_Curr_Len=f_Str_Curr_Len+1
End If
If f_Str_Curr_Len >= f_Length Then
Intercept_Char = Left(f_Str,f_i)
Exit For
End If
Next
If f_Str_Curr_Len < f_Length Then
Intercept_Char = f_Str
End If
End If
Intercept_Char = Replace(Replace(Replace(Replace(Intercept_Char," "," "),Chr(34),"""),">",">"),"<","<")
End Function
Function Mod_IS_Installed_Bool(f_Mod_Str)
On Error Resume Next
Mod_IS_Installed_Bool = False
Err = 0
Dim f_TestObj
Set f_TestObj = Server.CreateObject(f_Mod_Str)
If Err = 0 Then
Mod_IS_Installed_Bool = True
End If
Set f_TestObj = Nothing
Err = 0
End Function
Function SendMail(f_Mailto_Address,f_Mailto_Name,f_Subject,f_Mail_Body,f_From_Name,f_Mail_From,f_Priority)
On Error Resume Next
Dim f_JMail,f_True_Mail_From,f_Mail_Server,f_Server_Domain
Set f_JMail=Server.CreateObject("JMail.Message")
If Err Then
SendMail= "<br><li>没有安装JMail组件</li>"
Err.Clear
Exit Function
End If
f_Mail_Server = Get_Cache_Value("MF","MF_Mail_Server")
f_True_Mail_From = Get_Cache_Value("MF","MF_Mail_Name")
f_JMail.Silent = True
f_JMail.Logging = True
f_JMail.Charset = "gb2312"
f_JMail.MailServerUserName = f_True_Mail_From
f_JMail.MailServerPassword = Get_Cache_Value("MF","MF_Mail_Pass_Word")
f_JMail.ContentType = "text/html"
f_True_Mail_From =f_True_Mail_From & "@"
f_Server_Domain = Left(f_Mail_Server,InStrRev(f_Mail_Server,".")-1)
f_Server_Domain = Left(f_Server_Domain,InStrRev(f_Server_Domain,"."))
f_True_Mail_From =f_True_Mail_From & Right(f_Mail_Server,Len(f_Mail_Server)-Len(f_Server_Domain))
f_JMail.From = f_True_Mail_From
f_JMail.FromName = f_From_Name & "(" & f_Mail_From & ")"
f_JMail.Subject = f_Subject
f_JMail.AddRecipient f_Mailto_Address
f_JMail.Body = f_Mail_Body
f_JMail.Priority = 3
f_JMail.AddHeader "Originating-IP", Request.ServerVariables("REMOTE_ADDR")
f_JMail = ObjJmail.Send(f_Mail_Server)
f_JMail.Close
Set f_JMail=nothing
End Function
Function NoSqlHack(FS_inputStr)
Dim f_NoSqlHack_AllStr,f_NoSqlHack_Str,f_NoSqlHack_i,Str_InputStr
Str_InputStr=FS_inputStr
f_NoSqlHack_AllStr="*|and |exec |insert |select |delete |update |count |master |truncate |declare |and |exec |insert |select |delete |update |count |master |truncate |declare |char(|mid(|chr("
f_NoSqlHack_Str = Split(f_NoSqlHack_AllStr,"|")
For f_NoSqlHack_i=LBound(f_NoSqlHack_Str) To Ubound(f_NoSqlHack_Str)
If Instr(LCase(Str_InputStr),f_NoSqlHack_Str(f_NoSqlHack_i))<>0 Then
If f_NoSqlHack_Str(f_NoSqlHack_i)="'" Then f_NoSqlHack_Str(f_NoSqlHack_i)=" \' "
Response.Write "<html><title>警告</title><body bgcolor=""EEEEEE"" leftmargin=""60"" topmargin=""30""><font style=""font-size:16px;font-weight:bolder;color:blue;""><li>您提交的数据有恶意字符</li></font><font style=""font-size:14px;font-weight:bolder;color:red;""><br><li>您的数据已经被记录!</li><br><li>您的IP："&Request.ServerVariables("Remote_Addr")&"</li><br><li>操作日期："&Now&"</li></font></body></html><!--Powered by Foosun Inc.,AddTime:"&now&"-->"
Response.End
End if
Next
NoSqlHack = Replace(Str_InputStr,"'","''")
End Function
Function CheckIpSafe(ip)
Dim test,test_i,test_j,ascnum,safe,iplen
test=Split(ip,".")
safe=True
For test_i=LBound(test) To UBound(test)
iplen=Len(test(test_i))
For test_j=1 To iplen
ascnum=Asc(Mid(test(test_i),test_j,1))
If Not (ascnum>=48 And ascnum<=57) Then
Response.Write "<html><title>警告</title><body bgcolor=""EEEEEE"" leftmargin=""60"" topmargin=""30""><font style=""font-size:16px;font-weight:bolder;color:blue;""><li>您提交的数据有恶意字符</li></font><font style=""font-size:14px;font-weight:bolder;color:red;""><br><li>您的数据已经被记录!</li><br><li>您的IP："&Request.ServerVariables("Remote_Addr")&"</li><br><li>操作日期："&Now&"</li></font></body></html><!--Powered by Foosun Inc.,AddTime:"&now&"-->"
Response.End
End If
Next
Next
CheckIpSafe=ip
End Function
Function NoHtmlHackInput(Str) '过滤跨站脚本和HTML标签
Dim regEx
Set regEx = New RegExp
regEx.IgnoreCase = True
regEx.Pattern = "<|>|(script)|on(mouseover|mouseon|mouseout|click|dblclick|blur|focus|change)|eval|\t"
If regEx.Test(LCase(Str)) Then
Response.Write "<html><title>警告</title><body bgcolor=""EEEEEE"" leftmargin=""60"" topmargin=""30""><font style=""font-size:16px;font-weight:bolder;color:blue;""><li>您提交的数据有恶意字符</li></font><font style=""font-size:14px;font-weight:bolder;color:red;""><br><li>提交的内容不能包括[<|>|(script)|on(mouseover|mouseon|mouseout|click|dblclick|blur|focus|change)|eval]</li><li>您的数据已经被记录!</li><br><li>您的IP："&Request.ServerVariables("Remote_Addr")&"</li><br><li>操作日期："&Now&"</li></font></body></html><!--Powered by Foosun Inc.,AddTime:"&now&"-->"
Response.End
End If
Set regEx = Nothing
NoHtmlHackInput = Str
End Function
'获得中文字数，1个中文站2个字符，codez by Simpwind
Function GotTopic(Str,StrLen)
Dim l,t,c, i,LableStr,regEx,Match,Matches
If StrLen=0 then
GotTopic=""
exit function
End If
if IsNull(Str) then
GotTopic = ""
Exit Function
end if
if Str = "" then
GotTopic=""
Exit Function
end If
Str=Replace(Replace(Replace(Replace(Str," "," "),""",Chr(34)),">",">"),"<","<")
l=len(str)
t=0
strlen=Clng(strLen)
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
GotTopic=left(str,i)
exit for
else
GotTopic=str
end if
Next
GotTopic = Replace(Replace(Replace(Replace(GotTopic," "," "),Chr(34),"""),">",">"),"<","<")
End Function
'返回中文字符的前StrLen位字符 By Wen Yongzhong
Function GetCStrLen(Str,StrLen)
Dim l,t,c, i,LableStr,regEx,Match,Matches
If StrLen=0 Then
GetCStrLen=""
Exit Function
End If
If IsNull(Str) Then
GetCStrLen = ""
Exit Function
End If
If Str = "" Then
GetCStrLen=""
Exit Function
End If
l=len(str)
t=0
strlen=Clng(strLen)
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
GetCStrLen=left(str,i)
Exit For
Else
GetCStrLen=str
End If
Next
End Function
'远程存图
Function ReplaceRemoteUrl(NewsContent,SaveFilePath,FunDoMain,DummyPath)
Dim re,RemoteFile,RemoteFileurl,SaveFileName,FileName,FileExtName,SaveImagePath,tNewsContent
Set re = New RegExp
re.IgnoreCase = True
re.Global=True
re.Pattern = "((http|https|ftp|rtsp|mms):(\/\/|\\\\){1}((\w)+[.]){1,}(net|com|cn|org|cc|tv|[0-9]{1,3})(\S*\/)((\S)+[.]{1}(gif|jpg|png|bmp)))"
tNewsContent = NewsContent
Set RemoteFile = re.Execute(tNewsContent)
Set re = Nothing
For Each RemoteFileurl in RemoteFile
SaveFileName = Mid(RemoteFileurl,InstrRev(RemoteFileurl,"/")+1)
Call SaveRemoteFile(DummyPath & SaveFilePath & "/" & SaveFileName,RemoteFileurl)
tNewsContent = Replace(tNewsContent,RemoteFileurl,FunDoMain & SaveFilePath & "/" & SaveFileName)
Next
ReplaceRemoteUrl = tNewsContent
End Function
Sub SaveRemoteFile(LocalFileName,RemoteFileUrl)
LocalFileName=Server.MapPath(replace(LocalFileName,"//","/"))
'PathExistCheck LocalFileName
On Error Resume Next
Dim StreamObj,Retrieval,GetRemoteData
Set Retrieval = Server.CreateObject(G_FS_XMLHTTP)
If Err Then
Response.Write "<script language='JavaScript'>alert('你的系统不支持"&G_FS_XMLHTTP&"\n，无法保存远程文件！');</script>"
Err.clear
Set Retrieval = Nothing
Exit Sub
End If
With Retrieval
.Open "Get", RemoteFileUrl, False, "", ""
.Send
if Err.Number <> 0 then
Err.Clear
Set Retrieval = Nothing
Exit Sub
end if
GetRemoteData = .ResponseBody
End With
Set Retrieval = Nothing
If Err Then Err.clear
Set StreamObj = Server.CreateObject(G_FS_STREAM)
If Err Then
Response.Write "<script language='JavaScript'>alert('你的系统不支持"&G_FS_STREAM&"\n，无法保存远程文件！');</script>"
Err.clear
Set StreamObj = Nothing
Exit Sub
End If
With StreamObj
.Type = 1
.Open
.Write GetRemoteData
.SaveToFile LocalFileName,2
.Cancel()
.Close()
End With
AddWaterMark LocalFileName'////////////2006-11-22 为新闻远程存图添加水印 by sicend
Set StreamObj = Nothing
End Sub
'创建
Function CreateDateDir(Path)
Dim sBuild,FSO
sBuild=path&"\"&year(Now())&"-"&month(now())
Set FSO = Server.CreateObject(G_FS_FSO)
If FSO.FolderExists(sBuild)=false then
FSO.CreateFolder(sBuild)
End IF
sBuild=sBuild&"\"&day(Now())
If FSO.FolderExists(sBuild)=false then
FSO.CreateFolder(sBuild)
End IF
set FSO=Nothing
End Function
'创建目录
Sub savePathdirectory(Path)
Dim FSO
Set FSO = Server.CreateObject(G_FS_FSO)
if Trim(G_VIRTUAL_ROOT_DIR) ="" then
FSO.CreateFolder(Path)
Else
FSO.CreateFolder(G_VIRTUAL_ROOT_DIR)
FSO.CreateFolder(Path)
End if
End Sub
' 传入：字符串、位置、长度
' 返回：在字符串指定位置取出指定长度的字符串，如果位置大于等于字符串长度，返回空值
Function getStrLoc(FS_Str,FS_StrLoc,FS_StrLen)
Dim FS_CharFind
If Len(FS_Str)>=FS_StrLoc Then
FS_CharFind = Mid(FS_Str,FS_StrLoc,FS_StrLen)
getStrLoc = FS_CharFind
Else
getStrLoc = ""
End If
End Function
'======================================================================
' 用AspJpeg组件建立带有新闻标题的图片
' 参数说明
' NumCanvasWidth画布宽度，NumCanvasHeight画布高度，bgColor背景颜色，borderColor图片边框颜色(为空或者0不显示边框)
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -