<%@LANGUAGE="VBSCRIPT" CODEPAGE="936"%>
<%
Option Explicit
Response.Buffer=True
Server.ScriptTimeOut=9999999
'-----------------------------------------------------------------------
'--- 帖子批量导出静态页面工具 FOR 7.1.0 sp1 20050925
'--- Main Script
'--- http://html.laoman.com/
'--- By MGc
'-----------------------------------------------------------------------
Dim X_ForumName,X_ForumDomain,X_DatabaseInfo,X_CreatCatalogue
X_ForumName=Session("xhtml_forum_name")
X_ForumDomain=Session("xhtml_forum_domain")
X_DatabaseInfo=Session("xhtml_database_info")
X_CreatCatalogue=Session("xhtml_catalogue_path")

Dim X_Conn,X_ConnDeBug
Sub X_ConnectionDatabase(X_DatabaseInfo)
Dim X_TempString
Dim X_Connstr
X_TempString=Split(X_DatabaseInfo, "|")
If X_TempString(0) = "0" Then
X_Connstr="Provider=Microsoft.Jet.OLEDB.4.0;Data Source="& Server.MapPath(X_TempString(1))
Else
X_Connstr="Provider=Sqloledb;User ID="& X_TempString(3) &";Password="& X_TempString(4) &";Initial Catalog="& X_TempString(1) &";Data Source="& X_TempString(2) &";"
End If
On Error Resume Next
Set X_Conn=Server.CreateObject("ADODB.Connection")
X_Conn.Open X_Connstr
If Err.Number <> 0 Then
Err.Clear
Set X_Conn=Nothing
X_ConnDeBug=1
End if
End Sub

Sub DisconnectionDatabase
If IsObject(X_Conn) Then
X_Conn.Close
Set X_Conn=Nothing
End If
End Sub

Function X_InstallObject(X_ObjectName)
Dim X_TempObject
On Error Resume Next
Set X_TempObject=Server.CreateObject(X_ObjectName)
If Err.Number <> 0 Then
Err.Clear
X_InstallObject=False
Else
X_InstallObject=True
End if
Set X_TempObject=Nothing
End Function

Dim X_TemplateContent,X_TemplateDeBug
Sub X_Template(X_TemplateName)
'On Error Resume Next
Dim X_TemplateObject,X_TemplateFile
Set X_TemplateObject=Server.CreateObject("Scripting.FileSystemObject")
Set X_TemplateFile=X_TemplateObject.OpenTextFile(Server.MapPath("./xfiles/"& X_TemplateName &".htm"))
If Err.Number <> 0 Then
Err.Clear
Set X_TemplateFile=Nothing
Set X_TemplateObject=Nothing
X_TemplateDeBug=1
End if
X_TemplateContent=X_TemplateFile.ReadAll
X_TemplateFile.Close
Set X_TemplateFile=Nothing
Set X_TemplateObject=Nothing
End Sub

Dim X_HtmlContent,X_CreatDeBug
Sub X_CreatHtml(X_Catalogue,X_HtmlName)
'On Error Resume Next
If Not X_CheckFolder(X_Catalogue) Then
X_CreatDeBug=1
Exit Sub
End If
Dim X_CreatObject,X_CreatFile
Set X_CreatObject=Server.CreateObject("Scripting.FileSystemObject")
Set X_CreatFile=X_CreatObject.CreateTextFile(Server.MapPath(X_Catalogue & X_HtmlName &".htm"),True,False)
If Err.Number <> 0 Then
Set X_CreatFile=Nothing
Set X_CreatObject=Nothing
Err.Clear
X_CreatDeBug=1
Exit Sub
End if
X_CreatFile.Write(X_HtmlContent)
X_CreatFile.Close
Set X_CreatFile=Nothing
Set X_CreatObject=Nothing
End Sub

