📄 download.asp
字号:
<%@LANGUAGE="VBSCRIPT" CODEPAGE="936"%>
<%option explicit
response.Buffer=true
%>
<!--#include file="../Conn.asp"-->
<!--#include file="../SysCls/KS_UserCommonCls.asp"-->
<!--#include file="../SysCls/KS_RefreshCls.asp"-->
<%
Dim KSCls
Set KSCls = New DownLoad
KSCls.Execute()
Set KSCls = Nothing
Class DownLoad
Private KSCMS,KSUser, KSRFObj
Private FileContent,RSObj,SqlStr,ShowInfoStr,InfoPurview,ReadPoint,ChargeType,PitchTime,ReadTimes
Private DomainStr,ID,ClassID,UserLoginTF,PayTF,DownUrlTF,TitleStr,Rs,SQL,FoundErr,SoftName,DownID
Private Sub Class_Initialize()
Set KSCMS=New CommonCls
Set KSUser=New UserCls
Set KSRFObj = New Refresh
End Sub
Private Sub Class_Terminate()
Call KSCMS.CloseConn()
Set KSCMS=Nothing:Set KSUser=Nothing
End Sub
Public Sub Execute()
DownUrlTF=false
DomainStr=KSCMS.GetDomain
UserLoginTF=Cbool(KSUser.UserLoginChecked)
ID = KSCMS.ChkClng(KSCMS.G("ID"))
DownID = KSCMS.ChkClng(KSCMS.G("DownID"))
PayTF=KSCMS.G("PayTF")
If ID = 0 Then
TitleStr="下载错误提示"
ShowInfoStr = ShowInfoStr & "<li>错误的系统参数!请输入正确的软件ID</li>"
FoundErr=True
End If
If DownID = 0 Then
TitleStr="下载错误提示"
ShowInfoStr = ShowInfoStr & "<li>错误的系统参数!请输入正确的软件下载ID</li>"
FoundErr=True
End If
If Not KSCMS.CheckOuterUrl Then
ShowInfoStr = ShowInfoStr & "<li>非法下载，请不要盗链本站资源！</li>"
FoundErr=True
End If
If FoundErr Then Call ShowInfo :Exit Sub
SqlStr= "Select * From KS_DownLoad Where ID=" & ID
Set RSObj=Server.CreateObject("Adodb.Recordset")
RSObj.Open SqlStr,Conn,1,3
IF RSObj.Eof And RSObj.Bof Then
TitleStr="下载错误提示"
ShowInfoStr = ShowInfoStr & "<li>找不到你要下载的软件！</li>"
FoundErr=True:Call ShowInfo :Exit Sub
End IF
ID=RSObj("ID")
InfoPurview=Cint(RSObj("InfoPurview"))
ReadPoint=Cint(RSObj("ReadPoint"))
ChargeType=Cint(RSObj("ChargeType"))
PitchTime=Cint(RSObj("PitchTime"))
ReadTimes=Cint(RSObj("ReadTimes"))
ClassID=RSObj("Tid")
If InfoPurview=2 Then
IF UserLoginTF=false Then
Call GetNoLoginInfo
Else
IF InStr(RSObj("ArrGroupID"),KSUser.Get_GroupID)=0 Then
ShowInfoStr = ShowInfoStr & "<li>对不起，你没有下载本软件的权限!</li>"
FoundErr=True:Call ShowInfo :Exit Sub
Else
Call PayPointProcess()
End If
End If
ElseIF InfoPurview=0 And (KSCMS.GetClassConfig(ClassID,"ClassPurview")=1 Or KSCMS.GetClassConfig(ClassID,"ClassPurview")=2) Then
If UserLoginTF=false Then
Call GetNoLoginInfo
Else '尚待完善,根据会员所在会员组进行判断是否有查看本文的权限
Call PayPointProcess()
End If
Else
Call PayPointProcess()
End If
If DownUrlTF=true Then
If RSObj("FlagUrl") = 0 Then
ShowInfoStr = "<a href=""" & Split(Split(RSObj("DownUrls"), "|||")(DownID-1),"|")(1) & """><font color=blue>立即下载 --- " & RSObj("Title") & "</font></a>"
Else
ShowInfoStr = "<a href=""" & Conn.Execute("Select ServerUrl From KS_DownServer Where ID=" & DownID)(0) & RSObj("DownUrls") & """><font color=blue>立即下载 --- " & RSObj("Title") & "</font></a>"
End If
RSObj("Hits") = RSObj("Hits") + 1
If DateDiff("D", RSObj("LastHitsTime"), Now()) <= 0 Then
RSObj("HitsByDay") = RSObj("HitsByDay") + 1
Else
RSObj("HitsByDay") = 1
End If
If DateDiff("ww", RSObj("LastHitsTime"), Now()) <= 0 Then
RSObj("HitsByWeek") = RSObj("HitsByWeek") + 1
Else
RSObj("HitsByWeek") = 1
End If
If DateDiff("m", RSObj("LastHitsTime"), Now()) <= 0 Then
RSObj("HitsByMonth") = RSObj("HitsByMonth") + 1
Else
RSObj("HitsByMonth") = 1
End If
RSObj("LastHitsTime") = Now()
RSObj.Update
Else
TitleStr="操作提示"
End If
Call ShowInfo()
RSObj.Close:Set RSObj=Nothing
End Sub
'收费扣点处理过程
Sub PayPointProcess()
Dim UserChargeType:UserChargeType=KSUser.ChargeType
If Cint(ReadPoint)>0 Then
If UserChargeType=1 Then
Select Case ChargeType
Case 0
Call CheckPayTF("1=1")
Case 1
Call CheckPayTF("datediff('h',AddDate," & Application("SqlNowString") & ")<" & PitchTime)
Case 2
Call CheckPayTF("Times<" & ReadTimes)
Case 3
Call CheckPayTF("datediff('h',AddDate," & Application("SqlNowString") & ")<" & PitchTime & " or Times<" & ReadTimes)
Case 4
Call CheckPayTF("datediff('h',AddDate," & Application("SqlNowString") & ")<" & PitchTime & " and Times<" & ReadTimes)
Case 5
Call PayConfirm()
End Select
Elseif UserChargeType=2 Then
Dim Edays:Edays=KSUser.Edays-DateDiff("D",KSUser.BeginDate,now())
If Edays <=0 Then
ShowInfoStr="<div align=center>对不起，你的账户已过期 <font color=red>" & Edays & "</font> 天,此软件需要在有效期内才可以下载，请及时与我们联系！</div>"
Else
Call GetContent()
End If
Else
Call GetContent()
end if
Else
Call GetContent()
End IF
End Sub
'检查是否过期，如果过期要重复扣点券
'返回值 过期返回 true,未过期返回false
Sub CheckPayTF(Param)
Dim SqlStr:SqlStr="Select top 1 Times From KS_LogPoint Where ChannelID=3 And InfoID=" & ID & " And InOrOutFlag=2 and UserName='" & KSUser.Get_UserName & "' And (" & Param & ") Order By ID"
'response.write sqlstr
'response.end
Dim RS:Set RS=Server.CreateObject("ADODB.RECORDSET")
RS.Open SqlStr,conn,1,3
IF RS.Eof And RS.Bof Then
Call PayConfirm()
Else
RS.Movelast
RS(0)=RS(0)+1
RS.Update
Call GetContent()
End IF
RS.Close:Set RS=nothing
End Sub
Sub PayConfirm()
If UserLoginTF=false Then Call GetNoLoginInfo():Exit Sub
If Cint(KSUser.Get_Point)<ReadPoint Then
ShowInfoStr="<div align=center>对不起，你的可用" & KSCMS.PointName & "不足!下载本软件需要 <font color=red>" & ReadPoint & "</font> " & KSCMS.PointStr &",你还有 <font color=green>" & KSUser.Get_Point & "</font> " & KSCMS.PointStr & "</div>,请及时与我们联系！"
Else
If PayTF="yes" Then
IF Cbool(KSCMS.PointInOrOut(3,RSObj("ID"),KSUser.Get_UserName,2,ReadPoint,"系统","下载收费软件：<br>" & RSObj("Title")))=True Then Call GetContent()
Else
ShowInfoStr="<div align=center>下载本软件需要消耗 <font color=red>" & ReadPoint & "</font> " & KSCMS.PointStr &",你目前尚有 <font color=green>" & KSUser.Get_Point & "</font> " & KSCMS.PointStr &"可用,下载本软件后，您将剩下 <font color=blue>" & KSUser.Get_Point-ReadPoint & "</font> " & KSCMS.PointStr &"</div><div align=center>你确实愿意花 <font color=red>" & ReadPoint & "</font> " & KSCMS.PointStr & "来下载本软件吗?</div><div> </div><div align=center><a href=""?ID=" & ID & "&PayTF=yes&DownID=" & DownID & """>我愿意</a> <a href=""" &DomainStr & """>我不愿意</a></div>"
End If
End If
End Sub
Sub GetNoLoginInfo()
ShowInfoStr="<div align=center>对不起，你还没有登录，本软件至少要求本站的注册会员才可下载!</div><div align=center>如果你还没有注册，请<a href=""" & DomainStr & "Register/UserReg_Step1.asp""><font color=red>点此注册</font></a>吧!</div><div align=center>如果您已是本站注册会员，赶紧<a href=""" & domainstr & "Member/login.asp""><font color=red>点此登录</font></a>吧！</div>"
End Sub
Sub GetContent()
TitleStr=RSObj("Title")
DownUrlTF=True
End Sub
Function ShowInfo()
With Response
.Write "<html><head><title>" & TitleStr & "</title>" & vbNewLine
.Write "<script>"&vbnewline
.Write " <!--" & vbNewLine
.Write " window.moveTo(100,100);" & vbNewLine
.Write " window.resizeTo(550,400);" & vbNewLine
.Write "//-->" & vbNewLine
.Write "</script>" & vbNewLine
.Write "<meta http-equiv=Content-Type content=text/html; charset=gb2312>" & vbNewLine
.Write "<style type=""text/css"">" & vbNewLine
.Write "body {font-size: 12px;font-family: 宋体;}" & vbNewLine
.Write "td {font-size: 12px; font-family: 宋体; line-height: 18px;table-layout:fixed;word-break:break-all}" & vbNewLine
.Write "a {color: #555555; text-decoration: none}" & vbNewLine
.Write "a:hover {color: #FF8C40; text-decoration: underline}" & vbNewLine
.Write "th{ background-color: #0A95D2;color: white;font-size: 12px;font-weight:bold;height: 25;}" & vbNewLine
.Write ".TableRow1 {background-color:#F7F7F7;}" & vbNewLine
.Write ".TableRow2 {background-color:#F0F0F0;}" & vbNewLine
.Write ".TableBorder {border: 1px #3795D2 solid ; background-color: #FFFFFF;font: 12px;}" & vbNewLine
.Write "</style>" & vbNewLine
.Write "</head><body><br /><br />" & vbNewLine
.Write "<table width=500 border=0 align=center cellpadding=0 cellspacing=0 class=TableBorder>"
.Write "<tr>"
.Write " <th>系 统 提 示</th>"
.Write "</tr>"
.Write "<tr height=110>"
.Write "<td class=TableRow1 align=center>" & ShowInfoStr & "</td>"
.Write "</tr>"
.Write "<tr height=22><td align=center class=TableRow2><a href=""" & KSCMS.GetDomain & """>返回首页...</a> | <a href=javascript:window.close()>关闭本窗口...</a></td></tr>"
.Write "</table>"
.Write "<br /><br /></body></html>"
End With
End Function
End Class
%>
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -