<%@language=vbscript codepage=936 %> <% Option Explicit Response.Buffer = True Server.ScriptTimeOut = 9999999 %> <% Dim Conn, ConnStr, db, PE_True, PE_False, PE_Now Dim SqlDatabaseName, SqlPassword, SqlUsername, SqlHostIP Dim SiteName, SiteTitle, SiteUrl, InstallDir, LogoUrl, WebmasterName, WebmasterEmail, SiteKey Dim AdminDir, ShowSiteChannel, objName_FSO, FileExt_SiteIndex, FileExt_SiteSpecial Dim PresentExpPerLogin Dim EnableUserReg, RegFields_MustFill, EnableCheckCodeOfLogin Dim RssCodeType Dim LockIP, LockIPType Dim UserTrueIP Dim AllModules, PointName, PointUnit Const CMS_Edition = 0 '0--普及版 1--标准版 2--专业版 3--企业版 Const eShop_Edition = -1 '0--普及版 1--标准版 2--专业版 3--企业版 Const CRM_Edition = 0 '0--普及版 1--标准版 2--专业版 3--企业版 Const SystemDatabaseType = "ACCESS" '系统数据库类型，"SQL"为MS SQL2000数据库，"ACCESS"为MS ACCESS 2000数据库，免费版只能使用ACCESS数据库 '如果是ACCESS数据库，请认真修改好下面的数据库的文件名 db = "\sjk\wsfsch109094006.asp" 'ACCESS数据库的文件名，请使用相对于网站根目录的的绝对路径 '如果是安装在网站根目录，直接修改文件名即可。如果是安装在网站某一目录下，则在前面加上此目录， '例如，系统安装在“http://www.powereasy.net/PE2006/”目录下（PE2006为安装目录），则这里应该修改为：db="\PE2006\database\PowerEasy2006.mdb" '如果是SQL数据库，请认真修改好以下数据库选项 SqlUsername = "PowerEasy" 'SQL数据库用户名 SqlPassword = "PowerEasy*9988" 'SQL数据库用户密码 SqlDatabaseName = "PowerEasy2006" 'SQL数据库名 SqlHostIP = "127.0.0.1" 'SQL主机IP地址（本地可用“127.0.0.1”或“(local)”，非本机请用真实IP） Call OpenConn Call GetSiteConfig Call IsIPlock Sub OpenConn() On Error Resume Next If SystemDatabaseType = "SQL" Then ConnStr = "Provider = Sqloledb; User ID = " & SqlUsername & "; Password = " & SqlPassword & "; Initial Catalog = " & SqlDatabaseName & "; Data Source = " & SqlHostIP & ";" Else ConnStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath(db) End If Set Conn = Server.CreateObject("ADODB.Connection") Conn.open ConnStr If Err Then Err.Clear Set Conn = Nothing Response.Write "数据库连接出错，请检查Conn.asp文件中的数据库参数设置。" Response.End End If If SystemDatabaseType = "SQL" Then PE_True = "1" PE_False = "0" PE_Now = "getdate()" Else PE_True = "True" PE_False = "False" PE_Now = "Now()" End If End Sub Sub CloseConn() On Error Resume Next If IsObject(Conn) Then Conn.Close Set Conn = Nothing End If End Sub Sub GetSiteConfig() Dim rsConfig Set rsConfig = Conn.Execute("select * from PE_Config") If rsConfig.BOF And rsConfig.EOF Then rsConfig.Close Set rsConfig = Nothing Response.Write "网站配置数据丢失！系统无法正常运行！" Response.End Else SiteName = rsConfig("SiteName") SiteTitle = rsConfig("SiteTitle") SiteUrl = rsConfig("SiteUrl") InstallDir = rsConfig("InstallDir") LogoUrl = rsConfig("LogoUrl") WebmasterName = rsConfig("WebmasterName") WebmasterEmail = rsConfig("WebmasterEmail") SiteKey = rsConfig("SiteKey") AdminDir = rsConfig("AdminDir") ShowSiteChannel = rsConfig("ShowSiteChannel") objName_FSO = rsConfig("objName_FSO") FileExt_SiteIndex = rsConfig("FileExt_SiteIndex") FileExt_SiteSpecial = rsConfig("FileExt_SiteSpecial") EnableUserReg = rsConfig("EnableUserReg") RegFields_MustFill = rsConfig("RegFields_MustFill") AllModules = rsConfig("Modules") PointName = rsConfig("PointName") PointUnit = rsConfig("PointUnit") RssCodeType = rsConfig("RssCodeType") LockIP = rsConfig("LockIP") LockIPType = rsConfig("LockIPType") EnableCheckCodeOfLogin = rsConfig("EnableCheckCodeOfLogin") PresentExpPerLogin = rsConfig("PresentExpPerLogin") End If rsConfig.Close Set rsConfig = Nothing Application("SiteKey") = SiteKey Application("objName_FSO") = objName_FSO End Sub Sub IsIPlock() UserTrueIP = Request.ServerVariables("HTTP_X_FORWARDED_FOR") If UserTrueIP = "" Then UserTrueIP = Request.ServerVariables("REMOTE_ADDR") If session("IPlock") = "" Then session("IPlock") = ChecKIPlock(LockIPType, LockIP, UserTrueIP) End If If session("IPlock") = True Then Response.Write "对不起！您的IP（" & UserTrueIP & "）被系统限定。您可以和站长联系。" Response.End End If End Sub Function EncodeIP(Sip) Dim strIP strIP = Split(Sip, ".") If UBound(strIP) < 3 Then EncodeIP = 0 Exit Function End If If IsNumeric(strIP(0)) = False Or IsNumeric(strIP(1)) = False Or IsNumeric(strIP(2)) = False Or IsNumeric(strIP(3)) = False Then Sip = 0 Else Sip = CSng(strIP(0)) * 256 * 256 * 256 + CLng(strIP(1)) * 256 * 256 + CLng(strIP(2)) * 256 + CLng(strIP(3)) - 1 End If EncodeIP = Sip End Function '白名单的端点可以访问和黑名单的端点将不允许访问。 Function ChecKIPlock(ByVal sLockType, ByVal sLockList, ByVal sUserIP) Dim IPlock, rsLockIP Dim arrLockIPW, arrLockIPB, arrLockIPWCut, arrLockIPBCut IPlock = False ChecKIPlock = IPlock Dim i, sKillIP If sLockType = "" Or IsNull(sLockType) Then Exit Function If sLockList = "" Or IsNull(sLockList) Then Exit Function If sUserIP = "" Or IsNull(sUserIP) Then Exit Function sUserIP = CDbl(EncodeIP(sUserIP)) rsLockIP = Split(sLockList, "|||") If sLockType = 4 Then arrLockIPB = Split(Trim(rsLockIP(1)), "$$$") For i = 0 To UBound(arrLockIPB) If arrLockIPB(i) <> "" Then arrLockIPBCut = Split(Trim(arrLockIPB(i)), "----") IPlock = True If CDbl(arrLockIPBCut(0)) > sUserIP Or sUserIP > CDbl(arrLockIPBCut(1)) Then IPlock = False If IPlock Then Exit For End If Next If IPlock = True Then arrLockIPW = Split(Trim(rsLockIP(0)), "$$$") For i = 0 To UBound(arrLockIPW) If arrLockIPW(i) <> "" Then arrLockIPWCut = Split(Trim(arrLockIPW(i)), "----") IPlock = True If CDbl(arrLockIPWCut(0)) <= sUserIP And sUserIP <= CDbl(arrLockIPWCut(1)) Then IPlock = False If IPlock Then Exit For End If Next End If Else If sLockType = 1 Or sLockType = 3 Then arrLockIPW = Split(Trim(rsLockIP(0)), "$$$") For i = 0 To UBound(arrLockIPW) If arrLockIPW(i) <> "" Then arrLockIPWCut = Split(Trim(arrLockIPW(i)), "----") IPlock = True If CDbl(arrLockIPWCut(0)) <= sUserIP And sUserIP <= CDbl(arrLockIPWCut(1)) Then IPlock = False If IPlock Then Exit For End If Next End If If IPlock = False And (sLockType = 2 Or sLockType = 3) Then arrLockIPB = Split(Trim(rsLockIP(1)), "$$$") For i = 0 To UBound(arrLockIPB) If arrLockIPB(i) <> "" Then arrLockIPBCut = Split(Trim(arrLockIPB(i)), "----") IPlock = True If CDbl(arrLockIPBCut(0)) > sUserIP Or sUserIP > CDbl(arrLockIPBCut(1)) Then IPlock = False If IPlock Then Exit For End If Next End If End If ChecKIPlock = IPlock End Function %> <% Sub PE_Execute(strDllName, strClassName) On Error Resume Next If strDllName = "" Or IsNull(strDllName) Then Response.Write "请指定动易组件名！" Exit Sub End If If strClassName = "" Or IsNull(strClassName) Then Response.Write "请指定动易组件提供的类名！" Exit Sub End If Dim PE_User, objName objName = strDllName & "." & strClassName Set PE_User = Server.CreateObject(objName) If Err Then Err.Clear Response.Write "对不起，你的服务器没有安装动易组件（" & strDllName & ".dll），所以不能使用动易系统。请和你的空间商联系以安装动易组件。" Exit Sub End If PE_User.iConnStr = ConnStr PE_User.iSystemDatabaseType = SystemDatabaseType If strClassName = "User_Enrol" Then PE_User.iStartDay = "2006-1-1" End If Call PE_User.Execute Set PE_User = Nothing If Err Then Response.Write "错 误 号：" & Err.Number & "
" Response.Write "错误描述：" & Err.Description & "
" Response.Write "错误来源：" & Err.Source & "
" Err.Clear End If End Sub %> <% Dim Action, FoundErr, ErrMsg, ComeUrl Dim strInstallDir Dim Site_Sn '定义系统识别码 '定义用户相关的变量 Dim UserLogined, GroupID, GroupName, GroupType, Discount_Member, IsOffer, LoginTimes, RegTime, JoinTime, LastLoginTime, LastLoginIP Dim UserID, ClientID, CompanyID, ContacterID, UserType, UserName, email, Balance, UserPoint, UserExp, ValidNum, ValidDays, SpecialPermission, UserSetting, ChargeType Dim UnsignedItems, UnreadMsg, arrClass_Input, arrClass_View Dim DefaultTemplateProjectName If Request("ComeUrl") = "" Then ComeUrl = Trim(Request.ServerVariables("HTTP_REFERER")) Else ComeUrl = Trim(Request("ComeUrl")) End If Action = Trim(Request("Action")) FoundErr = False ErrMsg = "" If Right(InstallDir, 1) <> "/" Then strInstallDir = InstallDir & "/" Else strInstallDir = InstallDir End If Site_Sn = Replace(Replace(LCase(Request.ServerVariables("SERVER_NAME") & InstallDir), "/", ""), ".", "") '************************************************** '函数名：gotTopic '作 用：截字符串，汉字一个算两个字符，英文算一个字符 '参 数：str ----原字符串 ' strlen ----截取长度 '返回值：截取后的字符串 '************************************************** Function gotTopic(ByVal str, ByVal strlen) If str = "" Then gotTopic = "" Exit Function End If Dim l, t, c, i, strTemp str = Replace(Replace(Replace(Replace(str, " ", " "), """, Chr(34)), ">", ">"), "<", "<") l = Len(str) t = 0 strTemp = str strlen = CLng(strlen) For i = 1 To l c = Abs(Asc(Mid(str, i, 1))) If c > 255 Then t = t + 2 Else t = t + 1 End If If t >= strlen Then strTemp = Left(str, i) Exit For End If Next If strTemp <> str Then strTemp = strTemp & "…" End If gotTopic = Replace(Replace(Replace(Replace(strTemp, " ", " "), Chr(34), """), ">", ">"), "<", "<") End Function '************************************************** '函数名：JoinChar '作 用：向地址中加入 ? 或 & '参 数：strUrl ----网址 '返回值：加了 ? 或 & 的网址 '************************************************** Function JoinChar(ByVal strUrl) If strUrl = "" Then JoinChar = "" Exit Function End If If InStr(strUrl, "?") < Len(strUrl) Then If InStr(strUrl, "?") > 1 Then If InStr(strUrl, "&") < Len(strUrl) Then JoinChar = strUrl & "&" Else JoinChar = strUrl End If Else JoinChar = strUrl & "?" End If Else JoinChar = strUrl End If End Function '************************************************** '函数名：ShowPage '作 用：显示“上一页 下一页”等信息 '参 数：sFileName ----链接地址 ' TotalNumber ----总数量 ' MaxPerPage ----每页数量 ' CurrentPage ----当前页 ' ShowTotal ----是否显示总数量 ' ShowAllPages ---是否用下拉列表显示所有页面以供跳转。 ' strUnit ----计数单位 ' ShowMaxPerPage ----是否显示每页信息量选项框 '返回值：“上一页 下一页”等信息的HTML代码 '************************************************** Function ShowPage(sfilename, totalnumber, MaxPerPage, CurrentPage, ShowTotal, ShowAllPages, strUnit, ShowMaxPerPage) Dim TotalPage, strTemp, strUrl, i If totalnumber = 0 Or MaxPerPage = 0 Or IsNull(MaxPerPage) Then ShowPage = "" Exit Function End If If totalnumber Mod MaxPerPage = 0 Then TotalPage = totalnumber \ MaxPerPage Else TotalPage = totalnumber \ MaxPerPage + 1 End If If CurrentPage > TotalPage Then CurrentPage = TotalPage strTemp = "
" If ShowTotal = True Then strTemp = strTemp & "共 " & totalnumber & " " & strUnit & "  " End If If ShowMaxPerPage = True Then strUrl = JoinChar(sfilename) & "MaxPerPage=" & MaxPerPage & "&" Else strUrl = JoinChar(sfilename) End If If CurrentPage = 1 Then strTemp = strTemp & "首页 上一页 " Else strTemp = strTemp & "首页 " strTemp = strTemp & "上一页 " End If If CurrentPage >= TotalPage Then strTemp = strTemp & "下一页 尾页" Else strTemp = strTemp & "下一页 " strTemp = strTemp & "尾页" End If strTemp = strTemp & " 页次：" & CurrentPage & "/" & TotalPage & "页 " If ShowMaxPerPage = True Then strTemp = strTemp & " " & strUnit & "/页" Else strTemp = strTemp & " " & MaxPerPage & "" & strUnit & "/页" End If If ShowAllPages = True Then If TotalPage > 20 Then strTemp = strTemp & "  转到第页" Else strTemp = strTemp & " 转到：" End If End If strTemp = strTemp & "
" ShowPage = strTemp End Function '************************************************** '函数名：IsObjInstalled '作 用：检查组件是否已经安装 '参 数：strClassString ----组件名 '返回值：True ----已经安装 ' False ----没有安装 '************************************************** Function IsObjInstalled(strClassString) On Error Resume Next IsObjInstalled = False Err = 0 Dim xTestObj Set xTestObj = Server.CreateObject(strClassString) If 0 = Err Then IsObjInstalled = True Set xTestObj = Nothing Err = 0 End Function '************************************************** '函数名：strLength '作 用：求字符串长度。汉字算两个字符，英文算一个字符。 '参 数：str ----要求长度的字符串 '返回值：字符串长度 '************************************************** Function strLength(str) On Error Resume Next Dim WINNT_CHINESE WINNT_CHINESE = (Len("中国") = 2) If WINNT_CHINESE Then Dim l, t, c Dim i l = Len(str) t = l For i = 1 To l c = Asc(Mid(str, i, 1)) If c < 0 Then c = c + 65536 If c > 255 Then t = t + 1 End If Next strLength = t Else strLength = Len(str) End If If Err.Number <> 0 Then Err.Clear End Function '************************************************** '函数：FoundInArr '作 用：检查一个数组中所有元素是否包含指定字符串 '参 数：strArr ----存储数据数据的字串 ' strToFind ----要查找的字符串 ' strSplit ----数组的分隔符 '返回值：True,False '************************************************** Function FoundInArr(strArr, strToFind, strSplit) Dim arrTemp, i FoundInArr = False If InStr(strArr, strSplit) > 0 Then arrTemp = Split(strArr, strSplit) For i = 0 To UBound(arrTemp) If LCase(Trim(arrTemp(i))) = LCase(Trim(strToFind)) Then FoundInArr = True Exit For End If Next Else If LCase(Trim(strArr)) = LCase(Trim(strToFind)) Then FoundInArr = True End If End If End Function '************************************************** '过程名：WriteErrMsg '作 用：显示错误提示信息 '参 数：无 '************************************************** Sub WriteErrMsg(sErrMsg, sComeUrl) Dim strErr strErr = strErr & "错误信息" & vbCrLf strErr = strErr & "

" & vbCrLf strErr = strErr & "" & vbCrLf strErr = strErr & " " & vbCrLf strErr = strErr & " " & vbCrLf strErr = strErr & " " & vbCrLf strErr = strErr & "
错误信息
产生错误的可能原因：" & sErrMsg & "
" If sComeUrl <> "" Then strErr = strErr & "<< 返回上一页" Else strErr = strErr & "【关闭】" End If strErr = strErr & "
" & vbCrLf strErr = strErr & "" & vbCrLf Response.Write strErr End Sub '************************************************** '过程名：WriteSuccessMsg '作 用：显示成功提示信息 '参 数：无 '************************************************** Sub WriteSuccessMsg(sSuccessMsg, sComeUrl) Dim strSuccess strSuccess = strSuccess & "成功信息" & vbCrLf strSuccess = strSuccess & "

" & vbCrLf strSuccess = strSuccess & "" & vbCrLf strSuccess = strSuccess & " " & vbCrLf strSuccess = strSuccess & " " & vbCrLf strSuccess = strSuccess & " " & vbCrLf strSuccess = strSuccess & "
恭喜你！

" & sSuccessMsg & "
" If sComeUrl <> "" Then strSuccess = strSuccess & "<< 返回上一页" Else strSuccess = strSuccess & "【关闭】" End If strSuccess = strSuccess & "
" & vbCrLf strSuccess = strSuccess & "" & vbCrLf Response.Write strSuccess End Sub '************************************************** '函数名：ReplaceBadChar '作 用：过滤非法的SQL字符 '参 数：strChar-----要过滤的字符 '返回值：过滤后的字符 '************************************************** Function ReplaceBadChar(strChar) If strChar = "" Or IsNull(strChar) Then ReplaceBadChar = "" Exit Function End If Dim strBadChar, arrBadChar, tempChar, i strBadChar = "+,',%,^,&,?,(,),<,>,[,],{,},/,\,;,:," & Chr(34) & "," & Chr(0) & ",--" arrBadChar = Split(strBadChar, ",") tempChar = strChar For i = 0 To UBound(arrBadChar) tempChar = Replace(tempChar, arrBadChar(i), "") Next tempChar = Replace(tempChar, "@@", "@") ReplaceBadChar = tempChar End Function Function PE_CLng(ByVal str1) If IsNumeric(str1) Then PE_CLng = Fix(CDbl(str1)) Else PE_CLng = 0 End If End Function Function PE_CDbl(ByVal str1) If IsNumeric(str1) Then PE_CDbl = CDbl(str1) Else PE_CDbl = 0 End If End Function Function PE_CDate(ByVal str1) If IsDate(str1) Then PE_CDate = CDate(str1) Else PE_CDate = Date End If End Function '************************************************** '函数名：IsValidEmail '作 用：检查Email地址合法性 '参 数：email ----要检查的Email地址 '返回值：True ----Email地址合法 ' False ----Email地址不合法 '************************************************** Function IsValidEmail(email) Dim names, name, i, c IsValidEmail = True names = Split(email, "@") If UBound(names) <> 1 Then IsValidEmail = False Exit Function End If For Each name In names If Len(name) <= 0 Then IsValidEmail = False Exit Function End If For i = 1 To Len(name) c = LCase(Mid(name, i, 1)) If InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 And Not IsNumeric(c) Then IsValidEmail = False Exit Function End If Next If Left(name, 1) = "." Or Right(name, 1) = "." Then IsValidEmail = False Exit Function End If Next If InStr(names(1), ".") <= 0 Then IsValidEmail = False Exit Function End If i = Len(names(1)) - InStrRev(names(1), ".") If i <> 2 And i <> 3 And i <> 4 Then IsValidEmail = False Exit Function End If If InStr(email, "..") > 0 Then IsValidEmail = False End If End Function '得到数组中某个元素的值 Public Function GetArrItem(ByVal arrTemp, ByVal ItemIndex) If Not IsArray(arrTemp) Then GetArrItem = "" Exit Function End If ItemIndex = PE_CLng(ItemIndex) If ItemIndex < 0 Or ItemIndex > UBound(arrTemp) Then GetArrItem = "" Exit Function End If Dim strTemp strTemp = arrTemp(ItemIndex) If InStr(strTemp, "|") > 0 Then GetArrItem = Left(strTemp, InStr(strTemp, "|") - 1) Else GetArrItem = strTemp End If End Function '把数组变成下拉列表项目 Public Function Array2Option(ByVal arrTemp, ByVal ID) Dim strOption, i, arrValue strOption = "" ID = PE_CLng(ID) For i = 0 To UBound(arrTemp) arrValue = Split(arrTemp(i), "|") If CLng(arrValue(1)) = 1 Then If ID > -1 Then If i = ID Then strOption = strOption & "" Else strOption = strOption & "" End If Else If CLng(arrValue(2)) = 1 Then strOption = strOption & "" Else strOption = strOption & "" End If End If End If Next Array2Option = strOption End Function Function GetRndPassword(PasswordLen) Dim Ran, i, strPassword strPassword = "" For i = 1 To PasswordLen Randomize Ran = CInt(Rnd * 2) Randomize If Ran = 0 Then Ran = CInt(Rnd * 25) + 97 strPassword = strPassword & UCase(Chr(Ran)) ElseIf Ran = 1 Then Ran = CInt(Rnd * 9) strPassword = strPassword & Ran ElseIf Ran = 2 Then Ran = CInt(Rnd * 25) + 97 strPassword = strPassword & Chr(Ran) End If Next GetRndPassword = strPassword End Function Function GetScriptPath(ByVal ScriptName, ParentLevel) Dim i GetScriptPath = "/" If ScriptName = "" Or IsNull(ScriptName) Then Exit Function If ParentLevel > 1 Then ParentLevel = 1 If ParentLevel = 0 Then GetScriptPath = Left(ScriptName, InStrRev(ScriptName, "/")) ElseIf ParentLevel = 1 Then i = InStrRev(ScriptName, "/") - 1 If i < 1 Then i = 1 GetScriptPath = Left(ScriptName, InStrRev(ScriptName, "/", i)) End If If Right(GetScriptPath, 1) <> "/" Then GetScriptPath = GetScriptPath & "/" End Function '判断当前访问者是否已经登录，若已登录，则读取数据并做必要赋值 Function CheckUserLogined() Dim UserPassword, LastPassword Dim rsUser, sqlUser Dim rsConfig UserName = ReplaceBadChar(Trim(Request.Cookies(Site_Sn)("UserName"))) UserPassword = ReplaceBadChar(Trim(Request.Cookies(Site_Sn)("UserPassword"))) LastPassword = ReplaceBadChar(Trim(Request.Cookies(Site_Sn)("LastPassword"))) UserID = 0 ClientID = 0 CompanyID = 0 ContacterID = 0 UserType = 0 GroupID = 0 GroupType = 0 GroupName = "游客" Discount_Member = 100 Balance = 0 UserPoint = 0 UserExp = 0 IsOffer = "否" If (UserName = "" Or UserPassword = "" Or LastPassword = "") Then CheckUserLogined = False Exit Function End If sqlUser = "SELECT U.*,G.GroupName,G.GroupType,G.GroupSetting,G.arrClass_Input as G_arrClass_Input,G.arrClass_View as G_arrClass_View FROM PE_User U inner join PE_UserGroup G on U.GroupID=G.GroupID WHERE" sqlUser = sqlUser & " U.UserName='" & UserName & "' AND U.UserPassword='" & UserPassword & "' AND U.LastPassword='" & LastPassword & "' and IsLocked=" & PE_False & "" Set rsUser = Conn.Execute(sqlUser) If rsUser.EOF And rsUser.BOF Then CheckUserLogined = False Else CheckUserLogined = True UserID = rsUser("UserID") ClientID = rsUser("ClientID") CompanyID = rsUser("CompanyID") ContacterID = rsUser("ContacterID") UserType = rsUser("UserType") UserName = rsUser("UserName") UserPassword = rsUser("UserPassword") LastPassword = rsUser("LastPassword") email = rsUser("Email") Balance = PE_CDbl(rsUser("Balance")) UserPoint = PE_CLng(rsUser("UserPoint")) UserExp = PE_CLng(rsUser("UserExp")) ValidNum = rsUser("ValidNum") LoginTimes = rsUser("LoginTimes") ValidDays = ChkValidDays(rsUser("ValidNum"), rsUser("ValidUnit"), rsUser("BeginTime")) GroupID = rsUser("GroupID") GroupName = rsUser("GroupName") GroupType = rsUser("GroupType") SpecialPermission = rsUser("SpecialPermission") If SpecialPermission = True Then UserSetting = Split(rsUser("UserSetting") & ",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0", ",") arrClass_Input = rsUser("arrClass_Input") arrClass_View = rsUser("arrClass_View") Else UserSetting = Split(rsUser("GroupSetting") & ",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0", ",") arrClass_Input = rsUser("G_arrClass_Input") arrClass_View = rsUser("G_arrClass_View") End If Discount_Member = PE_CDbl(UserSetting(11)) If PE_CLng(UserSetting(12)) = 1 Then IsOffer = "是" Else IsOffer = "否" End If ChargeType = PE_CLng(UserSetting(14)) UnsignedItems = rsUser("UnsignedItems") UnreadMsg = PE_CLng(rsUser("UnreadMsg")) RegTime = rsUser("RegTime") JoinTime = rsUser("JoinTime") LoginTimes = rsUser("LoginTimes") LastLoginTime = rsUser("LastLoginTime") LastLoginIP = rsUser("LastLoginIP") If PresentExpPerLogin > 0 Then If DateDiff("D", rsUser("LastPresentTime"), Now()) > 0 Or IsNull(rsUser("LastPresentTime")) Then Conn.Execute ("update PE_User set UserExp=UserExp+" & PresentExpPerLogin & ",LastPresentTime=" & PE_Now & " where UserID=" & UserID & "") End If End If If PE_CLng(Session("UserID")) = 0 Then UserTrueIP = ReplaceBadChar(UserTrueIP) Conn.Execute ("update PE_User set LastLoginIP='" & UserTrueIP & "',LastLoginTime=" & PE_Now & ",LoginTimes=LoginTimes+1 where UserID=" & UserID & "") Session("UserID") = UserID End If End If Set rsUser = Nothing DefaultTemplateProjectName = GetDefaultTemplateProjectName() End Function Function GetDefaultTemplateProjectName() Dim rsProject, strProjectName Set rsProject = Conn.Execute("select TemplateProjectName from PE_TemplateProject where IsDefault=" & PE_True) If Not rsProject.EOF Then strProjectName = rsProject("TemplateProjectName") Else strProjectName = "动易2006海蓝方案" End If Set rsProject = Nothing GetDefaultTemplateProjectName = strProjectName End Function Function GetClientName(ClientID) If ClientID <= 0 Then GetClientName = "" Exit Function End If Dim rsClient Set rsClient = Conn.Execute("select ClientName from PE_Client where ClientID=" & ClientID & "") If rsClient.BOF And rsClient.EOF Then GetClientName = "" Else GetClientName = rsClient(0) End If rsClient.Close Set rsClient = Nothing End Function Function GetGroupName(iGroupID) Dim rsGroup Set rsGroup = Conn.Execute("select GroupName from PE_UserGroup where GroupID=" & iGroupID & "") If rsGroup.BOF And rsGroup.EOF Then GetGroupName = "未知" Else GetGroupName = rsGroup(0) End If Set rsGroup = Nothing End Function Function CheckBadChar(strChar) Dim strBadChar, arrBadChar, i strBadChar = "@@,+,',--,%,^,&,?,(,),<,>,[,],{,},/,\,;,:," & Chr(34) & "" arrBadChar = Split(strBadChar, ",") If strChar = "" Then CheckBadChar = False Else For i = 0 To UBound(arrBadChar) If InStr(strChar, arrBadChar(i)) > 0 Then CheckBadChar = False Exit Function End If Next End If CheckBadChar = True End Function Function ReplaceUrlBadChar(strChar) If strChar = "" Or IsNull(strChar) Then ReplaceUrlBadChar = "" Exit Function End If Dim strBadChar, arrBadChar, tempChar, i strBadChar = "+,',--,(,),<,>,[,],{,},\,;," & Chr(34) & "," & Chr(0) & "" arrBadChar = Split(strBadChar, ",") tempChar = strChar For i = 0 To UBound(arrBadChar) tempChar = Replace(tempChar, arrBadChar(i), "") Next tempChar = Replace(tempChar, "@@", "@") ReplaceUrlBadChar = tempChar End Function Function GetNewID(SheetName, FieldName) Dim mrs Set mrs = Conn.Execute("select max(" & FieldName & ") from " & SheetName & "") If IsNull(mrs(0)) Then GetNewID = 1 Else GetNewID = mrs(0) + 1 End If Set mrs = Nothing End Function Function GetArrFromDictionary(strTableName, strFieldName) Dim rsDictionary Set rsDictionary = Conn.Execute("select FieldValue from PE_Dictionary where TableName='" & strTableName & "' and FieldName='" & strFieldName & "'") If rsDictionary.BOF And rsDictionary.EOF Then GetArrFromDictionary = "" Else GetArrFromDictionary = rsDictionary(0) End If Set rsDictionary = Nothing End Function Function ChkValidDays(iValidNum, iValidUnit, iBeginTime) If (iValidNum = "" Or IsNumeric(iValidNum) = False Or iValidUnit = "" Or IsNumeric(iValidUnit) = False Or iBeginTime = "" Or IsDate(iBeginTime) = False) Then ChkValidDays = 0 Exit Function End If Dim tmpDate, arrInterval arrInterval = Array("h", "D", "m", "yyyy") If iValidNum = -1 Then ChkValidDays = 99999 Else tmpDate = DateAdd(arrInterval(iValidUnit), iValidNum, iBeginTime) ChkValidDays = DateDiff("D", Date, tmpDate) End If End Function '************************************************** '函数名：PE_ServerHTMLEncode '作 用：显示HTML代码 '参 数：Content ---- 要输出HTML的字符串 '返回值：处理后的字符串 '************************************************** Function PE_ServerHTMLEncode(ByVal Content) If IsNull(Content) Then PE_ServerHTMLEncode = "" Else PE_ServerHTMLEncode = Server.HTMLEncode(Content) End If End Function '************************************************** '函数名：nohtml '作 用：过滤html 元素 '参 数：str ---- 要过滤字符 '返回值：没有html 的字符 '************************************************** Public Function nohtml(ByVal str) If IsNull(str) Or Trim(str) = "" Then nohtml = "" Exit Function End If Dim re Set re = New RegExp re.IgnoreCase = True re.Global = True re.Pattern = "(\<.[^\<]*\>)" str = re.Replace(str, " ") re.Pattern = "(\<\/[^\<]*\>)" str = re.Replace(str, " ") Set re = Nothing str = Replace(str, "'", "") str = Replace(str, Chr(34), "") nohtml = str End Function '================================================= '函数名：ReplaceBadUrl '作 用：过滤非法Url地址函数 '================================================= Public Function ReplaceBadUrl(ByVal strContent) Dim regEx, Matches, Match Set regEx = New RegExp regEx.IgnoreCase = True regEx.Global = True regEx.Pattern = "(a|%61|%41)(d|%64|%44)(m|%6D|4D)(i|%69|%49)(n|%6E|%4E)(\_|%5F)(.*?)(.|%2E)(a|%61|%41)(s|%73|%53)(p|%70|%50)" Set Matches = regEx.Execute(strContent) For Each Match In Matches strContent = Replace(strContent, Match.Value, "") Next regEx.Pattern = "(u|%75|%55)(s|%73|%53)(e|%65|%45)(r|%72|%52)(\_|%5F)(.*?)(.|%2E)(a|%61|%41)(s|%73|%53)(p|%70|%50)" Set Matches = regEx.Execute(strContent) For Each Match In Matches strContent = Replace(strContent, Match.Value, "") Next Set regEx = Nothing ReplaceBadUrl = strContent End Function '================================================= '函数名：FilterJS() '作 用：过滤非法JS字符 '参 数：strInput 需要过滤的内容 '================================================= Public Function FilterJS(ByVal strInput) If IsNull(strInput) Or Trim(strInput) = "" Then FilterJS = "" Exit Function End If Dim RegEx Dim reContent Set RegEx = New RegExp RegEx.IgnoreCase = True RegEx.Global = True RegEx.MultiLine = True ' 替换掉HTML字符实体(Character Entities)名字和分号之间的空白字符，比如：ä ;替换成ä RegEx.Pattern = "(&#*\w+)[\x00-\x20]+;" strInput = RegEx.Replace(strInput, "$1;") ' 将无分号结束符的数字编码实体规范成带分号的标准形式 RegEx.Pattern = "(&#x*[0-9A-F]+);*" strInput = RegEx.Replace(strInput, "$1;") ' 将  < > & "字符实体中的 & 替换成 & 以便在进行HtmlDecode时保留这些字符实体 'RegEx.Pattern = "&(amp|lt|gt|nbsp|quot);" 'strInput = RegEx.Replace(strInput, "&$1;") ' 将HTML字符实体进行解码，以消除编码字符对后续过滤的影响 'strInput = HtmlDecode(strInput); ' 将ASCII码表中前32个字符中的非打印字符替换成空字符串，保留 9、10、13、32，它们分别代表 制表符、换行符、回车符和空格。 RegEx.Pattern = "[\x00-\x08\x0b-\x0c\x0e-\x19]" strInput = RegEx.Replace(strInput, "") ' 替换以on和xmlns开头的属性，动易系统的几个JS需要保留 RegEx.Pattern = "on(load\s*=\s*""*'*resizepic\(this\)'*""*)" strInput = RegEx.Replace(strInput, "off$1") RegEx.Pattern = "on(mousewheel\s*=\s*""*'*return\s*bbimg\(this\)'*""*)" strInput = RegEx.Replace(strInput, "off$1") RegEx.Pattern = "(<[^>]+[\x00-\x20""'/])(on|xmlns)([^>]*)>" strInput = RegEx.Replace(strInput, "$1pe$3>") RegEx.Pattern = "off(load\s*=\s*""*'*resizepic\(this\)'*""*)" strInput = RegEx.Replace(strInput, "on$1") RegEx.Pattern = "off(mousewheel\s*=\s*""*'*return\s*bbimg\(this\)'*""*)" strInput = RegEx.Replace(strInput, "on$1") ' 替换javascript RegEx.Pattern = "([a-z]*)[\x00-\x20]*=[\x00-\x20]*([`'""]*)[\x00-\x20]*j[\x00-\x20]*a[\x00-\x20]*v[\x00-\x20]*a[\x00-\x20]*s[\x00-\x20]*c[\x00-\x20]*r[\x00-\x20]*i[\x00-\x20]*p[\x00-\x20]*t[\x00-\x20]*:" strInput = RegEx.Replace(strInput, "$1=$2nojavascript...") ' 替换vbscript RegEx.Pattern = "([a-z]*)[\x00-\x20]*=[\x00-\x20]*([`'""]*)[\x00-\x20]*v[\x00-\x20]*b[\x00-\x20]*s[\x00-\x20]*c[\x00-\x20]*r[\x00-\x20]*i[\x00-\x20]*p[\x00-\x20]*t[\x00-\x20]*:" strInput = RegEx.Replace(strInput, "$1=$2novbscript...") ' 替换expression RegEx.Pattern = "(<[^>]+)style[\x00-\x20]*=[\x00-\x20]*([`'""]*).*expression[\x00-\x20]*\([^>]*>" strInput = RegEx.Replace(strInput, "$1>") ' 替换behaviour RegEx.Pattern = "(<[^>]+)style[\x00-\x20]*=[\x00-\x20]*([`'""]*).*behaviour[\x00-\x20]*\([^>]*>" strInput = RegEx.Replace(strInput, "$1>") ' 替换script RegEx.Pattern = "(<[^>]+)style[\x00-\x20]*=[\x00-\x20]*([`'""]*).*s[\x00-\x20]*c[\x00-\x20]*r[\x00-\x20]*i[\x00-\x20]*p[\x00-\x20]*t[\x00-\x20]*:*[^>]*>" strInput = RegEx.Replace(strInput, "$1>") ' 替换namespaced elements 不需要 RegEx.Pattern = "]*>" strInput = RegEx.Replace(strInput, "") Dim oldhtmlString oldhtmlString = "" Do while oldhtmlString <> strInput oldhtmlString = strInput '实行严格过滤 RegEx.Pattern = "]*>" strInput = RegEx.Replace(strInput, "") '过滤掉SHTML的Include包含文件漏洞 RegEx.Pattern = " <% If CheckUserLogined() = False Then Call CloseConn Response.Redirect "User_Login.asp" End If %> 清河在线-页面建设中！！！！！
　
<%="您现在的位置：" & SiteName & " >> 会员中心 >> 信息管理"%>
　 　
　

添加信息
所有信息

草 稿
待审核的信息

已审核的信息
未被采用的信息
　

抱歉~页面建设中……
　

<% Call PE_Execute("PE_Article6", "User_Article") %>
　
　 　 　
设为首页 | 加入收藏 | 联系站长 | 友情链接 | 版权申明 | 管理登录 |   
管理员:王嵩峰 | 感谢邢台创通公司 提供空间 | 冀ICP备05018085号
清河在线 All Rights Reserved (C) Copyright 2006 TEL:0319-7502356  QQ:109094006 |     清河在线 *卡通版*
<% Call CloseConn %>