星星博客 - Powered by Discuz! Board

'DV2LB.vbs
'
'动网至雷傲论坛数据转换程序
'转换程序编制：
'雷傲论坛河北代理
'一窍不通
'
LBDataPath = "."'转换后雷傲论坛数据存放路径
DVDBName = "dvbbs6.mdb"'动网数据库路径名称
Title = "DV2LB数据转换程序(β0.11)"
Welcome
AllTimeBegin = Timer
ThisTime = Now
timeUTC = "1970-1-1 8:00:00"
Set fso = CreateObject("Scripting.FileSystemObject")
LBPathAll = fso.GetAbsolutePathName(LBDataPath) & "/"
DVDBNameAll = fso.GetAbsolutePathName(DVDBName)
dataDir = LBPathAll & "data\"
Set DBConnection = CreateObject("Adodb.Connection")
ConnectionString = "driver={Microsoft Access Driver (*.mdb)};dbq="&DVDBNameAll
DBConnection.Open ConnectionString
Set rs = CreateObject("Adodb.Recordset")
ChangeMemberData
ChangeClassData
ChangeForumsData
ChangeMemberFriend
ChangeShareForums
ChangeFav
DBConnection.close
Set DBConnection = nothing
AllTimeEnd = Timer
AllTime = AllTimeEnd - AllTimeBegin
MsgBox "动网至雷傲数据转换完成.共用时"& alltime &"秒",vbInformation,Title &"—数据转换完成"
Sub Welcome()
Dim intDoIt
L_Welcome_MsgBox_Message_Text="动网至雷傲论坛数据转换程序"&vbnewline&vbnewline&"程序编制："&vbnewline&"雷傲论坛河北代理一窍不通"&vbnewline&vbnewline&"是否进行论坛数据转换?"
L_Welcome_MsgBox_Title_Text=Title&"——提示"
intDoIt = MsgBox(L_Welcome_MsgBox_Message_Text, _
vbOKCancel + vbInformation, _
L_Welcome_MsgBox_Title_Text )
If intDoIt = vbCancel Then
WScript.Quit
End If
End Sub
Sub ChangeMemberData()
'Doit = MsgBox ("用户数据转换", vbokcancel ,Title&"——用户数据转换")
'If (Doit = vbcancel) Then Exit Sub
memberDir = LBPathAll & "members\"
If not fso.FolderExists(memberDir) Then fso.CreateFolder(memberDir)
'On Error Resume Next
rs.open "user",DBConnection
While not rs.eof
UserName = ChangeName(rs("UserName"))
If UserName<>"" Then
userinfos = rs("userinfo")
If userinfos<>"" Then
userinfo = split(userinfos,"|||")
Else
userinfos = "||||||||||||||||||||||||||||||||||||||||||"
userinfo = split(userinfos,"|||")
End If
If rs("sex") Then mSex="m" Else mSex="f"
Select Case rs("usergroupid")
Case "1" MemberCode = "ad"
Case "2" MemberCode = "smo"
Case "3" MemberCode = "mo"
Case "4" MemberCode = "me"
Case "8" MemberCode = "rz"
Case Else MemberCode = "me"
End Select
MData = UserName & vbtab & rs("UserPassword") & vbtab & rs("title") & vbtab _
& MemberCode & vbtab & rs("article") & vbtab & rs("useremail") & vbtab _
& rs("showre") & vbtab & vbtab & rs("homepage") & vbtab & rs("oicq") & vbtab _
& rs("icq") & vbtab & userinfo(4) & userinfo(5) & vbtab & ChangeString(userinfo(2)) & vbtab _
& changedate(rs("adddate")) & vbtab & vbtab & ChangeString(rs("sign")) & vbtab & vbtab & vbtab & vbtab _
& userinfo(3) & vbtab & vbtab & userinfo(6) & vbtab & vbtab & vbtab & vbtab & rs("userpower") & vbtab _
& changedate(rs("lastlogin")) & vbtab & rs("logins") & vbtab & vbtab & vbtab _
& vbtab & -rs("userdel") & vbtab & mSex & vbtab & userinfo(11) & vbtab _
& userinfo(10) & vbtab & userinfo(9) & vbtab _
& rs("birthday") & vbtab & vbtab & vbtab & rs("usergroup") & vbtab _
& vbtab
'MsgBox mdata
MemberName = LCase(UserName)
MemberName = memberDir & MemberName & ".cgi"
Set MFile = fso.opentextfile (MemberName,2,true)
MFile.Write(MData)
MFile.close
End If
rs.movenext
Wend
rs.close
End Sub
Sub ChangeClassData()
'Doit = MsgBox ("论坛分类数据转换", _
'vbokcancel,Title & "——论坛分类转换")
'If Doit = vbcancel Then Exit Sub
If not fso.FolderExists(dataDir) Then fso.CreateFolder(dataDir)
sql = "select * from board where parentid=0 order by rootid"
Set rsClass = DBConnection.execute(sql)
While not rsclass.eof
AllFourms=""
sql = "select * from board where parentid=" & rsClass("boardid") &" order by orders"
Set rsB = DBConnection.execute(sql)
While not rsB.eof
LastPostInfo = split (rsB("lastpost"),"$")
master = rsB("boardmaster")
If master<>"" Then master = Replace(master,"|",",")
fData = rsb("boardid") & vbtab & rsClass("boardtype") & vbtab & rsClass("rootid") & vbtab _
& rsB("boardtype") & vbtab & ChangeString(rsB("readme")) & vbtab & master & vbtab _
& "off" & vbtab & "on" & vbtab & "no" & vbtab & "yes" & vbtab & ChangeName(LastPostInfo(0)) & vbtab _
& changedate(LastPostInfo(2)) & "%%%" & LastPostInfo(6) & "%%%" & LastPostInfo(3) & vbtab _
& rsB("lasttopicnum") & vbtab _
& rsB("lastbbsnum") & vbtab & vbtab & vbtab & vbtab & vbtab & "no" & vbtab & "yes" & vbtab _
& rsB("indeximg") & vbtab & vbtab
forumDir = LBPathAll & "forum" & rsB("boardid")
If not fso.FolderExists(forumDir) Then fso.CreateFolder (forumDir)
Set fFile=fso.opentextfile (forumDir & "\foruminfo.cgi",2,true)
fFile.Write(fData)
fFile.close
AllForums = AllForums & fData & vbnewline
rsB.movenext
Wend
rsB.close
rsClass.movenext
Wend
rsClass.close
AllForumsFileName = LBPathAll & "data\allforums.cgi"
Set AllForumsFile = fso.opentextfile(AllForumsFileName,2,true)
AllForumsFile.Write(Allforums)
AllForumsFile.close
End Sub
Sub ChangeForumsData()
'Doit = MsgBox("帖子数据转换",_
'vbokcanel,Title & "——帖子数据转换")
'If Doit = vbcancel Then Exit Sub
BoardDataDir = LBPathAll & "boarddata"
If not fso.FolderExists(BoardDataDir) Then fso.CreateFolder(BoardDataDir)
AbsontopFileName = BoardDataDir & "\absontop.cgi"
sql = "select * from board where not depth=0"
Set rsForum = DBConnection.execute(sql)
While not rsForum.eof
BoardID = rsForum("boardid")
BoardDir = LBPathAll & "forum" & BoardID
If not fso.FolderExists(BoardDir) Then fso.CreateFolder(BoardDir)
ListFileName = BoardDataDir & "\list" & BoardID & ".cgi"
JinghuaFileName = BoardDataDir & "\jinhua" & BoardID & ".cgi"
OntopFileName = BoardDataDir & "\ontop" & BoardID & ".cgi"
sql = "select * from topic where boardid = "& BoardID &" and not locktopic=2 order by lastposttime desc"
Set rsThread = DBConnection.execute(sql)
While not rsThread.eof
TopicID = rsThread("topicid")
voteoption = ""
If rsThread("isbest")=1 Then
Set JinghuaFile = fso.OpenTextFile(JinghuaFileName,8,true)
JinghuaFile.Write(TopicID & vbnewline)
JinghuaFile.Close
End If
istop = rsThread("istop")
If istop=2 Then
Set AbsontopFile = fso.OpenTextFile(AbsontopFileName,8,true)
AbsontopFile.Write(BoardID & "|" & TopicID)
AbsontopFile.Close
ElseIf istop=1 Then
Set OntopFile = fso.OpenTextFile(OntopFileName,8,true)
OntopFile.Write(TopicID & vbnewline)
OntopFile.Close
End If
sql = "select * from "& rsThread("posttable") &" where boardid = "& boardid &" and rootid = "& TopicID & " and not locktopic=2 order by dateandtime"
Set rsTopic = DBConnection.execute(sql)
If not(rsTopic.bof and rstopic.eof) Then
If rsThread("isvote") = 1 Then
TopicType = "Poll"
sql = "select * from vote where voteid = "& rsThread("pollid")
Set rsVote = DBConnection.execute(sql)
If rsVote("votetype")=1 Then votetype = "yes"Else votetype = "no"
voteoption = rsVote("vote")
voteoptions = split(voteoption,"|")
voteoption = join(voteoptions,"<br>")
sql = "select * from voteuser where voteid="& rsVote("voteid")
Set rsVoteUser = DBConnection.execute(sql)
PollFileName = BoardDir & "\" & TopicID & ".poll.cgi"
Set PollFile = fso.OpenTextFile(PollFileName,2,true)
While not rsVoteUser.eof
sql = "select username from user where userid="& rsVoteUser("Userid")
Set rs = DBConnection.execute(sql)
If not (rs.bof and rs.eof) Then postname = ChangeName(rs(0))
rs.close
If votetype = "yes" Then
postoption = ""
postoptions = split(rsVoteUser("voteoption"),",")
For i = 0 to UBound(postoptions)
If postoptions(i) <> "" Then postoption = postoption & "＊！＃＆＊" & postname & vbtab & postoptions(i)+1 & vbtab & vbnewline
Next
Else
postoption = "＊！＃＆＊" & postname & vbtab & rsVoteUser("voteoption")+1 & vbtab & vbnewline
End If
PollFile.Write(postoption)
rsVoteUser.movenext
Wend
PollFile.Close
rsVoteUser.Close
rsVote.Close
ElseIf rsThread("locktopic") = 1 Then
TopicType = "Close"
Else
Topictype = "Open"
End If
'On Error Resume Next
If rsTopic("signflag")=1 Then signflag = "yes" Else signflag = "no"
Topic = ChangeName(rsTopic("username")) & vbtab & "＊＃！＆＊" & rsTopic("topic") & vbtab _
& rsTopic("ip") & vbtab & "yes" & vbtab & signflag & vbtab _
& Changedate(rsTopic("dateandtime")) & vbtab & ChangeString(rsTopic("body")) & vbtab _
& voteoption & vbtab & vbnewline
rsTopic.movenext
While not rsTopic.eof
If rsTopic("signflag")=1 Then signflag = "yes" Else signflag = "no"
Topic = Topic & ChangeName(rstopic("username")) & vbtab & "＊＃！＆＊" & rsTopic("topic") & vbtab _
& rsTopic("ip") & vbtab & "yes" & vbtab & signflag & vbtab _
& Changedate(rsTopic("dateandtime")) & vbtab & ChangeString(rstopic("body")) & vbtab _
& "" & vbtab & vbnewline
rsTopic.movenext
Wend
rsTopic.Close
'
TopicFileName = BoardDir & "\" & TopicID & ".thd.cgi"
Set TopicFile = fso.OpenTextFile(TopicFileName,2,true)
TopicFile.write(topic)
TopicFile.close
'If err Then
'MsgBox err.number & Err.Description & " " & TopicID & vbnewline & topic & vbnewline & "end"
'err.clear
'WScript.Quit
'End If
lastpost = split(rsThread("lastpost"),"$")
TopicIndex = TopicID & vbtab & rsThread("title") & vbtab & vbtab & topictype & vbtab _
& rsThread("child") & vbtab & rsThread("hits") & vbtab & ChangeName(rsThread("postusername")) & vbtab _
& changedate(rsThread("dateandtime")) & vbtab & ChangeName(lastpost(0)) & vbtab _
& changedate(rsThread("lastposttime")) & vbtab & "" & vbtab & ChangeString(lastpost(3)) & vbtab & vbnewline
TopicIndexName = BoardDir & "\" & TopicID & ".pl"
Set IndexFile = fso.OpenTextFile(TopicIndexName,2,true)
IndexFile.Write(TopicIndex)
IndexFile.Close
Set ListFile = fso.OpenTextFile(ListFileName,8,true)
ListFile.Write(TopicIndex)
ListFile.Close
End If
rsThread.movenext
Wend
rsForum.movenext
rsThread.close
Wend
rsForum.Close
End Sub
Sub ChangeMemberFriend()
'转化用户好友名单
friendDir = LBPathAll & "memfriend\"
If not fso.FolderExists(friendDir) Then fso.createFolder(friendDir)
rs.open "Friend",DBConnection
While not rs.eof
fName = ChangeName(rs("f_username"))
fName = LCase(fName)
friendName = friendDir & fName & ".cgi"
Set memfriendFile = fso.opentextfile(friendName,8,true)
memfriendFile.Write("＊＃！＆＊" & ChangeName(rs("f_friend")) & vbnewline)
memfriendFile.close
rs.movenext
Wend
rs.close
End Sub
Sub ChangeShareforums()
'转化联盟论坛
shareForums = ""
rs.open "bbslink",DBConnection
If not(rs.bof and rs.eof) Then
While not rs.eof
shareForum = rs("boardname") & vbtab & rs("url") & vbtab & ChangeString(rs("readme")) & vbtab & vbtab & rs("logo") & vbtab & vbnewline
shareForums = shareForums & shareForum
rs.movenext
Wend
rs.close
shareFileName = dataDir & "shareforums.cgi"
Set shareFile = fso.opentextfile(shareFileName,2,true)
shareFile.write(shareForums)
shareFile.close
End If
End Sub
Sub ChangeFav()
'转化个人收藏夹
favDir = LBPathAll & "memfav"
If not fso.FolderExists(favDir) Then fso.CreateFolder(favDir)
rs.open "bookmark",DBConnection
While not rs.eof
fav0 = split(rs("url"),"?")
fav1 = split(fav0(1),"&")
fav11 = split(fav1(0),"=")
fav12 = split(fav1(1),"=")
fName = ChangeName(rs("username"))
favName = favDir & "\" & LCase(fName)
Set favFile = fso.OpenTextFile(favName,8,true)
favFile.Write(fav11(1) & vbtab & fav12(1) & vbtab & vbnewline)
favFile.Close
rs.movenext
Wend
rs.close
End Sub
Function ChangeDate(date1)
ChangeDate = DateDiff("s",timeUTC,date1)
End Function
Function ChangeString(string1)
'On Error Resume Next
strings = string1
If strings<>"" Then
strings = Replace(strings,vbtab,"")
ChangeString = Replace(strings,vbcrlf,"<br>")
End If
End Function
Function ChangeName(iUserName)
'On Error Resume Next
inUserName = iUserName
Set regex = new regexp
regEx.Global = True
regEx.Pattern = "[\`\~\!\@\#\$\%\^\&\*\-\_\+\=\|\\\{\[\}\]\:\;""\'\<\,\>\.\?\/]"
ChangeName = regEx.Replace(inUserName,"")
End Function

复制代码