collecting_function.asp

一款不错的影音视频网站源代码。asp的程序。后台有自动采集功能

<%
Function GetHttp(HttpUrl,Cset)
On Error Resume Next
If IsNull(HttpUrl)=True Or Len(HttpUrl)<18 Or HttpUrl=False Then
GetHttp=False
Exit Function
End If
Dim Http
Set Http=server.createobject("MSXML2.XMLHTTP")
Http.open "GET",HttpUrl,False
Http.Send()
If Http.Readystate<>4 then
Http.close
Set Http=Nothing 
GetHttp=False
Exit function
End if
GetHttp=bytesToBSTR(Http.responseBody,Cset)
Set Http=Nothing
If Err.number<>0 then
Err.Clear
End If
End Function

Function BytesToBstr(Body,Cset)
Dim Objstream
Set Objstream = Server.CreateObject("adodb.stream")
objstream.Type = 1
objstream.Mode =3
objstream.Open
objstream.Write body
objstream.Position = 0
objstream.Type = 2
objstream.Charset = Cset
BytesToBstr = objstream.ReadText 
objstream.Close
set objstream = nothing
End Function

Function GetBody(ConStr,StartStr,OverStr)
on error resume next
   If ConStr=False or ConStr="" or IsNull(ConStr)=True Or StartStr="" or IsNull(StartStr)=True Or OverStr="" or IsNull(OverStr)=True Then
      GetBody=False
      Exit Function
   End If
   Dim ConStrTemp
   Dim Start,Over
   ConStrTemp=Lcase(ConStr)
   StartStr=Lcase(StartStr)
   OverStr=Lcase(OverStr)
   Start = InStrB(1, ConStrTemp, StartStr, vbBinaryCompare)
   If Start<=0 then
      GetBody=False
      Exit Function
   Else
         Start=Start+LenB(StartStr)
   End If
   Over=InStrB(Start,ConStrTemp,OverStr,vbBinaryCompare)
   GetBody=MidB(ConStr,Start,Over-Start)
End Function

Function GetArray(Byval ConStr,StartStr,OverStr)
on error resume next
If ConStr=False or ConStr="" Or IsNull(ConStr)=True or StartStr="" Or OverStr="" or IsNull(StartStr)=True Or IsNull(OverStr)=True Then
GetArray=False
Exit Function
End If
Dim TempStr,TempStr2,objRegExp,Matches,Match
TempStr=""
Set objRegExp = New Regexp 
objRegExp.IgnoreCase = True 
objRegExp.Global = True
objRegExp.Pattern = "("&StartStr&").+?("&OverStr&")"
Set Matches =objRegExp.Execute(ConStr) 
For Each Match in Matches
TempStr=TempStr & "$Array$" & Match.Value
Next 
Set Matches=nothing
If TempStr="" Then
GetArray=False
Exit Function
End If
TempStr=Right(TempStr,Len(TempStr)-7)
objRegExp.Pattern =StartStr
TempStr=objRegExp.Replace(TempStr,"")
objRegExp.Pattern =OverStr
TempStr=objRegExp.Replace(TempStr,"")
Set objRegExp=nothing
If TempStr="" then
GetArray=False
Else
GetArray=TempStr
End if
End Function

