% Option Explicit %>
<%
'==============================================================================
'软件名称:风讯网站信息管理系统
'当前版本:Foosun Content Manager System(FoosunCMS V3.2SP1)
'最新更新:2006.50
'==============================================================================
'Copyright (C) 2002-2004 Foosun.Net All rights reserved.
'商业注册联系:028-85098980-601,项目开发:028-85098980-606、609,客户支持:608
'产品咨询QQ:394226379,159410,125114015
'技术支持QQ:315485710,66252421
'项目开发QQ:415637671,655071
'程序开发:四川风讯科技发展有限公司(Foosun Inc.)
'Email:service@Foosun.cn
'MSN:skoolls@hotmail.com
'论坛支持:风讯在线论坛(http:/bbs.foosun.net)
'官方网站:www.Foosun.cn 演示站点:test.cooin.com
'网站通系列(智能快速建站系列):www.ewebs.cn
'==============================================================================
'免费版本请在程序首页保留版权信息,并做上本站LOGO友情连接
'风讯公司保留此程序的法律追究权利
'==============================================================================
Dim DBC,Conn
Set DBC=new DataBaseClass
Set Conn=DBC.OpenConnection
Set DBC=Nothing
'加载 FS系统缓存
Dim ClassCache
Set ClassCache = New Cls_FsCache
ClassCache.Name="ConfigCache"
If ClassCache.IsVaild = False Then
ClassCache.ReLoadCache("")
End If
ClassCache.Name="ClassCache"
If ClassCache.IsVaild = False Then
ClassCache.ReLoadCache("")
End If
Set ClassCache=Nothing
Dim DownCacheNameStr
DownCacheNameStr=LCase(Replace(Replace(Server.MapPath("/"&SysRootDir) & "_ConfigCache","\",""),":",""))
Dim ResponseBodyStr,ResponseStr,ErrorStr,RsAddressObj,FileURL
Dim Server_Name,Server_V1,Server_V2
Dim OnlyFileUrlTF '只有文件地址
OnlyFileUrlTF = False
ResponseBodyStr = "
下载" & Chr(13)
ResponseBodyStr = ResponseBodyStr & "" & Chr(13)
ResponseBodyStr = ResponseBodyStr & "" & Chr(13)
ResponseBodyStr = ResponseBodyStr & "" & Chr(13)
ErrorStr = "" & Chr(13)
ErrorStr = ErrorStr & ResponseBodyStr & Chr(13)
ErrorStr = ErrorStr & "错误! 读取地址时出错 5秒后自动返回首页..." & Chr(13)
FileURL = Request("FileUrl")
if Request("ID")="" And FileURL = "" then
Response.Write ErrorStr
Set Conn = Nothing
Response.End
end if
if FileUrl = "" then
Set RsAddressObj = Server.CreateObject(G_FS_RS)
RsAddressObj.Open "Select Url from FS_DownLoadAddress where ID='" & trim(Replace(Replace(Request("ID"),"'",""),Chr(39),"")) & "'",Conn,1,1
if Not RsAddressObj.Eof then
FileURL = RsAddressObj("Url")
else
RsAddressObj.Close
Set RsAddressObj = Nothing
Set Conn = Nothing
Response.Write ErrorStr
Response.End
end if
RsAddressObj.Close
OnlyFileUrlTF = False
else
OnlyFileUrlTF = True
end if
'防盗链
Dim DownLoadConfigObj
Set DownLoadConfigObj = Conn.Execute("Select * from FS_DownLoadConfig")
if DownLoadConfigObj("Lock") = 1 then
Server_Name = Len(Request.ServerVariables("SERVER_NAME"))
Server_V1 = Left(Replace(Cstr(Request.ServerVariables("HTTP_REFERER")),"http:/",""),Server_Name)
Server_V2 = Left(Cstr(Request.ServerVariables("SERVER_NAME")),Server_Name)
if Server_V1 <> Server_V2 and Server_V1 <> "" and Server_V2 <> "" then
Set DownLoadConfigObj = Nothing
Set Conn = Nothing
Response.write("")
Response.End
end if
end if
'判断IP限制
Dim RequestIPAddress,IPList,IPType,Flag,DownLoadTF
RequestIPAddress = Request.ServerVariables("REMOTE_ADDR")
IPList = DownLoadConfigObj("IPList")
IPType = DownLoadConfigObj("IPType")
Flag = CheckIPAddress(IPList,RequestIPAddress)
'Response.Write(Flag)
'Response.End
if Not IsNull(IPList) And IPList <> "" then
if Flag = True then
if IPType = 1 then
DownLoadTF = False
else
DownLoadTF = True
end if
else
if IPType = 1 then
DownLoadTF = True
else
DownLoadTF = False
end if
end if
else
DownLoadTF = True
end if
if DownLoadTF then
if OnlyFileUrlTF = False then
RsAddressObj.Open "Select ClickNum from FS_DownLoad where DownLoadID='" & trim(Replace(Replace(Request("DownID"),"'",""),Chr(39),"")) & "'",Conn,1,2
if Not RsAddressObj.eof then
RsAddressObj("ClickNum") = CLng(RsAddressObj("ClickNum")) + 1
RsAddressObj.UpDate
else
RsAddressObj.Close
Set RsAddressObj = Nothing
Set Conn = Nothing
Response.Write ErrorStr
Response.End
end if
end if
Set RsAddressObj = Nothing
if InStr(LCase(FileURl),":/") = 0 then
FileURl = Application(DownCacheNameStr)(0) & FileUrl
end if
Response.Redirect FileURL
else
Response.write("")
end if
Response.End
Set DownLoadConfigObj = Nothing
Set Conn = Nothing
Function CheckIPAddress(IPList,IPAddress)
Dim TempArray,i,j,AddressArray,BeginAddressArray,EndAddressArray,IPAddressArray
IPAddressArray = Split(IPAddress,".")
if UBound(IPAddressArray) <> 3 then
CheckIPAddress = False
Exit Function
end if
if IsNull(IPList) then
CheckIPAddress = False
else
if IPList <> "" then
TempArray = Split(IPList,"$")
for i = LBound(TempArray) to UBound(TempArray)
AddressArray = Split(TempArray(i),"-")
if UBound(AddressArray) = 1 then
BeginAddressArray = Split(AddressArray(0),".")
EndAddressArray = Split(AddressArray(1),".")
if (UBound(BeginAddressArray) = 3) and (UBound(EndAddressArray) = 3) then
for j = LBound(BeginAddressArray) to UBound(BeginAddressArray)
'Response.Write(EndAddressArray(j) = BeginAddressArray(j))
if (EndAddressArray(j) = BeginAddressArray(j)) then
if EndAddressArray(j) <> IPAddressArray(j) then
if (CInt(IPAddressArray(j)) >= CInt(BeginAddressArray(j))) And (CInt(IPAddressArray(j)) <= CInt(EndAddressArray(j))) then
CheckIPAddress = True
Exit Function
end if
end if
else
if (CInt(IPAddressArray(j)) >= CInt(BeginAddressArray(j))) And (CInt(IPAddressArray(j)) <= CInt(EndAddressArray(j))) then
CheckIPAddress = True
Exit Function
end if
end if
Next
end if
end if
'Response.End
Next
CheckIPAddress = False
else
CheckIPAddress = False
end if
end if
End Function
%>