<!-- #include file=inc/BBSSetup.asp -->
<!-- #include file=inc/ubbcode_SQL.asp -->
<%
Dim GBL_CHK_User
Rem -------------------------------------------------------
Rem ------------dvbbs 7.0 to LeadBBS 3.14----------------
Rem -------------------------------------------------------
server.scripttimeout=99999

Dim Version
%>
<head>
<style>
body		{ 
		color:000000;
		font-size: 75%;
		font-family: "宋体"; 
                }
p{
		font-size:9pt;
	}
td{
		font-size:9pt;
	}
li{
		font-size:9pt;
		margin-left: 0pt
	}
ul{
		font-size:9pt;
		margin-left: 20pt
}
textarea{
     font-size:9pt;
     }
input{
     font-size:9pt;
     height:20;
     }
select{
     font-size:9pt;
     height:20;
     }
a{text-transform: none; text-decoration: none; color: #774400;}
a.link2:hover {  color: #551100; text-decoration: none}
a.link2 {  color: #551100; text-decoration: none}
a.com:hover {  color: #551100; text-decoration: none}
a:hover {color: #008800;}

</style>
</head>
<%
OpenLeadBBSDatabase
OpenDvBBSDatabase
CheckLeadBBSVersion

CopyBoardAssort
CopyBoardList
CopyBoardLink
CopyMessage
CopyUser
CopyAnnounce
CloseDatabase
CloseDatabase2

Function CheckLeadBBSVersion

	Dim Rs
	Set Rs = Con.ExeCute("Select top 1 ID from [LeadBBS_User] where UserName <> 'Admin'")
	If Not Rs.Eof Then
		Response.Write "<p><b><font color=Red>错误，您的转换工作已经进行过，如果再次转换需要重新开始，<br>请确认dtxy.asp文件为原始的LeadBBS3.14数据库文件．<p>提示：请复制BAK/dtxy.asp替换目录下面的dtxy.asp文件</font></b>"
		Rs.Close
		Set Rs = Nothing
		Response.End
	End If
	Rs.Close
	Set Rs = Nothing
	If Request("submitflag") = "yes" then
		Version = Request("Version")
		If Version = "Dvbbs 7.0" Then
		Else
			Response.Write "<p><b><font color=Red>错误的版本号，仅支持转换Dvbbs 7.0版本的数据库．</b></font>"
			Response.End
		End If
		Response.Write "<p><b>Dvbbs " & Version & "版本数据库将升迁到leadBBS 3.14，请耐心等候程序执行完毕．</b><br>" & VbCrLf
		Exit Function
	Else
		%><form action=DVBBS2LEADBBS.asp><p><br>
			<b>可转换的内容</b><br><br>
				&nbsp; 1.论坛帖子（包括主题）<br>
				&nbsp; 2.论坛用户<br>
				&nbsp; 3.论坛版面(二级以上的版面归到首个分类)<br>
				&nbsp; 4.论坛分类<br>
				&nbsp; 5.用户短消息<br>
				&nbsp; 6.友情论坛<br>

<p><b>不可转换的内容</b><p>

				&nbsp; 除上述外的都不可转换，另有下述说明<br><br>

				&nbsp; 1.dvbbs的[upload]等leadbbs中没有的标签未作转换<br>
				&nbsp; 2.金钱等加密帖都不能完成彻底转换，只是简单的复制内容<br>
				&nbsp; 3.投票帖子的投票项目及投票人等不能完成转换<br>
			<br>
			<b><font color=ff0000 class=RedFont>确认信息： 转换程序根据您的帖子量，可能需要较长的时间，真的要开始吗？</font></b><br><br>
			<p>
			<select name=Version>
				<option value="Dvbbs 7.0">Dvbbs 7.0</option>
			</select>
			<input name=submitflag value=yes type=hidden>
			<input type=submit value="点击开始转换数据库" class=fmbtn>
			</option>
		<%
		Response.End
	End If

End Function

Dim con,MaxRootID
MaxRootID = 1
Sub OpenLeadBBSDatabase

	on error resume next
	set con = Server.CreateObject("ADODB.Connection")
	Con.ConnectionString = "driver={Microsoft Access Driver (*.mdb)};dbq=" & Server.MapPath("dtxy.asp")
	'Con.ConnectionString = "Provider=SQLOLEDB;Data Source=(local);uid=sa;pwd=;database=;"
	con.open
	if Err Then
		err.Clear
		Set Con = Nothing
		Response.Write "leadbbs数据连接错误，请确定转换目录下面是否存在dtxy.asp文件!"
		Response.End
	End If

End Sub

Function CloseDatabase

	Con.Close
	Set con = Nothing

End Function


Rem 为VBScript的isDate缺陷而编写的函数,用on error resume next也拦不住
Function isTrueDate(TStr)

	If isNull(Tstr) Then
		isTrueDate = 0
		Exit Function
	End If
	Dim TempDate
	TempDate = TStr
	TempDate = Replace(TempDate,"年","-")
	TempDate = Replace(TempDate,"月","-")
	TempDate = Replace(TempDate,"日"," ")
	TempDate = Replace(TempDate,"上午"," ")
	TempDate = Replace(TempDate,"下午"," ")
	TempDate = Replace(TempDate,"  "," ")
	TempDate = Replace(TempDate,"  "," ")
	
	Dim N1,N2
	N1 = inStr(TempDate,"-")
	If N1>0 Then N2 = inStrRev(TempDate,"-")
	If N1 = N2 and N1 >0 Then
		isTrueDate = 0
		Exit Function
	End If
	
	N1 = inStr(TempDate,":")
	If N1>0 Then N2 = inStrRev(TempDate,"-")
	If N1 = N2 and N1 >0 Then
		isTrueDate = 0
		Exit Function
	End If
	
	If isDate(TStr) Then
		isTrueDate = 1
	Else
		isTrueDate = 0
	End If
	
End Function


Function ReplaceNotNull(str,str1,str2)

	If str<>"" Then
		ReplaceNotNull = Replace(str,str1,str2)
	Else
		ReplaceNotNull=str
	End If

end function


Rem 返回时间数字，比如YYYYMMDDHHmmSS
Function GetTimeValue(DateString)

	If isNull(DateString) Then
		GetTimeValue = 0
		Exit Function
	End If
	If isTrueDate(DateString) = 0 Then
		GetTimeValue = 0
		Exit Function
	End If
	Dim Temp,TempStr
	Temp = csTr(Year(DateString))
	If len(temp)<3 Then
		Temp = left(year(date),2) & temp
	End If
	TempStr = Temp
	
	Temp = csTr(month(DateString))
	If len(temp)<2 Then
		Temp = "0" & temp
	End If
	TempStr = TempStr & Temp

	Temp = csTr(day(DateString))
	If len(temp)<2 Then
		Temp = "0" & temp
	End If
	TempStr = TempStr & Temp

	Temp = csTr(Hour(DateString))
	If len(temp)<2 Then
		Temp = "0" & temp
	End If
	TempStr = TempStr & Temp

	Temp = csTr(Minute(DateString))
	If len(temp)<2 Then
		Temp = "0" & temp
	End If
	TempStr = TempStr & Temp

	Temp = csTr(Second(DateString))
	If len(temp)<2 Then
		Temp = "0" & temp
	End If
	TempStr = TempStr & Temp

	GetTimeValue = cCur(TempStr)

End Function

Function PrintTrueText(tempString)

	If tempString<>"" Then
		'PrintTrueText=ReplaceNotNull(ReplaceNotNull(htmlEncode(tempString),chr(13),"<br>" & VbCrLf),"  "," &nbsp;")
		PrintTrueText=ReplaceNotNull(ReplaceNotNull(ReplaceNotNull(ReplaceNotNull(ReplaceNotNull(htmlEncode(tempString),VbCrLf & " ","<br>" & "&nbsp;"),VbCrLf,"<br>" & VbCrLf),"   "," &nbsp; "),"  "," &nbsp;"),chr(9)," &nbsp; &nbsp; &nbsp;")

		If Left(PrintTrueText,1) = chr(32) Then
			PrintTrueText = "&nbsp;" & Mid(PrintTrueText,2)
			'PrintTrueText = ReplaceNotNull(PrintTrueText," ","&nbsp;",1,1)
		End If
	Else
		PrintTrueText=""
	End If

End Function

Function ReplaceNotNull(str,str1,str2)

	If isNull(str) Then str = ""
	If str<>"" Then
		ReplaceNotNull = Replace(str,str1,str2)
	Else
		ReplaceNotNull=str
	End If

end function

Function htmlEncode(str)

	If len(str)>0 Then
		'htmlEncode=ReplaceNotNull(ReplaceNotNull(ReplaceNotNull(ReplaceNotNull(str,"&","&amp;"),">","&gt;"),"<","&lt;"),"""","&quot;")
		htmlEncode=ReplaceNotNull(ReplaceNotNull(ReplaceNotNull(str,">","&gt;"),"<","&lt;"),"""","&quot;")
	Else
		htmlEncode=str
	End If

End Function

Function CloseDatabase2

	Con2.Close
	Set con2 = Nothing

End Function

Dim con2
Sub OpenDvBBSDatabase

	on error resume next
	set con2 = Server.CreateObject("ADODB.Connection")
	Con2.ConnectionString = "driver={Microsoft Access Driver (*.mdb)};dbq=" & Server.MapPath("dvbbs7.mdb")
	'Con2.ConnectionString = "Provider=SQLOLEDB;Data Source=(local);uid=sa;pwd=;database=;"
	con2.open
	if Err Then
		err.Clear
		Set Con2 = Nothing
		Response.Write "<p><b><font color=Red>dvbbs数据连接错误，请确定转换目录下是否存在dvbbs7.mdb文件</font></b>"
		Response.End
	End If

End Sub

Dim DefaultAssort
DefaultAssort = 0

Function CopyBoardAssort()

	Dim Rs,SQL
	Set Rs = Server.CreateObject("ADODB.RecordSet")
	
	Dim Rs2,SQL2
	Set Rs2 = Server.CreateObject("ADODB.RecordSet")

	Dim TempAT,T
	Dim NowID,EndFlag,GetData
	NowID = 0
	EndFlag = 0
	
	SQL2 = "Select * from Dv_Board where ParentID=0"
	Rs2.Open SQL2,con2,0,1
	If Not Rs2.Eof Then DefaultAssort = Rs2("BoardID")
	Do while Not Rs2.Eof
		SQL = "Select top 1 * From LeadBBS_Assort Where AssortID=" & Rs2("BoardID")
		Rs.Open SQL,con,0,1
		If Rs.Eof Then
			Rs.Close
			SQL = "Insert Into LeadBBS_Assort(AssortID,AssortName) Values(" & Rs2("BoardID") & ",'" & ReplaceNotNull(Rs2("BoardType"),"'","''") & "')"
			Con.Execute(SQL)
			'Response.write "<br><font color=green>" & htmlencode(Rs2("BoardType")) & " 分类成功添加!</font>"
		Else
			Rs.Close
			'Response.write "<br><font color=red>" & htmlencode(Rs2("BoardType")) & " 分类已经存在,略过添加!</font>"
		End if
		Rs2.MoveNext
	Loop
	Set Rs = Nothing
	Set Rs2 = Nothing
	Response.write "<br><font color=green>论坛一级分类转换完成，重复的已经自动略过!</font>"
	Response.Flush

End Function


Function CopyBoardList()

	Dim Rs,SQL
	Set Rs = Server.CreateObject("ADODB.RecordSet")

	Dim Rs2,SQL2
	Set Rs2 = Server.CreateObject("ADODB.RecordSet")

	Dim TempAT,T
	Dim NowID,EndFlag,GetData
	NowID = 0
	EndFlag = 0
	
	SQL2 = "Select * from Dv_Board where ParentID>0"
	Rs2.Open SQL2,con2,0,1
	Dim Assort
	Do while Not Rs2.Eof
		SQL = "Select top 1 * From LeadBBS_Assort Where AssortID=" & Rs2("ParentID")
		Rs.Open SQL,con,0,1
		If Rs.Eof Then
			Response.write "<br><font color=red>" & htmlencode(Rs2("BoardType")) & " 版面为二级以上或丢失的版面，归入到默认论坛分类" & DefaultAssort & "!</font>"
			Assort = DefaultAssort
		Else
			Assort = Rs2("ParentID")
		End If
		Rs.Close
		
		SQL = "Select top 1 * from leadbbs_Boards where BoardID=" & Rs2("boardid")
		Rs.Open SQL,con,0,1
		If Rs.Eof Then
			Rs.Close
			SQL = "Insert Into LeadBBS_Boards(BoardID,BoardAssort,BoardName,BoardIntro,LastWriter,LastWriteTime,TopicNum,AnnounceNum,ForumPass,HiddenFlag,LastAnnounceID,LastTopicName,MasterList,BoardLimit,AllMinRootID,AllMaxRootID,TodayAnnounce,GoodNum,OrderID,BoardStyle,StartTime,EndTime,BoardHead,Boardbottom,BoardImgUrl,BoardImgWidth,BoardImgHeight) Values(" &_
			Rs2("BoardID") & _
			"," & Assort & _
			",'" & ReplaceNotNull(Rs2("BoardType"),"'","''") & "'" & _
			",'" & ReplaceNotNull(Rs2("readme"),"'","''") & "'" & _
			",''" & _
			",0" & _
			",0" & _
			",0" & _
			",''" & _
			",0" & _
			",0" & _
			",''" & _
			",'" & ReplaceNotNull(ReplaceNotNull(Rs2("BoardMaster"),"'","''"),"|",",") & "'" & _
			",0" & _
			",0" & _
			",0" & _
			",0" & _
			",0" & _
			",0" & _
			",0" & _
			",0" & _
			",0" & _
			",''" & _
			",''" & _
			",'" & ReplaceNotNull(Rs2("indexImg"),"'","''") & "'" & _
			",54" & _
			",50" & _
			")"
			Con.Execute(SQL)
			'Response.write "<br><font color=green>" & htmlencode(Rs2("BoardType")) & " 版面成功添加!</font>"
		Else
			Rs.Close
			'Response.write "<br><font color=red>" & htmlencode(Rs2("BoardType")) & " 版面已经存在,略过添加!</font>"
		End if
		Rs2.MoveNext
	Loop
	Set Rs = Nothing
	Set Rs2 = Nothing
	Response.write "<br><font color=green>论坛版面转换完成，重复的已经自动略过，二级以上版面自动归入到一级分类!</font>"
	Response.Flush

End Function


Function CopyBoardLink()

	Dim Rs,SQL
	Set Rs = Server.CreateObject("ADODB.RecordSet")
	
	Dim Rs2,SQL2
	Set Rs2 = Server.CreateObject("ADODB.RecordSet")

	Dim TempAT,T
	Dim NowID,EndFlag,GetData
	NowID = 0
	EndFlag = 0
	
	SQL2 = "Select * from Dv_bbslink"
	Rs2.Open SQL2,con2,0,1
	Do while Not Rs2.Eof
		SQL = "Select top 1 * From LeadBBS_Link Where SiteName='" & ReplaceNotnull(Rs2("Boardname"),"'","''") & "'"
		Rs.Open SQL,con,0,1
		If Rs.Eof Then
			Rs.Close
			SQL = "Insert Into LeadBBS_Link(SiteName,SiteUrl,LogoUrl,OrderID,LogoWidth,LogoHeight,BreakFlag) Values(" &_
			"'" & ReplaceNotNull(Rs2("boardname"),"'","''") & "'" & _
			",'" & ReplaceNotNull(Rs2("url"),"'","''") & "'" & _
			",'" & ReplaceNotNull(Rs2("logo"),"'","''") & "'" & _
			",0" & _
			",88" & _
			",31" & _
			",0" & _
			")"
			Con.Execute(SQL)
			'Response.write "<br><font color=green>" & htmlencode(Rs2("boardname")) & " 友情链接添加!</font>"
		Else
			Rs.Close
			'Response.write "<br><font color=red>" & htmlencode(Rs2("boardname")) & " 友情链接已经存在,略过添加!</font>"
		End if
		Rs2.MoveNext
	Loop
	Set Rs = Nothing
	Set Rs2 = Nothing
	Response.write "<br><font color=green>友情论坛完成复制，重复的已经自动略过!</font>"
	Response.Flush

End Function

Function CopyMessage()

	Dim Rs,SQL
	Set Rs = Server.CreateObject("ADODB.RecordSet")
	
	Dim Rs2,SQL2
	Set Rs2 = Server.CreateObject("ADODB.RecordSet")

	Dim TempAT,T
	Dim ID, title, ndatetime, moreData, htmlflag, biglength, looktimes,linkurl,PrintmoreData,linkurlUBB,linkurltemp
	Dim NowID,EndFlag,GetData
	NowID = 0
	EndFlag = 0

	Dim RootMaxID,RootMinID
	Response.Write "<p>正在复制用户短信息。。。"
	
	Dim DvBBSRecordCount,CountIndex
	SQL2 = "Select count(*) from [Dv_message]"
	Rs2.Open SQL2,con2,0,1
	If Rs2.Eof Then
		DvBBSRecordCount = 0
	Else
		DvBBSRecordCount = Rs2(0)
		If isNull(DvBBSRecordCount) Then DvBBSRecordCount = 0
	End If
	Rs2.Close
	If DvBBSRecordCount < 1 Then DvBBSRecordCount = 1
	CountIndex = 0
	%>
	<p>下面开始转换用户短消息，共有<%=DvBBSRecordCount%>条待转换消息．

	<table width="400" border="0" cellspacing="1" cellpadding="1">
		<tr> 
			<td bgcolor=000000>
	<table width="400" border="0" cellspacing="0" cellpadding="1">
		<tr> 
			<td bgcolor=ffffff height=9><img src=bar.gif width=0 height=16 id=img1 name=img1 align=absmiddle></td></tr></table>
	</td></tr></table> <span id=txt1 name=txt1 style="font-size:9pt">0</span><span style="font-size:9pt">%</span>
	<%
	Response.Flush
	Do while EndFlag = 0
		SQL2 = "Select top 100 * from Dv_message where ID>" & NowID & " order by ID ASC"
		Rs2.Open SQL2,con2,0,1
		If Rs2.Eof Then
			EndFlag = 1
		End If
		Do While Not Rs2.Eof
			
			SQL = "Insert Into LeadBBS_InfoBox(FromUser,ToUser,Title,Content,IP,SendTime,ReadFlag) Values(" &_
			"'" & ReplaceNotNull(Rs2("sender"),"'","''") & "'" & _
			",'" & ReplaceNotNull(Rs2("incept"),"'","''") & "'" & _
			",'" & ReplaceNotNull(Rs2("title"),"'","''") & "'" & _
			",'" & ReplaceNotNull(Rs2("content"),"'","''") & "'" & _
			",''" & _
			"," & GetTimeValue(Rs2("sendTime")) & _
			"," & Rs2("flag") & _
			")"
			Con.Execute(SQL)
			
			NowID = Rs2(0)
			'Response.Write " " & NowID
			CountIndex = CountIndex + 1
			If (CountIndex mod 100) = 0 Then
				Response.Write "<script>img1.width=" & Fix((CountIndex/DvBBSRecordCount) * 400) & ";" & VbCrLf
				Response.Write "txt1.innerHTML=""" & FormatNumber(CountIndex/DvBBSRecordCount*100,4,-1) & """;" & VbCrLf
				Response.Write "img1.title=""" & NowID & "(" & CountIndex & ")"";</script>" & VbCrLf
				Response.Flush
			End If
			Rs2.MoveNext
		Loop
		Rs2.Close
	Loop
	Set Rs = Nothing
	Set Rs2 = Nothing
	%>
	<script>img1.width=400;
	txt1.innerHTML="100";</script>
	<%

End Function


Function CopyUser()

	Dim Rs,SQL
	Set Rs = Server.CreateObject("ADODB.RecordSet")
	
	Dim Rs2,SQL2
	Set Rs2 = Server.CreateObject("ADODB.RecordSet")

	Dim TempAT,T
	Dim ID, title, ndatetime, moreData, htmlflag, biglength, looktimes,linkurl,PrintmoreData,linkurlUBB,linkurltemp
	Dim NowID,EndFlag,GetData
	NowID = 0
	EndFlag = 0
	
	Dim RootMaxID,RootMinID
	Response.Write "<p>正在复制用户。。。"
	
	Dim DvBBSRecordCount,CountIndex
	SQL2 = "Select count(*) from [Dv_user]"
	Rs2.Open SQL2,con2,0,1
	If Rs2.Eof Then
		DvBBSRecordCount = 0
	Else
		DvBBSRecordCount = Rs2(0)
		If isNull(DvBBSRecordCount) Then DvBBSRecordCount = 0
	End If
	Rs2.Close
	If DvBBSRecordCount < 1 Then DvBBSRecordCount = 1
	CountIndex = 0
	%>
	<p>下面开始转换用户资料，共有<%=DvBBSRecordCount%>个待转换用户．

	<table width="400" border="0" cellspacing="1" cellpadding="1">
		<tr> 
			<td bgcolor=000000>
	<table width="400" border="0" cellspacing="0" cellpadding="1">
		<tr> 
			<td bgcolor=ffffff height=9><img src=bar.gif width=0 height=16 id=img2 name=img2 align=absmiddle></td></tr></table>
	</td></tr></table> <span id=txt2 name=txt2 style="font-size:9pt">0</span><span style="font-size:9pt">%</span>
	<%
	Response.Flush
	Dim TempV
	Do while EndFlag = 0
		SQL2 = "Select top 1000 * from [Dv_user] where UserID>" & NowID & " order by UserID ASC"
		Rs2.Open SQL2,con2,0,1
		If Rs2.Eof Then
			EndFlag = 1
		End If
		Do While Not Rs2.Eof
			Rs.Open "select top 1 * from LeadBBS_User Where UserName='" & Replace(Rs2("UserName") & "","'","''") & "'",con,2,2
			If Rs.Eof Then
				Rs.Addnew
				Rs("UserName") = Left(Rs2("UserName") & "",14)
				Rs("Pass") = Left(Rs2("UserPassword"),20)
				Rs("Mail") = Left(Rs2("UserEMail"),60)
				Rs("Address") = ""
				If isNull(Rs2("UserSex")) Then
					TempV = 0
				Else
					TempV = cStr(Rs2("UserSex"))
				End If
				If TempV = "2" Then
					Rs("Sex") = "女"
				ElseIf TempV = "1" then
					Rs("Sex") = "男"
				Else
					Rs("Sex") = "密"
				End if
				Rs("Birthday") = GetTimeValue(Rs2("Userbirthday"))
				Rs("ApplyTime") = GetTimeValue(Rs2("JoinDate"))
				'If isNumeric(Rs2("UserICQ")) Then
				'	Rs("ICQ") = cCur(Left(Rs2("UserICQ"),10))
				'Else
					Rs("ICQ") = 0
				'End If
				'If isNumeric(Rs2("OICQ")) Then
				'	Rs("OICQ") = cCur(Left(Rs2("UserOICQ"),10))
				'Else
					Rs("OICQ") = 0
				'End If
				Rs("Sessionid") = 0
				Rs("Online") = 0
				Rs("Prevtime") = 0
				Rs("Userphoto") = 0
				Rs("IP") = Left(Rs2("UserLastIP") & "",15)
				Rs("UserLevel") = 0
				'Rs("Homepage") = Left(Rs2("Homepage"),250)
				Rs("Homepage") = ""
				If isNull(Rs2("Usersign")) Then
					Rs("Underwrite") = ""
					Rs("PrintUnderWrite") = ""
				Else
					Rs("Underwrite") = Left(Rs2("Usersign"),255)
					Rs("PrintUnderWrite") = UBB_Code_UnderWrite(Rs2("Usersign"))
				End If
				Rs("Points") = Rs2("UserEP")
				Rs("Officer") = ""
				Rs("Login_IP") = ""
				Rs("Login_oknum") = 0
				Rs("Login_falsenum") = 0
				Rs("Login_lastpass") = ""
				Rs("Login_RightIP") = ""
				Rs("OnlineTime") = 0
				Rs("AnnounceNum") = Rs2("UserPost")
				Rs("AnnounceNum2") = Rs2("UserPost")
				Rs("LastDoingTime") = GetTimeValue(Rs2("lastlogin"))
				If Lcase(Left(Rs2("userface"),7)) = "http://" Then
					Rs("FaceUrl") = Left(Rs2("userface"),255)
				Else
					Rs("FaceUrl") = ""
				end If
				Rs("FaceWidth") = 65
				Rs("FaceHeight") = 65
				Rs("UserLimit") = 0
				Rs("ShowFlag") = 0
				Rs("MessageFlag") = 0
				Rs("NongLiBirth") = GetTimeValue(Rs2("Userbirthday"))
				Rs("AnnounceTopic") = 0
				Rs("AnnounceGood") = 0
				Rs("UploadNum") = 0
				Rs("CharmPoint") = 0
				Rs("CachetValue") = 0
				Rs("UserTitle") = Left(Rs2("Usertitle") & "",10)
				Rs("NotSecret") = 0
				Rs("Question") = Left(Rs2("Userquesion") & "",20)
				Rs("Answer") = Left(Rs2("UserAnswer") & "",32)
				Rs.Update
				Rs.Close
				NowID = Rs2("UserID")
				'Response.Write " " & NowID
			Else
				NowID = Rs2("UserID")
				'Response.Write " <font color=red>" & NowID & "</font>"
				Rs.close
			End If
			Response.Flush

			Rs2.MoveNext
			CountIndex = CountIndex + 1
			If (CountIndex mod 100) = 0 Then
				Response.Write "<script>img2.width=" & Fix((CountIndex/DvBBSRecordCount) * 400) & ";" & VbCrLf
				Response.Write "txt2.innerHTML=""" & FormatNumber(CountIndex/DvBBSRecordCount*100,4,-1) & """;" & VbCrLf
				Response.Write "img2.title=""" & NowID & "(" & CountIndex & ")"";</script>" & VbCrLf
				Response.Flush
			End If
		Loop
		Rs2.Close
	Loop
	Set Rs = Nothing
	Set Rs2 = Nothing
	%>
	<script>img2.width=400;
	txt2.innerHTML="100";</script>
	<%

End Function


Function CopyAnnounce()

	Response.Write "<p>正在论坛帖子。。。"
	Dim Rs,SQL
	Set Rs = Server.CreateObject("ADODB.RecordSet")
	
	Dim Rs2,SQL2
	Set Rs2 = Server.CreateObject("ADODB.RecordSet")

	Dim TempAT,T
	Dim ID, title, ndatetime, moreData, htmlflag, biglength, looktimes,linkurl,PrintmoreData,linkurlUBB,linkurltemp
	Dim NowID,EndFlag,GetData
	NowID = 0
	EndFlag = 0

	Dim RootMaxID,RootMinID

	Dim TempV

	Dim DvBBSRecordCount,CountIndex
	SQL2 = "Select count(*) from [Dv_topic]"
	Rs2.Open SQL2,con2,0,1
	If Rs2.Eof Then
		DvBBSRecordCount = 0
	Else
		DvBBSRecordCount = Rs2(0)
		If isNull(DvBBSRecordCount) Then DvBBSRecordCount = 0
	End If
	Rs2.Close
	If DvBBSRecordCount < 1 Then DvBBSRecordCount = 1
	CountIndex = 0
	%>
	<p>下面开始转换论坛帖子，共有<%=DvBBSRecordCount%>条待转换的主题．

	<table width="400" border="0" cellspacing="1" cellpadding="1">
		<tr> 
			<td bgcolor=000000>
	<table width="400" border="0" cellspacing="0" cellpadding="1">
		<tr> 
			<td bgcolor=ffffff height=9><img src=bar.gif width=0 height=16 id=img3 name=img3 align=absmiddle></td></tr></table>
	</td></tr></table> <span id=txt3 name=txt3 style="font-size:9pt">0</span><span style="font-size:9pt">%</span>
	<%
	Response.Flush
	Do while EndFlag = 0
		SQL2 = "Select top 100 TopicID,PostTable,Hits,TopicMode from [Dv_topic] where TopicID>" & NowID & " order by TopicID ASC"
		Rs2.Open SQL2,con2,0,1
		If Rs2.Eof Then
			EndFlag = 1
		End If
		Do While Not Rs2.Eof
			CopyRootData Rs2(0),Rs2(1),Rs2(2),Rs2(3)
			NowID = Rs2(0)
			'Response.Write " " & NowID
			'Response.Flush
			CountIndex = CountIndex + 1
			'If (CountIndex mod 100) = 0 Then
				Response.Write "<script>img3.width=" & Fix((CountIndex/DvBBSRecordCount) * 400) & ";" & VbCrLf
				Response.Write "txt3.innerHTML=""" & FormatNumber(CountIndex/DvBBSRecordCount*100,4,-1) & """;" & VbCrLf
				Response.Write "img3.title=""" & NowID & "(" & CountIndex & ")"";</script>" & VbCrLf
				Response.Flush
			'End If
			Rs2.MoveNext
		Loop
		Rs2.Close
	Loop
	Set Rs = Nothing
	Set Rs2 = Nothing
	%>
	<script>img3.width=400;
	txt3.innerHTML="100";</script>
	<%

End Function

Function CopyRootData(topicID,PostTable,Hits,TopicMode)

	Dim Rs,SQL
	Dim Rs2,SQL2
	
	Dim TempAT,T
	Dim ID, title, ndatetime, moreData, htmlflag, biglength, looktimes,linkurl,PrintmoreData,linkurlUBB,linkurltemp
	Dim NowID,EndFlag,GetData
	NowID = 0
	EndFlag = 0

	Dim RootMaxID,RootMinID

	'Response.Write "<p>执行时间ss:" & FormatNumber(cCur(Timer - DEF_PageExeTime1),4,True) * 1000
	
	'Set Rs = Con.ExeCute("Select Max(RootID) from LeadBBS_Announce")
	'If Rs.Eof Then
	'	MaxRootID = 1
	'Else
	'	MaxRootID = Rs(0)
	'	If isNull(MaxRootID) Then
	'		MaxRootID = 1
	'	Else
	'		MaxRootID = cCur(MaxRootID)
			MaxRootID = MaxRootID + 1
	'	End If
	'End If
	'Rs.Close
	'Set Rs = Nothing

	Dim TempV,Tt
	
	Dim TopicDoneFlag
	TopicDoneFlag = 0
	
	Dim ParentID,Bhits,NotReplay,GoodFlag,DateAndTime,RootIDBak,UserName
	Dim ChildNums,AnnounceID
	ChildNums = 0
	RootIDBak = 0
	
	Dim HaveFlag,TitleStyle
	HaveFlag = 0
	Dim Form_htmlflag,Form_PrintContent,Form_content
		SQL2 = "Select Topic,ParentID,Body,locktopic,isbest,DateAndTime,orders,BoardID,layer,Length,UserName,Signflag,IP from " & PostTable & " where RootID=" & topicID & " order by AnnounceID ASC"
		Set Rs2 = Con2.ExeCute(SQL2)
		If Not Rs2.Eof Then
			HaveFlag = 1
			Tt = Rs2("Topic")
			If isNull(Tt) or Tt = "" Then Tt = "Re:"
		End If
		Do While Not Rs2.Eof
			ChildNums = ChildNums + 1
			If TopicDoneFlag = 0 then
				ParentID = 0
				Bhits = Hits
				TitleStyle = TopicMode
				If TitleStyle < 0 Then TitleStyle = 0
				If TitleStyle > 4 Then TitleStyle = 4
			Else
				'ParentID = Rs2("ParentID")
				ParentID = RootIDBak
				Bhits = 0
				TitleStyle = 0
			End If
			If isNull(Rs2("topic")) or Rs2("topic") = "" then
				Title = Left("Re:" & Tt,255)
			Else
				Title = Rs2("Topic")
			End If
			
			'动网7.0的只有UBB格式的内容
			Form_htmlflag = 2
			Form_content = Html2UBBCode(ConvertDvBBSCode2LeadBBSCode(Rs2("Body")))
			If isNull(Form_content) Then Form_content = ""
			If Form_htmlflag = 2 Then
				Form_PrintContent = Ubb_code(Form_content)
				If Form_PrintContent = UBB_FiltrateBadWords(PrintTrueText(Form_content)) Then
					Form_htmlflag = 3
					Form_content = ""
				End If
			End If
			
			If Rs2("locktopic") = 0 or Rs2("locktopic") = False Then
				NotReplay = 0
			Else
				NotReplay = 1
			End If
			If Rs2("isbest") = 0 or Rs2("isbest") = False Then
				GoodFlag = 0
			Else
				GoodFlag = 1
			End If
			
			DateAndTime = GetTimeValue(Rs2("DateAndTime"))
			
			ndatetime = DateAndTime
			UserName = Left(Rs2("UserName"),20)
			On error Resume Next
			Con.ExeCute("insert into LeadBBS_Announce(ParentID,TopicSortID,BoardID,RootID,ChildNum,Layer" & _
			",Title,Content,PrintContent,FaceIcon,ndatetime,LastTime,Hits,Length,UserName,UserID" & _
			",HTMLFlag,UnderWriteFlag,NotReplay,IPAddress,GoodFlag,RootIDBak,TitleStyle)" & _
			" values(" & ParentID & "," & Rs2("orders") & "," & Rs2("BoardID") & "," & MaxRootID & ","  & 0 & _
			"," & Rs2("layer") & _
			",'" & Replace(title & "","'","''") & "'" & _
			",'" & Replace(Form_content & "","'","''") & "'" & _
			",'" & Replace(Form_PrintContent & "","'","''") & "'" & _
			"," & 0 & _
			"," & DateAndTime & _
			"," & DateAndTime & _
			"," & Bhits & _
			"," & Rs2("Length") & _
			",'" & Replace(UserName & "","'","''") & "'" & _
			"," & getUserID(UserName) & _
			"," & Form_htmlflag & _
			"," & Rs2("Signflag") & _
			"," & NotReplay & _
			",'" & Replace(Rs2("IP") & "","'","''") & "'" & _
			"," & GoodFlag & _
			"," & RootIDBak & _
			"," & TitleStyle & _
			")")
			
		If err <> 0 Then
			Err.Clear
			Response.Write "-"
		End If
			
				Set Rs = Con.ExeCute("Select @@IDENTITY")
				If Not Rs.Eof Then
					AnnounceID = cCur(Rs(0))
				Else
					Rs.Close
					Set Rs = Nothing
					Set Rs = Con.ExeCute("Select Max(ID) from LeadBBS_Announce")
					AnnounceID = cCur(Rs(0))
				End If
				Rs.Close
				Set Rs = Nothing
			
			If TopicDoneFlag = 0 then
				TopicDoneFlag = 1
				RootMaxID = AnnounceID
				RootMinID = AnnounceID
				RootIDBak = AnnounceID

			Con.ExeCute("insert into LeadBBS_Topic(ID,BoardID,RootID,ChildNum" & _
			",Title,FaceIcon,ndatetime,LastTime,Hits,Length,UserName,UserID" & _
			",NotReplay,GoodFlag,TitleStyle)" & _
			" values(" & AnnounceID & "," & Rs2("BoardID") & "," & MaxRootID & ","  & 0 & _
			",'" & Replace(title & "","'","''") & "'" & _
			"," & 0 & _
			"," & DateAndTime & _
			"," & DateAndTime & _
			"," & Bhits & _
			"," & Rs2("Length") & _
			",'" & Replace(UserName & "","'","''") & "'" & _
			"," & getUserID(UserName) & _
			"," & NotReplay & _
			"," & GoodFlag & _
			"," & TitleStyle & _
			")")
			
			Else
				RootMaxID = AnnounceID
			End If
			Rs2.MoveNext
			'Response.Write " ."
		Loop
		Rs2.Close
	Set Rs2 = Nothing
			'Response.Write "<p>执行时间ss2:" & FormatNumber(cCur(Timer - DEF_PageExeTime1),4,True) * 1000

	If HaveFlag = 1 Then
		Con.Execute("Update LeadBBS_Announce set RootMaxID=" & RootMaxID &_
			",RootMinID=" & RootMinID &_
			",ChildNum=" & ChildNums & ",LastTime=" & ndatetime & ",LastUser='" & Replace(UserName,"'","''") & "',RootIDBak=" & RootIDBak & " where ID=" & RootIDBak)
		Con.Execute("Update LeadBBS_Topic set RootMaxID=" & RootMaxID &_
			",RootMinID=" & RootMinID &_
			",ChildNum=" & ChildNums & ",LastTime=" & ndatetime & ",LastUser='" & Replace(UserName,"'","''") & "' where ID=" & RootIDBak)
	End If
	'RepairAnnounce(MaxRootID)

End Function

function GetUserID(UserName)

	Dim Rs,SQL
	Set Rs = Server.CreateObject("ADODB.RecordSet")
	SQL = "Select top 1 * from LeadBBS_User Where UserName='" & Replace(username,"'","''") & "'"
	Rs.Open SQL,con,0,1
	If Rs.Eof Then
		GetUserID = 0
	Else
		SQL = Rs(0)
		If isNull(SQL) Then SQL = 0
		GetUserID = cCur(SQL)
	End If
	Rs.Close
	Set Rs = Nothing

End Function

Function ConvertDvBBSCode2LeadBBSCode(Str)

	dim re,UBBStrCnt
	set re = New RegExp
	re.Global = True
	re.IgnoreCase = True

	UBBStrCnt = Replace(Str & "",VbCrLf,chr(3))
	re.Pattern="(\[\/upload\])"
	UBBStrCnt=re.Replace(UBBStrCnt,"[/upload]" & VbCrLf)
	re.Pattern="\[upload=(gif|jpg|jpeg|bmp|png)\](.[^\[]*)\[\/upload\]"
	UBBStrCnt= re.Replace(UBBStrCnt,"[IMGA]$2[/IMGA]")
	UBBStrCnt = Replace(UBBStrCnt,VbCrLf,"")
	UBBStrCnt = Replace(UBBStrCnt,chr(3),VbCrLf)
	UBBStrCnt = Replace(UBBStrCnt,VbCrLf,"<br>")
	ConvertDvBBSCode2LeadBBSCode = UBBStrCnt

End Function
	
%><p><b><font color=green>成功转换您的Dvbbs 7.0 的数据库到leadBBS 3.14数据库！<br>
请将dtxy.asp命名为您论坛的相应的数据库名称并作替换．<br>
执行3.14自带的Setup.asp文件，进行论坛初始化，即可完成论坛的升级．<br>