Function DefiniteUrl(Byval PrimitiveUrl,Byval ConsultUrl)
Dim ConTemp,PriTemp,Pi,Ci,PriArray,ConArray
If PrimitiveUrl="" or ConsultUrl="" or PrimitiveUrl="$False$" or ConsultUrl="$False$" Then
DefiniteUrl=False
Exit Function
End If
If Left(Lcase(ConsultUrl),7)<>"http://" Then
ConsultUrl= "http://" & ConsultUrl
End If
ConsultUrl=Replace(ConsultUrl,"\","/")
ConsultUrl=Replace(ConsultUrl,"://",":\\")
PrimitiveUrl=Replace(PrimitiveUrl,"\","/")

If Right(ConsultUrl,1)<>"/" Then
If Instr(ConsultUrl,"/")>0 Then
If Instr(Right(ConsultUrl,Len(ConsultUrl)-InstrRev(ConsultUrl,"/")),".")>0 then 
Else
ConsultUrl=ConsultUrl & "/"
End If
Else
ConsultUrl=ConsultUrl & "/"
End If
End If
ConArray=Split(ConsultUrl,"/")
If Left(LCase(PrimitiveUrl),7) = "http://" then
DefiniteUrl=Replace(PrimitiveUrl,"://",":\\")
ElseIf Left(PrimitiveUrl,1) = "/" Then
DefiniteUrl=ConArray(0) & PrimitiveUrl
ElseIf Left(PrimitiveUrl,2)="./" Then
PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-2)
If Right(ConsultUrl,1)="/" Then 
DefiniteUrl=ConsultUrl & PrimitiveUrl
Else
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & PrimitiveUrl
End If
ElseIf Left(PrimitiveUrl,3)="../" then
Do While Left(PrimitiveUrl,3)="../"
PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-3)
Pi=Pi+1
Loop 
For Ci=0 to (Ubound(ConArray)-1-Pi)
If DefiniteUrl<>"" Then
DefiniteUrl=DefiniteUrl & "/" & ConArray(Ci)
Else
DefiniteUrl=ConArray(Ci)
End If
Next
DefiniteUrl=DefiniteUrl & "/" & PrimitiveUrl
Else
If Instr(PrimitiveUrl,"/")>0 Then
PriArray=Split(PrimitiveUrl,"/")
If Instr(PriArray(0),".")>0 Then
If Right(PrimitiveUrl,1)="/" Then
DefiniteUrl="http:\\" & PrimitiveUrl
Else
If Instr(PriArray(Ubound(PriArray)-1),".")>0 Then 
DefiniteUrl="http:\\" & PrimitiveUrl
Else
DefiniteUrl="http:\\" & PrimitiveUrl & "/"
End If
End If 
Else
If Right(ConsultUrl,1)="/" Then 
DefiniteUrl=ConsultUrl & PrimitiveUrl
Else
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & PrimitiveUrl
End If
End If
Else
If Instr(PrimitiveUrl,".")>0 Then
If Right(ConsultUrl,1)="/" Then
If right(LCase(PrimitiveUrl),3)=".cn" or right(LCase(PrimitiveUrl),3)="com" or right(LCase(PrimitiveUrl),3)="net" or right(LCase(PrimitiveUrl),3)="org" Then
DefiniteUrl="http:\\" & PrimitiveUrl & "/"
Else
DefiniteUrl=ConsultUrl & PrimitiveUrl
End If
Else
If right(LCase(PrimitiveUrl),3)=".cn" or right(LCase(PrimitiveUrl),3)="com" or right(LCase(PrimitiveUrl),3)="net" or right(LCase(PrimitiveUrl),3)="org" Then
DefiniteUrl="http:\\" & PrimitiveUrl & "/"
Else
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl
End If
End If
Else
If Right(ConsultUrl,1)="/" Then
DefiniteUrl=ConsultUrl & PrimitiveUrl & "/"
Else
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl & "/"
End If 
End If
End If
End If
If Left(DefiniteUrl,1)="/" then
DefiniteUrl=Right(DefiniteUrl,Len(DefiniteUrl)-1)
End if
If DefiniteUrl<>"" Then
DefiniteUrl=Replace(DefiniteUrl,"//","/")
DefiniteUrl=Replace(DefiniteUrl,":\\","://")
Else
DefiniteUrl=False
End If
End Function

function GetImage(url)
on error resume next
dim http,geturl,objStream
ArrSaveFileName = Split(url,".")
strFileType=Lcase(ArrSaveFileName(Ubound(ArrSaveFileName)))
strFileName=year(now)&month(now)&day(now)&hour(now)&minute(now)&second(now)&MakeRandom(4)& "." & strFileType
set http=server.createobject("MSXML2.XMLHTTP")
Http.open "GET",url,false
Http.send()
if Http.readystate<>4 then exit function
getHTTPimg=Http.responseBody
set http=nothing
if err.number<>0 then err.Clear 
Set objStream = Server.CreateObject("ADO"&"DB.Stream")
objStream.Type =1
objStream.Open
objstream.write getHTTPimg
objstream.SaveToFile server.MapPath("../../"&web_picdir&strFileName),2
objstream.Close()
set objstream=nothing
GetImage=strFileName
end function

Function MakeRandom(ByVal maxLen)
  Dim strNewPass
  Dim whatsNext, upper, lower, intCounter
  Randomize
 For intCounter = 1 To maxLen
   upper = 57
   lower = 48
   strNewPass = strNewPass & Chr(Int((upper - lower + 1) * Rnd + lower))
 Next
   MakeRandom = strNewPass
End Function