Function X_CheckFolder(byval X_LocalPath)
'On Error Resume Next
Dim X_FileObject
Dim X_patharr,X_path_level,X_pathtmp,X_cpath
X_LocalPath = Replace(X_LocalPath,"\","/") 
Set X_FileObject=Server.CreateObject("Scripting.FileSystemObject") 
X_patharr = Split(X_LocalPath,"/") 
X_path_level = Ubound(X_patharr)
Dim i
For i = 0 to X_path_level 
If i = 0 Then 
X_pathtmp = X_patharr(0) & "/"
Else
X_pathtmp = X_pathtmp & X_patharr(i) & "/"
End If
X_cpath = Left(X_pathtmp,Len(X_pathtmp)-1)
If Not X_FileObject.FolderExists(Server.MapPath(X_cpath)) Then X_FileObject.CreateFolder(Server.MapPath(X_cpath))
Next
Set X_FileObject=Nothing
If Err.Number<>0 then
Err.Clear
X_CheckFolder = False
Else
X_CheckFolder = True
End If
End Function

Function X_CheckFolderName(X_FolderName)
X_FolderName=Replace(X_FolderName, Chr(0), "")
'X_FolderName=Replace(X_FolderName, ".", "")
If Right(X_FolderName,1) <> "/" Then X_FolderName=X_FolderName & "/"
X_CheckFolderName=X_FolderName
End Function

Function X_ChineseNumber(X_Nubmer)
Dim X_Digit,X_FirstNumber,X_LastNumber,X_Output
X_Digit=Len(X_Nubmer)
X_FirstNumber=Left(X_Nubmer,1)
X_LastNumber=Right(X_Nubmer,1)
Select Case X_Digit
Case 1
X_Output=X_GetChineseNumber(X_Nubmer)
Case 2
If X_FirstNumber = 1 Then
If X_LastNumber = 0 Then
X_Output="十"
Else
X_Output="十"& X_GetChineseNumber(X_LastNumber)
End If
Else
X_Output=X_GetChineseNumber(X_FirstNumber) &"十"& X_GetChineseNumber(X_LastNumber)
End If
Case Else
X_Output=X_Nubmer
End Select
X_ChineseNumber=X_Output
End Function

Function X_GetChineseNumber(X_Number)
X_Number=Replace(X_Number, "1", "一")
X_Number=Replace(X_Number, "2", "二")
X_Number=Replace(X_Number, "3", "三")
X_Number=Replace(X_Number, "4", "四")
X_Number=Replace(X_Number, "5", "五")
X_Number=Replace(X_Number, "6", "六")
X_Number=Replace(X_Number, "7", "七")
X_Number=Replace(X_Number, "8", "八")
X_Number=Replace(X_Number, "9", "九")
X_Number=Replace(X_Number, "0", "")
X_GetChineseNumber=X_Number
End Function

Function X_HTMLEncode(X_fString)
X_HTMLEncode = X_fString
End Function

Select Case Request.QueryString("step")
Case "2"
Call X_Page2()
Case "3"
Call X_Page3()
Case "4"
Call X_Page4()
Case Else
Call X_Page1()
End Select

Sub X_Page1()
If Not X_InstallObject("Adodb.Connection") Then Call X_Warning(1,"不支持读取Access数据库")
If Not X_InstallObject("Scripting.FileSystemObject") Then Call X_Warning(1,"不支持使用FSO组件")
Response.Write "<div>工具信息</div>"& vbNewLine
Response.Write "<ul>"& vbNewLine
Response.Write "<li>动网超贴帖子批量导出静态页面工具</li>"& vbNewLine
Response.Write "<li>FOR 7.1.0 sp1 20050925</li>"& vbNewLine
Response.Write "<li>技术支持站点: <a href=""http://html.laoman.com/"">http://html.laoman.com/</a></li>"& vbNewLine
Response.Write "</ul>"& vbNewLine
Response.Write "<div>系统信息</div>"& vbNewLine
Response.Write "<ul>"& vbNewLine
Response.Write "<li>VBScript版本: " & ScriptEngineMajorVersion &"."& ScriptEngineMinorVersion &"</li>"& vbNewLine
Response.Write "<li>支持读取Access数据库</li>"& vbNewLine
Response.Write "<li>支持使用FSO组件</li>"& vbNewLine
Response.Write "</ul>"& vbNewLine
Response.Write "<div>参数设定</div>"& vbNewLine
Response.Write "<form name=""form1"" method=""post"" action=""xhtml.asp?step=2"">"& vbNewLine
Response.Write "<ul>"& vbNewLine
Response.Write "<li>超贴名称: <input name=""name"" type=""text"" value=""超贴""></li>"& vbNewLine
Response.Write "<li>超贴网址: <input name=""domain"" type=""text"" size=""50"" value=""http://www.chaotie.com/""> 最后加上“/”</li>"& vbNewLine
Response.Write "</ul>"& vbNewLine
Response.Write "<div>数据库设定</div>"& vbNewLine
Response.Write "<ul>"& vbNewLine
Response.Write "<li><input type=""radio"" name=""databasetype"" value=""0"" checked> Access <input type=""radio"" name=""databasetype"" value=""1""> MSSQL</li>"& vbNewLine
Response.Write "<li>数据库路径 / 数据库名称: <input name=""databasename"" type=""text"" value=""data/dvbbs7.mdb""></li>"& vbNewLine
Response.Write "<li>数据库用户名: <input name=""sqlusername"" type=""text"" value=""sa""></li> 选择Access数据库的用户填写无效"& vbNewLine
Response.Write "<li>数据库密码: <input name=""sqlpassword"" type=""text"" value=""""></li> 选择Access数据库的用户填写无效"& vbNewLine
Response.Write "<li>数据库连接名: <input name=""sqllocalname"" type=""text"" value=""localhost""></li> 选择Access数据库的用户填写无效"& vbNewLine
Response.Write "</ul>"& vbNewLine
Response.Write "<div><input type=""submit""></div>"& vbNewLine
Response.Write "</form>"& vbNewLine
End Sub

Sub X_Page2()
X_ForumName=Trim(Request.Form("name"))
X_ForumDomain=Trim(Request.Form("domain"))
Dim X_DatabaseType
X_DatabaseType=Trim(Request.Form("databasetype"))
If X_DatabaseType = 0 Then
X_DatabaseInfo="0|"& Trim(Request.Form("databasename"))
Else
X_DatabaseInfo="1|"& Trim(Request.Form("databasename")) &"|"& Trim(Request.Form("sqllocalname")) &"|"& Trim(Request.Form("sqlusername")) &"|"& Trim(Request.Form("sqlpassword")) &""
End If
Call X_ConnectionDatabase(X_DatabaseInfo)
If X_ConnDeBug=1 Then Call X_Warning(0,"尝试连接数据库失败，请检查填写路径是否正确。<BR>")
Session("xhtml_forum_name")=X_ForumName
Session("xhtml_forum_domain")=X_ForumDomain
Session("xhtml_database_info")=X_DatabaseInfo
Response.Write "<div>帖子表信息</div>"& vbNewLine
Response.Write "<ul>"& vbNewLine
Dim X_TableRs,X_TableList
Dim X_TableTotalTopicRs,X_TableTotal
Set X_TableRs = X_Conn.OpenSchema(20, Array(Empty, Empty, Empty, "table"))
Do Until X_TableRs.Eof
If Left(X_TableRs("Table_Name"),6)="Dv_bbs" and IsNumeric(Mid(X_TableRs("Table_Name"),7)) Then
Response.Write "<li>"& X_TableRs("Table_Name") & vbNewLine
Set X_TableTotalTopicRs=X_Conn.Execute("Select Count(*) From ["& X_TableRs("Table_Name") &"]")
Response.Write "主题+回复: "& X_TableTotalTopicRs(0) &"</li>"
X_TableTotal=X_TableTotal + 1
Set X_TableTotalTopicRs=Nothing
End If
X_TableRs.MoveNext
Loop
X_TableRs.MoveFirst
X_TableRs.Close
Set X_TableRs=Nothing
DisconnectionDatabase

If X_TableTotal < 1 Then Response.Write "<li>数据库内没有发现帖子表</li>"& vbNewLine
Response.Write "</ul>"& vbNewLine

Response.Write "<div>参数设定</div>"& vbNewLine
Response.Write "<form name=""form2"" method=""post"" action=""xhtml.asp?step=3"">"& vbNewLine
Response.Write "<ul>"& vbNewLine
Response.Write "<li>列表主题数: <input name=""maximum"" type=""text"" value=""1000""></li>"& vbNewLine
Response.Write "<li>生成目录: <input name=""catalogue"" type=""text"" value=""archiver/""></li>"& vbNewLine
Response.Write "</ul>"& vbNewLine
Response.Write "<div><input type=""submit""></div>"& vbNewLine
Response.Write "</form>"& vbNewLine
End Sub

Sub X_Page3()
Dim X_CreatListMaximum,X_CreatCatalogue
X_CreatListMaximum=Trim(Request.Form("maximum"))
X_CreatCatalogue=Trim(Request.Form("catalogue"))
Session("xhtml_catalogue_path")=X_CreatCatalogue
Call X_ConnectionDatabase(X_DatabaseInfo)
If X_ConnDeBug=1 Then Call X_Warning(0,"尝试连接数据库失败，请检查填写路径是否正确。<BR>")

Dim X_TopicRs,X_TopicFieldList,X_TopicSql
X_TopicFieldList="TopicID,Title,BoardID,LockTopic,Child,PostUserName,PostUserID,DateAndTime,hits"
X_TopicSql="Select "& X_TopicFieldList &" From [Dv_Topic] Order by TopicID Desc"
Set X_TopicRs=Server.CreateObject("ADODB.Recordset")
X_TopicRs.Open X_TopicSql,X_Conn,1,1
X_TopicRs.PageSize=X_CreatListMaximum
Response.Write "<DIV>生成帖子列表页面</DIV>"
Response.Write "<UL>"
Dim X_PageLoopi
For X_PageLoopi = 1 to X_TopicRs.PageCount
X_TopicRs.AbsolutePage = X_PageLoopi
Call X_Template("xhtml_template_t")
If X_TemplateDeBug = 1 Then
X_CanRunInfo="尝试打开列表模板文件失败，请检查填写路径是否正确。<BR>"
Call X_Warning(0,X_CanRunInfo)
End If
X_HtmlContent = X_TemplateContent
Call X_Template("xhtml_template_t_loop")
If X_TemplateDeBug = 1 Then
X_CanRunInfo="尝试打开列表循环部分模板文件失败，请检查填写路径是否正确。<BR>"
Call X_Warning(0,X_CanRunInfo)
End If
Dim X_HtmlListLoop,X_HtmlListDoLoop,X_HtmlListLoopNext
X_HtmlListLoop = X_TemplateContent
Dim X_TopicLoopi
For X_TopicLoopi = 1 to X_TopicRs.PageSize
If X_TopicRs.Eof Then : Exit For
X_HtmlListDoLoop=X_HtmlListLoop
X_HtmlListDoLoop=Replace(X_HtmlListDoLoop,"{$TopicID$}",""& X_TopicRs("TopicID") &"")
X_HtmlListDoLoop=Replace(X_HtmlListDoLoop,"{$Title$}",""& X_TopicRs("Title") &"")
X_HtmlListDoLoop=Replace(X_HtmlListDoLoop,"{$BoardID$}",""& X_TopicRs("BoardID") &"")
X_HtmlListDoLoop=Replace(X_HtmlListDoLoop,"{$Child$}",""& X_TopicRs("Child") &"")
X_HtmlListDoLoop=Replace(X_HtmlListDoLoop,"{$PostUserName$}",""& X_TopicRs("PostUserName") &"")
X_HtmlListDoLoop=Replace(X_HtmlListDoLoop,"{$PostUserID$}",""& X_TopicRs("PostUserID") &"")
X_HtmlListDoLoop=Replace(X_HtmlListDoLoop,"{$DateAndTime$}",""& X_TopicRs("DateAndTime") &"")
X_HtmlListDoLoop=Replace(X_HtmlListDoLoop,"{$Hits$}",""& X_TopicRs("hits") &"")
X_HtmlListDoLoop=Replace(X_HtmlListDoLoop,"{$Catalogue$}",""& X_CreatCatalogue &"")
X_HtmlListLoopNext=X_HtmlListLoopNext & X_HtmlListDoLoop
X_TopicRs.MoveNext
Next
Dim X_PagingLoopi
Dim X_HtmlListPaging
Dim X_PagingVeryLoopi
For X_PagingLoopi = 1 to X_TopicRs.PageCount
If X_PagingLoopi <> 1 Then
X_HtmlListPaging=X_HtmlListPaging & " | "
X_PagingVeryLoopi=X_PagingLoopi
Else
X_PagingVeryLoopi=""
End If
If X_PagingLoopi = X_PageLoopi Then
X_HtmlListPaging=X_HtmlListPaging & "<a href=""index"& X_PagingVeryLoopi &".htm""><font color=""#FF0000"">"& X_PagingLoopi * X_CreatListMaximum &"</font></a>"
Else
X_HtmlListPaging=X_HtmlListPaging & "<a href=""index"& X_PagingVeryLoopi &".htm"">"& X_PagingLoopi * X_CreatListMaximum &"</a>"
End If
Next
Dim X_PageChineseLoopi : X_PageChineseLoopi = X_PageLoopi
X_HtmlContent=Replace(X_HtmlContent,"{$ForumName$}", X_ForumName)
X_HtmlContent=Replace(X_HtmlContent,"{$ForumDomain$}", X_ForumDomain)
X_HtmlContent=Replace(X_HtmlContent,"{$Page$}", X_ChineseNumber(X_PageChineseLoopi) &"")
X_HtmlContent=Replace(X_HtmlContent,"{$StartPoint$}", (X_PageLoopi - 1) * X_CreatListMaximum + 1 &"")
X_HtmlContent=Replace(X_HtmlContent,"{$Paging$}", X_HtmlListPaging &"")
X_HtmlContent=Replace(X_HtmlContent,"{$RecordCount$}", X_TopicRs.RecordCount &"")
X_HtmlContent=Replace(X_HtmlContent,"{$PageCount$}", X_TopicRs.PageCount &"")
X_HtmlContent=Replace(X_HtmlContent,"{$TopicLoop$}", X_HtmlListLoopNext &"")
X_HtmlListPaging=Null
X_HtmlListLoopNext=Null
Dim X_HtmlName
If X_PageLoopi <> 1 Then
X_HtmlName="index"& X_PageLoopi
Else
X_HtmlName="index"
End If
Call X_CreatHtml(X_CreatCatalogue,X_HtmlName)
If X_CreatDeBug <> 1 Then X_innerHTML("成功生成列表文件 "& X_CreatCatalogue & X_HtmlName &".htm")
Next
Response.Write "</UL>"
X_TopicRs.Close
Set X_TopicRs=Nothing
DisconnectionDatabase

Response.Write "<div>列表文件全部生成完毕</div>"& vbNewLine
Response.Write "<div><a href=""xhtml.asp?step=4"">继续生成帖子预览页面</a></div>"& vbNewLine
End Sub

Sub X_Page4()
Call X_ConnectionDatabase(X_DatabaseInfo)
If X_ConnDeBug=1 Then Call X_Warning(0,"尝试连接数据库失败，请检查填写路径是否正确。<BR>")

Dim X_TempRs,X_TempSql
X_TempSql="Select TopicID,Title,BoardID,PostTable From [Dv_Topic] Order by TopicID Desc"
Set X_TempRs=Server.CreateObject("ADODB.Recordset")
X_TempRs.Open X_TempSql,X_Conn,1,1
If X_TempRs.Eof Then Call X_Warning(0,"数据库内不存在帖子，请选择正确的数据库。<BR>")

Call X_Template("xhtml_template_v")
If X_TemplateDeBug = 1 Then
X_CanRunInfo="尝试打开帖子预览模板文件失败，请检查填写路径是否正确。<BR>"
Call X_Warning(0,X_CanRunInfo)
End If
Dim X_HtmlView
X_HtmlView = X_TemplateContent
Dim X_HtmlViewLoop,X_HtmlViewDoLoop,X_HtmlViewLoopNext
Call X_Template("xhtml_template_v_loop")
If X_TemplateDeBug = 1 Then
X_CanRunInfo="尝试打开帖子预览回复循环模板文件失败，请检查填写路径是否正确。<BR>"
Call X_Warning(0,X_CanRunInfo)
End If
X_HtmlViewLoop = X_TemplateContent

Dim X_ViewRs,X_ViewSql,X_Loopi
Do While Not X_TempRs.Eof
X_HtmlContent = X_HtmlView
Set X_ViewRs=X_Conn.Execute("Select UserName,Topic,Body,DateAndTime,orders From ["& X_TempRs("PostTable") &"] Where RootID="& X_TempRs("TopicID") &" Order by orders Asc")
If Not X_ViewRs.Eof Then
For X_Loopi = 1 to 1000
If X_ViewRs.Eof Then : Exit For
X_HtmlViewDoloop=X_HtmlViewLoop
X_HtmlViewDoloop=Replace(X_HtmlViewDoloop,"{$UserName$}",X_ViewRs("UserName") &"")
X_HtmlViewDoloop=Replace(X_HtmlViewDoloop,"{$Topic$}",X_ViewRs("Topic") &"")
X_HtmlViewDoloop=Replace(X_HtmlViewDoloop,"{$Body$}",X_HTMLEncode(X_ViewRs("Body")) &"")
X_HtmlViewDoloop=Replace(X_HtmlViewDoloop,"{$DateAndTime$}",X_ViewRs("DateAndTime") &"")
X_HtmlViewLoopNext=X_HtmlViewLoopNext & X_HtmlViewDoloop
X_ViewRs.MoveNext
Next
End If
X_ViewRs.Close
Set X_ViewRs = Nothing

Dim X_BoardNameSql,X_BoardNameRs
X_BoardNameSql="Select boardtype From [Dv_Board] Where boardid="& X_TempRs("BoardID")
Set X_BoardNameRs=X_Conn.Execute(X_BoardNameSql)
If Not X_BoardNameRs.Eof Then
X_HtmlContent=Replace(X_HtmlContent,"{$BoardName$}",X_BoardNameRs(0) &"")
X_HtmlContent=Replace(X_HtmlContent,"{$BoardID$}",X_TempRs("BoardID") &"")
Else
X_HtmlContent=Replace(X_HtmlContent,"{$BoardName$}","未知版面")
X_HtmlContent=Replace(X_HtmlContent,"{$BoardID$}","0")
End If
X_BoardNameRs.Close
Set X_BoardNameRs = Nothing

X_HtmlContent=Replace(X_HtmlContent,"{$TopicID$}",X_TempRs("TopicID") &"")
X_HtmlContent=Replace(X_HtmlContent,"{$TopicTitle$}",X_TempRs("Title") &"")
X_HtmlContent=Replace(X_HtmlContent,"{$ForumName$}", X_ForumName)
X_HtmlContent=Replace(X_HtmlContent,"{$ForumDomain$}", X_ForumDomain)
X_HtmlContent=Replace(X_HtmlContent,"{$ViewLoop$}", X_HtmlViewLoopNext &"")
X_HtmlViewLoopNext=Null

Dim X_HtmlName,X_NewCatalogue
X_NewCatalogue=X_CreatCatalogue &"board"& X_TempRs("BoardID") &"/"
X_HtmlName="topic"& X_TempRs("TopicID")
Call X_CreatHtml(X_NewCatalogue,X_HtmlName)
If X_CreatDeBug <> 1 Then X_innerHTML("成功生成预览文件 "& X_NewCatalogue & X_HtmlName &".htm")
X_TempRs.MoveNext
Loop

X_TempRs.Close
Set X_TempRs=Nothing
DisconnectionDatabase

X_RemoveSession

Response.Write "<div>预览文件全部生成完毕</div>"& vbNewLine
Response.Write "<div>清除临时变量成功</div>"& vbNewLine
End Sub

Sub X_RemoveSession()
Session.Contents.Remove("xhtml_forum_name")
Session.Contents.Remove("xhtml_forum_domain")
Session.Contents.Remove("xhtml_database_info")
Session.Contents.Remove("xhtml_catalogue_path")
End Sub

Sub X_innerHTML(X_innerString)
Response.Write "<li>"
Response.Write X_innerString
Response.Write "</li>"
Response.Flush
End Sub

Sub X_Warning(X_WarningType,X_WarningInfo)
Response.Write "<ul>"
Response.Write "<li>"
Response.Write X_WarningInfo
Response.Write "</li>"
Response.Write "</ul>"
If X_WarningType = 0 Then
Response.Write "<div>由于以上原因，程序被终止。您可以尝试<a href=""javascript:history.go(-1)"">返回上页</a></div>"
Else
Response.Write "<div>由于以上原因，程序无法运行。</div>"
End If
Response.End
End Sub
%>
