<% @LANGUAGE = "VBScript" %>
<%
'EditorTools文章采集发布助手
'----------------------------------
'动易内容管理系统2006SP6接口文件说明
'----------------------------------
'
'本接口适用于文章中心添加文章
'
'
'1、文件名
'ETpost.asp
'动易内容管理系统2006SP6版文章检查文件，请复制在网站根目录使用，为保密，请自行修改文件名；
'
'由于动易CMS程序没有开源，所以本接口发布规则需要设置发布成功特征码；
'
'ET发布配置-模拟发布-发布成功特征码处，填写“添加文章成功”
'
'主要参数
'Title			主题标题
'Content		文章内容
'UserName		用户名，必须为管理员
'Password		密码
'UploadFiles	上传文件列表
'
'
'必要附加参数
'（注：以下参数名后“=”号为示范而用，参数名本身不含“=”号）
'Action=SaveAdd		发布动作，默认参数，取值不可更改
'ChannelID=1		栏目类型，默认参数，取值不可更改
'ClassID=1			所属栏目编号，不指定为-1
'SpecialID=1		所属专题，无则为空
'IncludePic=0		简短标题，取值：1图文，2组图，3推荐，4注意，无则为0
'Keyword=关键字		关键字，必填（本项建议在采集配置-自定项中设置）
'Status=3			文章状态，取值：-1草稿，0待审核，3终审通过
'CreateImmediate=Yes	立即生成HTML静态页面，不生成则为空 
'SaveRemotePic=Yes		自动下载文章内容里的图片，无则为空
'						使用本功能时，ET采集规则里应取消下载图片，发布规则里不使用FTP上传
'PaginationType=0		内容分页方式，取值：0不分页，1自动分页，2手动分页
'						如使用“2”手动分页，则在过滤规则中将ET分页标记“<--subpage-->”替换为“[NextPage]”，注意大小写
'MaxCharPerPage=10000	自动分页时的每页大约字符数
'Stars=3				文章评分等级,无则为0
'Hits=0					点击数初始值
'
'一般附加参数
'TitleFontColor=		标题颜色，默认为空，格式“#000000”
'TitleFontType=0		标题字形，默认为0，取值：1粗体，2斜体，3粗+斜
'Subheading=			副标题（本项建议在采集配置-自定项中设置）
'ShowCommentLink=Yes	显示文章列表时在标题旁显示评论链接，不显示则为空
'Author=admin			文章作者，如：佚名、未知、admin，无则为空（本项建议在采集配置-自定项中设置）
'CopyFrom=本站原创		文章来源，无则为空（本项建议在采集配置-自定项中设置）	
'Intro=				文章简介，无则为空（本项建议在采集配置-自定项中设置）
'OnTop=yes			是否固顶文章，不设则为空
'Hot=yes			是否热门文章，不设则为空
'Elite=yes			是否推荐文章，不设则为空
'UpdateTime=		录入时间，可留空
'SkinID=0			配色风格编号，0为系统默认
'TemplateID=0		版面设计模板，0为系统默认
'InfoPurview=0		阅读权限，0为继承栏目权限，1所有会员，2指定会员组
'arrGroupID=		阅读权限指定会员组编号，1注册会员，2商业客户，3VIP客户，
'					4普通代理，5金牌代理，6钻石代理，8未验证会员，7待审批会员
'InfoPoint=			阅读点数
'ChargeType=0		重复收费方式，取值：0不重复收费，1距离上次收费时间PitchTime小时后重新收费，
'					2会员重复阅读此文章ReadTimes次后重新收费，3上述两者都满足时重新收费，
'					4上述两者任一个满足时就重新收费，5每阅读一次就重复收费一次
'PitchTime=24		距离上次收费时间多少小时
'ReadTimes=10		重复阅读此文章多少次
'DividePercent=0		分成比例
'
'
'
'ET发布配置-文章发布网址处，可以如下填写
'http://您的网址/ETpost.asp
'

'自在工坊 ET.Zzcity.net
'----------------------------------


Option Explicit
Response.Buffer = True
Server.ScriptTimeOut = 9999999
%>
<!--#include file="conn.asp"-->
<!--#include file="inc/function.asp"-->
<!--#include file="inc/md5.asp"-->
<%

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 & "<li>服务器脚本解释引擎（VBScript）版本过低，请联系您的空间商或服务器管理员更新。</li>"
'        ErrMsg = ErrMsg & "<li><a href='http://www.microsoft.com/downloads/release.asp?ReleaseID=33136' target='_blank'><font color='green'>脚本解释引擎下载地址</font></a></li>"
'    End If

    If UserName = "" Then
        FoundErr = True
        ErrMsg = ErrMsg & "<br><li>用户名不能为空！</li>"
    End If
    If Password = "" Then
        FoundErr = True
        ErrMsg = ErrMsg & "<br><li>密码不能为空！</li>"
    End If
'    If CheckCode = "" Then
'        FoundErr = True
'        ErrMsg = ErrMsg & "<br><li>验证码不能为空！</li>"
'    End If
'    If Trim(Session("CheckCode")) = "" Then
'        FoundErr = True
'        ErrMsg = ErrMsg & "<br><li>你在管理登录停留的时间过长，导致验证码失效。请重新返回登录页面进行登录。</li>"
'    End If
'    If CheckCode <> Session("CheckCode") Then
'        FoundErr = True
'        ErrMsg = ErrMsg & "<br><li>您输入的验证码和系统产生的不一致，请重新输入。</li>"
'    End If
'    If EnableSiteManageCode = True And AdminLoginCode <> SiteManageCode Then
'        FoundErr = True
'        ErrMsg = ErrMsg & "<br><li>您输入的后台管理认证码不对，请重新输入。</li>"
'    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 & "<br><li>用户名或密码错误！！！</li>"
    Else
        If Password <> rs("Password") Then
            FoundErr = True
            ErrMsg = ErrMsg & "<br><li>用户名或密码错误！！！</li>"
        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 & "<BR>"
        Response.Write "错误描述：" & Err.Description & "<BR>"
        Response.Write "错误来源：" & Err.Source & "<BR>"
        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 & "<BR>"
        Response.Write "错误描述：" & Err.Description & "<BR>"
        Response.Write "错误来源：" & Err.Source & "<BR>"
        Err.Clear
    End If
End Sub

%>