Function showerr(msg,url)
Response.Write "<script>"&vbcrlf
Response.Write "var pgo=0;"&vbcrlf
Response.Write "function JumpUrl(){"&vbcrlf
Response.Write "if(pgo==0){ location='"&url&"'; pgo=1; }}"&vbcrlf
Response.Write "document.write(""<br/><div style='width:400px;margin:0px auto;padding-top:4px;height:24px;line-height: 24px;font-size:10pt;border:1px solid #cad9ea;background-color:#f5fafe;'>&nbsp;雷风影视系统提示信息：</div>"");"&vbcrlf
Response.Write "document.write(""<div style='width:400px;margin:0px auto;height:100;font-size:10pt;text-align: center;border:1px solid #cad9ea;background-color:#ffffff'><br/><br/>"");"&vbcrlf
Response.Write "document.write("""&msg&""");"&vbcrlf
Response.Write "document.write(""<br/><br/><a href='"&url&"'>如果你的浏览器没反应，请点击这里...</a><br/><br/></div>"");"&vbcrlf
Response.Write "setTimeout('JumpUrl()',5000);</script>"
Response.end
End Function

Function usersip()
Dim ip
ip = Trim(Request.ServerVariables("HTTP_X_FORWARDED_FOR"))
If ip = "" Then ip = Request.ServerVariables("REMOTE_ADDR")
usersip=ip
End Function

Function login_check()
	Dim AdminName,PassWord
		AdminName = NoSqlHack(Trim(Request.Cookies(web_url)("AdminName")))
		PassWord= NoSqlHack(Trim(Request.Cookies(web_url)("AdminPassword")))
		IF AdminName="" Or PassWord = "" Then
		   		Response.Write "<script>top.location.href='../admin_login.asp';</script>"
	  			Response.end
		   Exit Function
		Else
			Dim UserRs
			Set Userrs=conn.execute("Select name,[password] From "&web_dbtop&"admin Where name='" & AdminName & "' And [password]='" & PassWord & "'")
			IF UserRS.Eof And UserRS.Bof Then
				Response.Write "<script>top.location.href='../admin_login.asp';</script>"
	  			Response.end
			End if
			UserRS.Close:Set UserRS=Nothing
	   End IF
End Function

Function NoSqlHack(content)
	Dim f_NoSqlHack_AllStr,f_NoSqlHack_Str,f_NoSqlHack_i,Str_InputStr
	If content = "" Or IsNull(content) Then Exit Function
	Str_InputStr=content
	f_NoSqlHack_AllStr="dbcc|alter|drop|* |and|exec|or|insert|select|delete|update|count|master|truncate|declare|char|mid(|chr|set |where|xp_cmdshell|tab"
	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>"
			Response.End
		End if
	Next
	NoSqlHack = Replace(Replace(Str_InputStr,"'","''"),"%27","''")
End Function

Function addlog(logcontent)
	dim logtime
		logtime=now()
		conn.execute("INSERT INTO "&web_dbtop&"log (logcontent,logtime,logname,logip) VALUES ('"&logcontent&"','"&logtime&"','"&Request.Cookies(web_url)("AdminName")&"','"&usersip()&"')")
End Function

Function showselect(tables,tablesname,selectname,selecttitle,selectid)
	dim Rs
	Response.Write"<select name="""&selectname&""" dataType=""Require"" msg="""&selecttitle&""">"
	if selectid="" then
    	Response.Write"<option value="""">"&selecttitle&"</option>"
	end if
	set Rs=conn.execute("SELECT * FROM "&web_dbtop&tables&" Order by sort asc,id desc")
	do while not Rs.eof
		if selectid<>"" then
			if Rs("id")=cint(selectid) then
				Response.Write"<option value="&Rs("id")&" selected>"&Rs(tablesname)&"</option>" 	
			else
				Response.Write"<option value="&Rs("id")&">"&Rs(tablesname)&"</option>" 	
			end if
		else
			Response.Write"<option value="&Rs("id")&">"&Rs(tablesname)&"</option>" 
		end if
    Rs.movenext
	loop
	Rs.close:Set Rs = Nothing
    Response.Write"</select>"
End Function

Function storageselect(tables,tablesname,selectname,selecttitle,selectid)
	dim Rs
	Response.Write"<select name="""&selectname&""">"
	if selectid="" then
    	Response.Write"<option value="""">"&selecttitle&"</option>"
	end if
	set Rs=conn.execute("SELECT * FROM "&web_dbtop&tables&" Order by sort asc,id desc")
	do while not Rs.eof
		if selectid<>"" then
			if Rs("id")=cint(selectid) then
				Response.Write"<option value="&Rs("id")&" selected>"&Rs(tablesname)&"</option>" 	
			else
				Response.Write"<option value="&Rs("id")&">"&Rs(tablesname)&"</option>" 	
			end if
		else
			Response.Write"<option value="&Rs("id")&">"&Rs(tablesname)&"</option>" 
		end if
    Rs.movenext
	loop
	Rs.close:Set Rs = Nothing
    Response.Write"</select>"
