cl_clssystem.asp

淘客网上商店网站程序 淘客网上商店网站程序 淘客网上商店网站程序

		if tRs.Bof and tRs.Eof then
			IsPay = False
		else
			IsPay = True
			'if *** then IsPay=False
			tRs("ConsumeNums") = tRs("ConsumeNums") + 1
			tRs.Update
		end if
		tRs.Close : Set tRs=Nothing
		Select Case Cint(User_Info(17))
		Case 1
			if IsPay=False and (sInfoPoint>0 or sInfoMoney>0) then
				if sUserPoint < sInfoPoint Or sUserMoney < sInfoMoney Then
					ErrMessage = Language.selectSingleNode("//PointLack").text
					ErrMessage = Replace(ErrMessage,"{$infopoint}",sInfoPoint)
					ErrMessage = Replace(ErrMessage,"{$userpoint}",sUserPoint)
					ErrMessage = Replace(ErrMessage,"{$infomoney}",sInfoMoney)
					ErrMessage = Replace(ErrMessage,"{$usermoney}",sUserMoney)
					ErrMessage = ReplaceItem(ErrMessage)
					Exit Function
				End If
				If CLng(Channel.SelectSingleNode("@moduleid").text)=1 And lcase(request("Pay"))<>"yes" Then
					ErrMessage = Language.selectSingleNode("//PayConfirm").text
					ErrMessage=Replace(ErrMessage,"{$infopoint}",sInfoPoint)
					ErrMessage=Replace(ErrMessage,"{$userpoint}",sUserPoint)
					ErrMessage=Replace(ErrMessage,"{$infomoney}",sInfoMoney)
					ErrMessage=Replace(ErrMessage,"{$usermoney}",sUserMoney)
					ErrMessage=Replace(ErrMessage,"{$filename}",FileName)
					ErrMessage=Replace(ErrMessage,"{$infoid}",InfoID)
					ErrMessage = ReplaceItem(ErrMessage)
					Exit Function
				End if
				Execute_U("update " & Db.UserTable & " set " & Db.UserPoint & "=" & Db.UserPoint & "-" & sInfoPoint & "," & Db.UserMoney & "=" & Db.UserMoney & "-" & sInfoMoney & " where " & Db.UserID & "=" & Clng(UserID))
				Execute_L("Insert Into Cl_ConsumeLog (ChannelID,InfoID,Title,Url,UserID,UserName,ConsumePoint,ConsumeMoney,ConsumeNums,ConsumeTime) values ("&ChannelID&","&InfoID&",'"&CheckStr(InfoTitle)&"','"&Request.ServerVariables("PATH_INFO")&"',"&UserID&",'"&MemberName&"',"&sInfoPoint&","&sInfoMoney&",0,'"&Now&"')")
				GetCacheUserInfo
				sBackMoney = sBackMoney + Clng(sInfoMoney*sBackMoneyRate/100)
				sBackPoint = sBackPoint + Clng(sInfoPoint*sBackPointRate/100)
				if sBackMoney>0 or sBackPoint>0 then
					Execute_U("update " & Db.UserTable & " set " & Db.UserPoint & "=" & Db.UserPoint & "+" & sBackPoint & "," & Db.UserMoney & "=" & Db.UserMoney & "+" & sBackMoney & " where " & Db.UserName & "='" & sEditor & "'")
				end if
			end if
		Case 2
			if Clng(User_Info(22))<=0 Then
				ErrMessage = Language.selectSingleNode("//DateOver").text
				ErrMessage = ReplaceItem(ErrMessage)
				Exit Function
			elseif IsPay=False and sInfoMoney>0 then
				if sUserMoney < sInfoMoney then '2
					ErrMessage = Language.selectSingleNode("//PointLack").text
					ErrMessage = Replace(ErrMessage,"{$infopoint}",0)
					ErrMessage = Replace(ErrMessage,"{$userpoint}",0)
					ErrMessage = Replace(ErrMessage,"{$infomoney}",sInfoMoney)
					ErrMessage = Replace(ErrMessage,"{$usermoney}",sUserMoney)
					ErrMessage = ReplaceItem(ErrMessage)
					Exit Function
				end if
				Execute_U("update " & Db.UserTable & " set " & Db.UserMoney & "=" & Db.UserMoney & "-" & sInfoMoney & " where " & Db.UserID & "=" & Clng(UserID))
				Execute_L("Insert Into Cl_ConsumeLog (ChannelID,InfoID,Title,Url,UserID,UserName,ConsumePoint,ConsumeMoney,ConsumeNums,ConsumeTime) values ("&ChannelID&","&InfoID&",'"&CheckStr(InfoTitle)&"','"&Request.ServerVariables("PATH_INFO")&"',"&UserID&",'"&MemberName&"',0,"&sInfoMoney&",0,'"&Now&"')")
				GetCacheUserInfo
				sBackMoney = sBackMoney + Clng(sInfoMoney*sBackMoneyRate/100)
				sBackPoint = sBackPoint + Clng(sInfoPoint*sBackPointRate/100)
				if sBackMoney>0 or sBackPoint>0 then
					Execute_U "update " & Db.UserTable & " set " & Db.UserPoint & "=" & Db.UserPoint & "+" & sBackPoint & "," & Db.UserMoney & "=" & Db.UserMoney & "+" & sBackMoney & " where " & Db.UserName & "='" & sEditor & "'"
				end if
			End if
		Case Else
			ErrMessage = Language.selectSingleNode("//DateOver").text
			ErrMessage = ReplaceItem(ErrMessage)
			Exit Function
		End Select
		TrueInfoPurview = True
	End Function

	'取得用户级别
	Public Function GetUserGroupName(Byval sLevel)
		Dim sGroup
		If IsNull(sLevel) or sLevel="" then Exit Function
		On Error Resume Next
		if Instr(sLevel,",")>0 then
			Dim sL
			sLevel=Split(sLevel,",")
			for sL=0 to Ubound(sLevel)
			If sl>0 Then sGroup = sGroup & ","
			sGroup = sGroup & Application(CacheName & "_usergrouplist").DocumentElement.selectSingleNode("usergroup[@id="&sLevel(sL)&"]/@groupname").text
			Next
		else
			sGroup = Application(CacheName & "_usergrouplist").DocumentElement.selectSingleNode("usergroup[@id="&sLevel&"]/@groupname").text
		end if
		GetUserGroupName=sGroup
	End Function

	Public Function UserGroup_Option(Byval sLevel)
		Dim Node,sTemp
		For Each Node In Application(CacheName & "_usergrouplist").DocumentElement.selectNodes("usergroup")
			if InStr(","&sLevel&",",","&Trim(Node.SelectSingleNode("@id").text)&",")>0 then
				sTemp=sTemp & "<option value='" & Node.SelectSingleNode("@id").text & "' selected>" & Node.SelectSingleNode("@groupname").text & "</option>"
			else
				sTemp=sTemp & "<option value='" & Node.SelectSingleNode("@id").text & "'>" & Node.SelectSingleNode("@groupname").text & "</option>"
			end if
		Next
		UserGroup_Option = sTemp
		sTemp = Empty
		Set Node = Nothing
	End Function

	Rem 加载XML用户组列表
	Public Sub Load_UserGroupList()
		Dim Rs
		Set Rs = Execute("Select * from Cl_UserGroup Order by ID")
		Application.Lock
		Set Application(CacheName&"_usergrouplist") = RecordsetToxml(Rs,"usergroup","usergrouplist")
		Application.unLock
		Set Rs = Nothing
		'Application(CacheName&"_usergrouplist").Save(Server.MapPath("/usergrouplist.xml"))
	End Sub

	Public Function GetClassUrl(Byval sPathType, Byval sHtmlDir, Byval sChannelDir, Byval sParentPath, _
		Byval sClassID, Byval sParentDir, Byval sClassDir, Byval sIsCreate, Byval sCreateFileExt)
		if Clng(sIsCreate)=1 and CBool(Channel.selectSingleNode("@iscreatelist").text) then
			GetClassUrl=GetItemPath(sPathType, sHtmlDir, sChannelDir, sParentPath, sClassID, sParentDir, sClassDir) & sClassID &"_Index." & sCreateFileExt
		else
			GetClassUrl=sChannelDir &"/ShowClass.asp?ClassID="&sClassID
		end if
	End Function

	Public Function GetItemPath(Byval sPathType, Byval sHtmlDir, Byval sChannelDir, _
		Byval sParentPath, Byval sClassID, Byval sParentDir, Byval sClassDir)
		Select Case Clng(sPathType)
		Case 0      'HtmlDir/频道/大类/小类/文件
			GetItemPath = sHtmlDir & sChannelDir & "/" & sParentDir & sClassDir & "/"
		Case 1      'HtmlDir/频道/大类(ClassID)/小类(ClassID)/文件
			GetItemPath = sHtmlDir & sChannelDir & "/" & GetClassIDPath(sParentPath, sClassID) & "/"
		Case 2      'HtmlDir/频道/栏目(英文)/文件
			GetItemPath = sHtmlDir & sChannelDir & "/" & sClassDir & "/"
		Case 3      'HtmlDir/频道/栏目(ClassID)/文件
			GetItemPath = sHtmlDir & sChannelDir & "/" & "Class" & sClassID&"/"
		Case 4      'HtmlDir/频道/文件
			GetItemPath = sHtmlDir & sChannelDir & "/"
		Case 5      'HtmlDir/频道/年月/文件
			GetItemPath = sHtmlDir & sChannelDir & "/" & Year(Now()) & Right("0" & Month(Now()),2) & "/"
		Case 6      'HtmlDir/频道/年/月/文件
			GetItemPath = sHtmlDir & sChannelDir & "/" & Year(Now()) & "/" & Right("0" & Month(Now()),2) & "/"
		Case 7      '频道/Html目录/大类(英文目录)/小类(英文目录)/文件
			GetItemPath = sChannelDir & "/" & sHtmlDir & sParentDir & sClassDir & "/"
		Case 8      '频道/Html目录/大类(ClassID)/小类(ClassID)/文件
			GetItemPath = sChannelDir & "/" & sHtmlDir & GetClassIDPath(sParentPath, sClassID) & "/"
		Case 9      '频道/大类(英文目录)/小类(英文目录)/文件
			GetItemPath = sChannelDir & "/" & sParentDir & sClassDir & "/"
		Case 10      '频道/大类(ClassID)/小类(ClassID)/文件
			GetItemPath = sChannelDir & "/" & GetClassIDPath(sParentPath, sClassID) & "/"
		Case 11      '频道/Html目录/栏目(英文目录)/文件
			GetItemPath = sChannelDir & "/" & sHtmlDir & "/" & sClassDir & "/"
		Case 12      '频道/Html目录/栏目(ClassID)/文件
			GetItemPath = sChannelDir & "/" & sHtmlDir & "/" & "Class" & sClassID & "/"
		Case 13      '频道/栏目(英文目录)/文件
			GetItemPath = sChannelDir & "/" & sClassDir & "/"
		Case 14      '频道/栏目(ClassID)/文件
			GetItemPath = sChannelDir & "/" & "Class" & sClassID&"/"
		Case 15      '频道/Html目录/文件
			GetItemPath = sChannelDir & "/" & sHtmlDir & "/"
		Case 16      '频道/Html目录/年月/文件
			GetItemPath = sChannelDir & "/" & sHtmlDir & "/" & Year(Now()) & Right("0" & Month(Now()),2) & "/"
		Case 17      '频道/Html目录/年/月/文件
			GetItemPath = sChannelDir & "/" & sHtmlDir & "/" & Year(Now()) & "/" & Right("0" & Month(Now()),2) & "/"
		Case Else
			GetItemPath = sHtmlDir & sChannelDir & "/" & sParentDir & sClassDir & "/"
		End Select
		GetItemPath = Replace(GetItemPath, "//", "/")
		if Not CheckFolder(Webdir&GetItemPath,False) then
			dim objFSO,sPath,tPath,i
			Set objFSO = Server.CreateObject(Trim(Web_Info(13)))
			tPath	= Split(GetItemPath,"/")
			sPath	= WebDir
			For i=0 to Ubound(tPath)-1
				If objFSO.FolderExists(Server.MapPath(sPath & tPath(i)))=False Then
					objFSO.CreateFolder Server.MapPath(sPath & tPath(i))
				End If
				sPath = sPath & tPath(i) & "/"
			Next
			tPath = Empty
			Set objFSO = Nothing
		end if
	End Function

	Public Function GetItemFileName(ByVal sType, ByVal sClassID, ByVal sInfoID, ByVal sInfoTime)
		Select Case Clng(sType)
		Case 0      'ID + 时间(20051001234545)
			GetItemFileName = sInfoID & Format_Time(sInfoTime,8)
		Case 1      'ID
			GetItemFileName = sInfoID
		Case 2      'ID + 时间(20051001234545)
			GetItemFileName = Format_Time(sInfoTime,8)
		Case 3      '栏目ID + _ + ID + 时间(20051001234545)
			GetItemFileName = sClassID & "_" & sInfoID & Format_Time(sInfoTime,8)
		Case 4      '栏目ID + _ + ID
			GetItemFileName = sClassID & "_" & sInfoID
		Case 5      '栏目ID + _ + 时间(20051001234545)
			GetItemFileName = sClassID & "_" & Format_Time(sInfoTime,8)
		Case Else   'ID
			GetItemFileName = sInfoID
		End Select
	End Function

	Public Function GetItemIndexPath(ByVal sPathType, ByVal sHtmlDir, ByVal sChannelDir)
		Select Case Clng(sPathType)
		Case 0, 1, 2, 3, 4, 5, 6		 'HtmlDir/频道/
			GetItemIndexPath = sHtmlDir & sChannelDir & "/"
		Case 7, 8, 11, 12, 15, 16, 17     '频道/Html目录/
			GetItemIndexPath = sChannelDir & "/" & sHtmlDir & "/"
		Case 9, 10, 13, 14		 '频道/
			GetItemIndexPath = sChannelDir & "/"
		Case Else
			GetItemIndexPath = sHtmlDir & sChannelDir & "/"
		End Select
		GetItemIndexPath = Replace(GetItemIndexPath, "//", "/")
		if Not CheckFolder(Webdir&GetItemIndexPath&"Class/",False) then
			dim objFSO,sPath,tPath,i
			Set objFSO = Server.CreateObject(Trim(Web_Info(13)))
			tPath	= Split(GetItemIndexPath,"/")
			sPath	= WebDir
			For i=0 to Ubound(tPath)-1
				If objFSO.FolderExists(Server.MapPath(sPath & tPath(i)))=False Then
					objFSO.CreateFolder Server.MapPath(sPath & tPath(i))
				End If
				sPath = sPath & tPath(i) & "/"
			Next
			On Error Resume Next
			objFSO.CreateFolder Server.MapPath(sPath&"Class/")
			objFSO.CreateFolder Server.MapPath(sPath&"Special/")
			objFSO.CreateFolder Server.MapPath(sPath&"Update/")
			objFSO.CreateFolder Server.MapPath(sPath&"Elite/")
			objFSO.CreateFolder Server.MapPath(sPath&"Hot/")
			tPath = Empty
			Set objFSO = Nothing
		end if
	End Function
	Public Sub CreateFolder(Byval sFolder)
		On Error Resume Next
		Dim objFSO
		err=0
		sFolder=Server.MapPath(sFolder)
		Set objFSO = Server.CreateObject(Trim(Web_Info(13)))
		If Not objFSO.FolderExists(sFolder) Then
			objFSO.CreateFolder sFolder
		End If
		Set objFSO = Nothing
		err=0
	End Sub
	Public Sub DelFolder(Byval sFolder)
		On Error Resume Next
		Dim objFSO
		err=0
		sFolder=Server.MapPath(sFolder)
		Set objFSO = Server.CreateObject(Trim(Web_Info(13)))
		If objFSO.FolderExists(sFolder) Then
			objFSO.DeleteFolder sFolder,True
		End If
		Set objFSO = Nothing
		err=0
	End Sub
	Public Function MoveFolder(Byval oFolder,Byval nFolder)
		On Error Resume Next
		Dim objFSO
		err=0
		MoveFolder=False
		oFolder=Server.MapPath(oFolder)
		nFolder=Server.MapPath(nFolder)
		Set objFSO = Server.CreateObject(Trim(Web_Info(13)))
		If objFSO.FolderExists(nFolder) Then
			MoveFolder=False
		Else
			objFSO.MoveFolder oFolder,nFolder
			MoveFolder=True
		End If
		Set objFSO = Nothing
		err=0
	End Function
	'检查目录是否存在！(sFolderPath,sIsCreate 不存在是否创建)
	Public Function CheckFolder(byval sFolder,byval sIsCreate)
		On Error Resume Next
		Dim objFSO
		CheckFolder=False:err=0
		sFolder=Server.MapPath(sFolder)
		Set objFSO = Server.CreateObject(Trim(Web_Info(13)))
		If objFSO.FolderExists(sFolder) Then
			CheckFolder=True
		ElseIf sIsCreate=True then
			objFSO.CreateFolder sFolder
			if err=0 then CheckFolder=True
		End If
		Set objFSO = Nothing
		err=0
	End Function
	'按月份自动分类（By梅傲风）
	Public Function CreatePath(Byval sTopPath,Byval sSort)
		Dim objFSO,sPath,tPath,i
		if Not IsNumeric(sSort) then sSort=0
		sTopPath=Replace(sTopPath&"/","//","/")
		Select Case sSort