<% @LANGUAGE = "VBScript" %>
<%
Option Explicit
Response.Buffer = True
Server.ScriptTimeOut = 9999999
%>
<%
Call ChkLogin
If FoundErr = True Then
WriteMsg(ErrMsg)
End If
Action = Trim(Request("Action"))
if Action="SaveAdd" then
Call PE_Execute("PE_Article6", "Admin_Article", "CMS")
if Trim(Request("CreateImmediate"))="Yes" then
dim ArticleID,ChannelID,ClassID,rs,sql
Call OpenConn
Set rs = Server.CreateObject("adodb.recordset")
sql = "select top 1 ArticleID,ChannelID,ClassID from PE_Article order by ArticleID desc"
rs.Open sql, Conn, 1, 3
If not rs.EOF Then
ArticleID=rs("ArticleID")
ChannelID=rs("ChannelID")
ClassID=rs("ClassID")
End If
rs.close
set rs=nothing
Call CloseConn
dim posturl
posturl="http://"&Trim(Request.ServerVariables("HTTP_HOST"))&"/etpost.asp?ChannelID="&ChannelID&"&Action=CreateArticle2&ClassID="&ClassID&"&SpecialID="&Trim(Request("SpecialID"))&"&ArticleID="&ArticleID&"&ShowBack=No&UserName="&Trim(Request("UserName"))&"&Password="&Trim(Request("Password"))
response.Write(getText(POSTURL))
end if
elseif Action="CreateArticle2" then
Call PE_CreateHTML("PE_Article6", "Article", "CMS")
end if
function getText(url)
dim oReq
on error resume next
'//创建XMLHTTP对象
'set oReq= CreateObject("Msxml2.ServerXMLHTTP")
set oReq= CreateObject("MSXML2.XMLHTTP")
oReq.open "get",url,false
oReq.send
if oReq.status = 200 then
getText = bytes2BSTR(oReq.responseBody)
else
getText = "0"
end if
set oReq=nothing
end function
Function Bytes2bStr(vin)
Const adTypeBinary = 1
Const adTypeText = 2
Dim BytesStream,StringReturn
Set BytesStream = Server.CreateObject("ADODB.Stream") '建立一个流对象
With BytesStream
.Type = adTypeText
.Open
.WriteText vin
.Position = 0
.Charset = "GB2312"
.Position = 2
StringReturn = .ReadText
.close
End With
Set BytesStream = Nothing
Bytes2bStr = StringReturn
End Function
Sub ChkLogin()
Dim sql, rs
Dim UserName, Password, CheckCode, RndPassword, AdminLoginCode
UserName = ReplaceBadChar(Trim(Request("UserName")))
Password = ReplaceBadChar(Trim(Request("Password")))
' CheckCode = LCase(ReplaceBadChar(Trim(Request("CheckCode"))))
' AdminLoginCode = Trim(Request("AdminLoginCode"))
' If CSng(ScriptEngineMajorVersion & "." & ScriptEngineMinorVersion) < 5.6 Then
' FoundErr = True
' ErrMsg = ErrMsg & "服务器脚本解释引擎（VBScript）版本过低，请联系您的空间商或服务器管理员更新。"
' ErrMsg = ErrMsg & "脚本解释引擎下载地址"
' End If
If UserName = "" Then
FoundErr = True
ErrMsg = ErrMsg & "
用户名不能为空！"
End If
If Password = "" Then
FoundErr = True
ErrMsg = ErrMsg & "
密码不能为空！"
End If
' If CheckCode = "" Then
' FoundErr = True
' ErrMsg = ErrMsg & "
验证码不能为空！"
' End If
' If Trim(Session("CheckCode")) = "" Then
' FoundErr = True
' ErrMsg = ErrMsg & "
你在管理登录停留的时间过长，导致验证码失效。请重新返回登录页面进行登录。"
' End If
' If CheckCode <> Session("CheckCode") Then
' FoundErr = True
' ErrMsg = ErrMsg & "
您输入的验证码和系统产生的不一致，请重新输入。"
' End If
' If EnableSiteManageCode = True And AdminLoginCode <> SiteManageCode Then
' FoundErr = True
' ErrMsg = ErrMsg & "
您输入的后台管理认证码不对，请重新输入。"
' End If
If FoundErr = True Then
Exit Sub
End If
ComeUrl = Trim(Request.ServerVariables("HTTP_REFERER"))
Password = MD5(Password, 16)
Set rs = Server.CreateObject("adodb.recordset")
sql = "select * from PE_Admin where Password='" & Password & "' and AdminName='" & UserName & "'"
rs.Open sql, Conn, 1, 3
If rs.bof And rs.EOF Then
FoundErr = True
ErrMsg = ErrMsg & "
用户名或密码错误！！！"
Else
If Password <> rs("Password") Then
FoundErr = True
ErrMsg = ErrMsg & "
用户名或密码错误！！！"
End If
End If
If FoundErr = True Then
Call InsertLog(1, -1, UserName, UserTrueIP, "登录失败", ComeUrl, "")
Session("AdminName") = ""
Session("AdminPassword") = ""
Session("RndPassword") = ""
rs.Close
Set rs = Nothing
Exit Sub
End If
UserName = rs("UserName")
RndPassword = GetRndPassword(16)
rs("LastLoginIP") = UserTrueIP
rs("LastLoginTime") = Now()
rs("LoginTimes") = rs("LoginTimes") + 1
rs("RndPassword") = RndPassword
rs.Update
' Call InsertLog(1, 0, UserName, UserTrueIP, "登录成功", ComeUrl, "")
strInstallDir = GetScriptPath(Trim(Request.ServerVariables("SCRIPT_NAME")), 1)
Site_Sn = Replace(Replace(LCase(Request.ServerVariables("SERVER_NAME") & strInstallDir), "/", ""), ".", "")
Response.Cookies(Site_Sn)("AdminName") = rs("AdminName")
Response.Cookies(Site_Sn)("AdminPassword") = rs("Password")
Response.Cookies(Site_Sn)("RndPassword") = RndPassword
Response.Cookies(Site_Sn)("AdminLoginCode") = AdminLoginCode
rs.Close
sql = "select UserPassword,LastPassword,LastLoginIP,LastLoginTime,LoginTimes from PE_User where UserName='" & UserName & "'"
rs.Open sql, Conn, 1, 3
If Not (rs.bof And rs.EOF) Then
rs("LastPassword") = RndPassword
rs("LastLoginIP") = UserTrueIP
rs("LastLoginTime") = Now()
rs("LoginTimes") = rs("LoginTimes") + 1
rs.Update
Response.Cookies(Site_Sn)("UserName") = UserName
Response.Cookies(Site_Sn)("UserPassword") = rs("UserPassword")
Response.Cookies(Site_Sn)("LastPassword") = RndPassword
End If
rs.Close
Set rs = Nothing
' Call CloseConn
' Response.Redirect "Admin_Index.asp"
End Sub
'****************************************************
'过程名：WriteMsg
'作 用：显示提示信息
'参 数：无
'****************************************************
function WriteMsg(ErrMsg)
Dim strErr
strErr = strErr & "[err]" & ErrMsg & "[/err]"
Response.Write strErr
Call CloseConn
response.End()
End function
Sub InsertLog(LogType, ChannelID, UserName, UserIP, LogContent, ScriptName, PostString)
Dim sqlLog, rsLog
sqlLog = "select top 1 * from PE_Log"
Set rsLog = Server.CreateObject("Adodb.RecordSet")
rsLog.Open sqlLog, Conn, 1, 3
rsLog.addnew
rsLog("LogType") = LogType
rsLog("ChannelID") = ChannelID
rsLog("LogTime") = Now()
rsLog("UserName") = UserName
rsLog("UserIP") = UserIP
rsLog("LogContent") = LogContent
rsLog("ScriptName") = ScriptName
rsLog("PostString") = PostString
rsLog.Update
rsLog.Close
Set rsLog = Nothing
End Sub
Sub PE_Execute(strDllName, strClassName, DllType)
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_Admin, objName
objName = strDllName & "." & strClassName
Set PE_Admin = Server.CreateObject(objName)
If Err Then
Err.Clear
Response.Write "对不起，你的服务器没有安装动易组件（" & strDllName & ".dll），所以不能使用动易系统。请和你的空间商联系以安装动易组件。"
Exit Sub
End If
PE_Admin.iConnStr = ConnStr
Select Case DllType
Case "CMS"
PE_Admin.iCMS_Edition = CMS_Edition
Case "eShop"
PE_Admin.ieShop_Edition = eShop_Edition
Case "CRM"
PE_Admin.iCRM_Edition = CRM_Edition
Case Else
End Select
PE_Admin.iSystemDatabaseType = SystemDatabaseType
Call PE_Admin.Execute
Set PE_Admin = Nothing
If Err Then
Response.Write "错 误 号：" & Err.Number & "
"
Response.Write "错误描述：" & Err.Description & "
"
Response.Write "错误来源：" & Err.Source & "
"
Err.Clear
End If
End Sub
Sub PE_CreateHTML(strDllName, strClassName, DllType)
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_Admin, objName
objName = strDllName & "." & strClassName
Set PE_Admin = Server.CreateObject(objName)
If Err Then
Err.Clear
Response.Write "对不起，你的服务器没有安装动易组件（" & strDllName & ".dll），所以不能使用动易系统。请和你的空间商联系以安装动易组件。"
Exit Sub
End If
PE_Admin.iConnStr = ConnStr
If strClassName <> "CreateIndex" Then
Select Case DllType
Case "CMS"
PE_Admin.iCMS_Edition = CMS_Edition
Case "eShop"
PE_Admin.ieShop_Edition = eShop_Edition
Case "CRM"
PE_Admin.iCRM_Edition = CRM_Edition
Case Else
End Select
End If
PE_Admin.iSystemDatabaseType = SystemDatabaseType
Call PE_Admin.CreateHTML
Set PE_Admin = Nothing
If Err Then
Response.Write "错 误 号：" & Err.Number & "
"
Response.Write "错误描述：" & Err.Description & "
"
Response.Write "错误来源：" & Err.Source & "
"
Err.Clear
End If
End Sub
%>