End Function

Function storageplay(selectname,playernum,playerid)
	dim rs
    Response.Write"<select name="""&selectname&""" dataType=""Require"" msg=""请选择入库播放器"">"
    Response.Write"<option value="""">请选择播放器</option>"
	if playerid<>"" then 
	set rs=conn.execute("select movietype from "&web_dbtop&"movieurl where movienum="&playernum&" and movieid="&playerid&"")
	if not rs.eof then
	movietype=rs("movietype")
	end if
	rs.close:Set rs = Nothing
	end if
	set rs=conn.execute("select id,playername from "&web_dbtop&"player Order by sort asc,id desc")
	do while not rs.eof
		if playerid<>"" then
			if rs("id")=movietype then
				Response.Write"<option value="&rs("id")&" selected>"&rs("playername")&"</option>" 	
			else
				Response.Write"<option value="&rs("id")&">"&rs("playername")&"</option>" 	
			end if
		else
			Response.Write"<option value="&rs("id")&">"&rs("playername")&"</option>" 
		end if
    rs.movenext
	loop
	rs.close:Set rs = Nothing
    Response.Write"</select>"
End Function

Function selecturl(tables,tablesname)
	dim rs
    Response.Write"<select onchange=javascript:window.location.href=this.options[this.selectedIndex].value>"
    Response.Write"<option value=""admin_collecting_movie.asp"">全部采集影片</option>"
	set rs=conn.execute("SELECT "&tablesname&" FROM "&web_dbtop&tables&" Order by id desc")
	do while not rs.eof
		if Trim(Request(tables))<>"" then
			if rs("id")=cint(Trim(Request(tables))) then
				Response.Write"<option value=admin_collecting_movie.asp?"&tablesname&"="&rs(tablesname)&" selected>"&rs(tablesname)&"</option>" 	
			else
				Response.Write"<option value=admin_collecting_movie.asp?"&tablesname&"="&rs(tablesname)&">"&rs(tablesname)&"</option>" 	
			end if
		else
			Response.Write"<option value=admin_collecting_movie.asp?"&tablesname&"="&rs(tablesname)&">"&rs(tablesname)&"</option>" 
		end if
    rs.movenext
	loop
	rs.close:Set rs = Nothing
    Response.Write"</select>"
End Function

Function showcontent(tables,tablesname,id)
on error resume next
	dim Rs
	set Rs=conn.execute("SELECT "&tablesname&" FROM "&web_dbtop&tables&" where id="&id)
	if not Rs.eof then
	showcontent=rs(tablesname)
	end if
	Rs.close:Set Rs = Nothing
End Function

Function showstoragecontent(tables,tablesname,name)
on error resume next
	dim Rs
	set Rs=conn.execute("SELECT id FROM "&web_dbtop&tables&" where "&tablesname&"='"&name&"'")
	if not Rs.eof then
	showstoragecontent=rs("id")
	end if
	Rs.close:Set Rs = Nothing
End Function

Function cturn(tables,id)
dim rs
set rs=conn.execute("SELECT "&tables&"id FROM "&web_dbtop&"c"&tables&" where "&tables&"name='"&id&"'")
if not rs.eof then
cturn=rs(tables&"id")
end if 
rs.Close:Set rs = Nothing
End Function

Function DelHtml(Str1)
  Dim regEx
  Set regEx = New RegExp
  regEx.Pattern = "(<[^>]*?>)"
  regEx.Global = True
  regEx.IgnoreCase = True
  DelHtml = replace(regEx.Replace(""&str1,""),"&nbsp;","")
End Function

function rtrimVBcrlf(str)
dim pos,isBlankChar
pos=len(str)
isBlankChar=true
while isBlankChar and pos>=2
if mid(str,pos-1,2)=VBcrlf then
pos=pos-2
else
isBlankChar=false
end if
wend
rtrimVBcrlf=left(str,pos)
end function

Function deletefile(FileStr)
	   Dim FSO
	   On Error Resume Next
	   Set FSO = CreateObject("Scripting.FileSystemObject")
		If FSO.FileExists(Server.MapPath(FileStr)) Then
			FSO.DeleteFile Server.MapPath(FileStr), True
		Else
		deletefile = True
		End If
	   Set FSO = Nothing
	   If Err.Number <> 0 Then
	   Err.Clear:DeleteFile = False
	   Else
	   deletefile = True
	   End If
End Function
%>