const.asp

来自「小游戏网站演示www.4399.io 拥有4万条游戏数据」· ASP 代码 · 共 454 行 · 第 1/2 页

<!--#include file="cls_main.asp"-->
<%
'生成HTML是否使用分类目录,1=是,0=否
Const IsUseClassDir = 1
'是否显示标题注释,1=是,0=否
Const IsUseRemark = 1
'--系统XML版本设置
Const MsxmlVersion = ".3.0"
'-- 是否随机显示下载地址(False=否,True=是)
Const IsRandomAddress = False
Const IsURLRewrite = False

Dim SERVER_OBJECT_NAME(5)
SERVER_OBJECT_NAME(0) = "Scrip"+"ting"+"."+"File"+"System"+"Object"
SERVER_OBJECT_NAME(1) = "ADO"+"DB"+"."+"Str"+"eam"
SERVER_OBJECT_NAME(2) = "Micro"+"soft"+"."+"XML"+"HTTP"
SERVER_OBJECT_NAME(3) = "MS"+"XML2"+"."+"DOM"+"Document"+MsxmlVersion
SERVER_OBJECT_NAME(4) = "MS"+"XML2"+"."+"Free"+"Threaded"+"DOMDocument"+MsxmlVersion
SERVER_OBJECT_NAME(5) = "MS"+"XML2"+"."+"XSL"+"Template"+MsxmlVersion

Dim Newasp,UserToday

Set Newasp = New NewaspMain_Cls
Newasp.ReadConfig

Public Function ShowChannelPath(ByVal ChannelPath,ByVal ClassPath)
	If IsUseClassDir = 1 Then
		ShowChannelPath = ChannelPath & ClassPath
	ElseIf IsUseClassDir = 2 Then
		ShowChannelPath = ChannelPath & Mid(ClassPath, 1, InStr(1, ClassPath, "/"))
	Else
		ShowChannelPath = ChannelPath
	End If
End Function

Public Function LoadRemark(ByVal str)
	If Len(str) = 0 Then Exit Function
	If IsUseRemark <> 1 Then Exit Function
	LoadRemark = " title=""" & Trim(str) & """"
End Function

'================================================
' 函数名：RelativePath2RootPath
' 作  用：转为根路径格式
' 参  数：url ----原URL
' 返回值：转换后的URL
'================================================
Function RelativePath2RootPath(url)
	Dim sTempUrl
	sTempUrl = url
	If Left(sTempUrl, 1) = "/" Then
		RelativePath2RootPath = sTempUrl
		Exit Function
	End If

	Dim sFilePath
	sFilePath = Request.ServerVariables("SCRIPT_NAME")
	sFilePath = Left(sFilePath, InstrRev(sFilePath, "/") - 1)
	Do While Left(sTempUrl, 3) = "../"
		sTempUrl = Mid(sTempUrl, 4)
		sFilePath = Left(sFilePath, InstrRev(sFilePath, "/") - 1)
	Loop
	RelativePath2RootPath = sFilePath & "/" & sTempUrl
End Function
'================================================
' 函数名：RootPath2DomainPath
' 作  用：根路径转为带域名全路径格式
' 参  数：url ----原URL
' 返回值：转换后的URL
'================================================
Function RootPath2DomainPath(url)
	Dim sHost, sPort
	sHost = Split(LCase(Request.ServerVariables("SERVER_PROTOCOL")), "/")(0) & "://" & Request.ServerVariables("HTTP_HOST")
	sPort = Request.ServerVariables("SERVER_PORT")
	If sPort <> "80" Then
		sHost = sHost & ":" & sPort
	End If
	RootPath2DomainPath = sHost & url
End Function
'================================================
' 函数名：ChkMapPath
' 作  用：相对路径转换为绝对路径
' 参  数：strPath ----原路径
' 返回值：绝对路径
'================================================
Public Function ChkMapPath(ByVal strPath)
	Dim fullPath
	strPath = Replace(Replace(Trim(strPath), "//", "/"), "\\", "\")

	If strPath = "" Then strPath = "."
	If InStr(strPath,":\") = 0 Then 
		fullPath = Server.MapPath(strPath)
	Else
		strPath = Replace(strPath,"/","\")
		fullPath = Trim(strPath)
		If Right(fullPath, 1) = "\" Then
			fullPath = Left(fullPath, Len(fullPath) - 1)
		End If
	End If
	ChkMapPath = fullPath
End Function
'================================================
' 函数名：CreatePath
' 作  用：按月份自动创建文件夹
' 参  数：fromPath ----原文件夹路径
'================================================
Function CreatePath(fromPath)
	Dim objFSO, uploadpath
	uploadpath = Year(Now) & "-" & Month(Now) '以年月创建上传文件夹，格式：2007－8
	uploadpath = Replace(uploadpath, ".", "_")
	On Error Resume Next
	Set objFSO = CreateObject(Newasp.FSO_ScriptName)
	If objFSO.FolderExists(Server.MapPath(fromPath & uploadpath)) = False Then
		objFSO.CreateFolder Server.MapPath(fromPath & uploadpath)
	End If
	If Err.Number = 0 Then
		CreatePath = uploadpath & "/"
	Else
		CreatePath = ""
	End If
	Set objFSO = Nothing
End Function
'================================================
'作  用：检查组件是否已经安装
'参  数：strClassString ----组件名
'返回值：True  ----已经安装
'        False ----没有安装
'================================================
Function IsObjInstalled(ByVal strClassString)
	Dim xTestObj,ClsString
	On Error Resume Next
	IsObjInstalled = False
	ClsString = strClassString
	Err = 0
	Set xTestObj = Server.CreateObject(ClsString)
	If Err = 0 Then IsObjInstalled = True
	If Err = -2147352567 Then IsObjInstalled = True
	Set xTestObj = Nothing
	Err = 0
	Exit Function
End Function
'--生成随机数函数
Function GetRandomizeCode()
	Randomize
	Dim m_strRandArray,m_intRandlen,m_strRandomize,i
	m_strRandArray = Array(0,1,2,3,4,5,6,7,8,9,"A","B","C","D","E","F","G","H","I","J","K","L","M","N","O","P","Q","R","S","T","U","V","W","X","Y","Z")
	m_intRandlen = 16 '定义随机码的长度
	for i = 1 to m_intRandlen
		m_strRandomize = m_strRandomize & m_strRandArray(Int((21*Rnd)))
	next
	GetRandomizeCode = m_strRandomize
End Function
Public Function FormatRound(ByVal m_Parameter)
	Dim m_strParameter,m_strlen
	m_Parameter = CStr(m_Parameter)
	m_strlen = len(m_Parameter)
	If InStr(m_Parameter,".") = 0 Then
		If m_strlen > 2 Then
			m_strParameter = m_Parameter
		ElseIf m_strlen = 2 Then
			m_strParameter = m_Parameter & ".0"
		Else
			m_strParameter = m_Parameter & ".00"
		End If
	Else
		If m_strlen > 3 Then
			m_strParameter = m_Parameter
		Else
			m_strParameter = m_Parameter & "0"
		End If
	End If
	FormatRound = m_strParameter
End Function
Public Sub GetUserTodayInfo()
	Dim Lastlogin,UserDayInfo
	Lastlogin = Request.Cookies("newasp_net")("LastTime")
	UserDayInfo = Request.Cookies("newasp_net")("UserToday")
	If Not IsDate(LastLogin) Then LastLogin = Now()
	On Error Resume Next
	If DateDiff("d",LastLogin,Now())<>0 Then
		Newasp.Execute("UPDATE [NC_User] SET UserToday='0,0,0,0,0,0',LastTime=" & NowString & " WHERE username='"& Newasp.membername &"' And userid=" & Newasp.memberid)
		UserDayInfo = "0,0,0,0,0,0"
		Response.Cookies("newasp_net")("UserToday") = UserDayInfo
		Response.Cookies("newasp_net")("LastTime") = Now()
	End If
	UserToday = Split(UserDayInfo, ",")
	If Ubound(UserToday) <> 5 Then
		Newasp.Execute("UPDATE [NC_User] SET UserToday='0,0,0,0,0,0',LastTime=" & NowString & " WHERE username='"& Newasp.membername &"' And userid=" & Newasp.memberid)
		UserDayInfo = "0,0,0,0,0,0"
		Response.Cookies("newasp_net")("UserToday") = UserDayInfo
		Response.Cookies("newasp_net")("LastTime") = Now()
		UserToday = Split(UserDayInfo, ",")
	End If
End Sub
Public Function UpdateUserToday(ByVal str)
	On Error Resume Next
	If Trim(str) <> "" Then
		Newasp.Execute("UPDATE [NC_User] SET UserToday='" & str & "' WHERE username='"& Newasp.membername &"' And userid=" & Newasp.memberid)
		Response.Cookies("newasp_net")("UserToday") = str
	End If
End Function
'================================================
'作  用：输出错误警告脚本
'参  数：str ----参数入口
'返回值：警告信息
'================================================
Sub OutAlertScript(str)
	Response.Write "<script language=javascript>" & vbcrlf
	Response.Write "alert('" & str & "');"
	Response.Write "history.back()" & vbcrlf
	Response.Write "</script>" & vbcrlf
	Response.End
End Sub
Sub OutHintScript(str)
	Response.Write "<script language=JavaScript>" & vbCrLf
	Response.Write "alert('" & str & "');"
	Response.Write "location.replace('" & Request.ServerVariables("HTTP_REFERER") & "')" & vbCrLf
	Response.Write "</script>" & vbCrLf
	Response.End
End Sub
Sub OutputScript(str,url)
	Response.Write "<script language=JavaScript>" & vbCrLf
	Response.Write "alert('" & str & "');"
	Response.Write "location.replace('" & url & "')" & vbCrLf
	Response.Write "</script>" & vbCrLf
	Response.End
End Sub