20CN网络安全小组论坛 - 网站建设 - 这个论坛的原码在哪里修改数据库的路径啊

论坛: 网站建设标题: 这个论坛的原码在哪里修改数据库的路径啊

作者: asusmlan2 [asusmlan2]

论坛用户

以下的是leadbbs 3.14版论坛的SETUP.ASP文件.要修改数据库才能安装
-------------------------------------------------------------------------

<%
Dim con,GBL_CHK_TempStr
Dim HomeUrl
Const Old_HomeUrl = "/LeadBBS/"

HomeUrl = Request.Servervariables("SCRIPT_NAME")
HomeUrl = Replace(HomeUrl,"\","/")
If inStr(HomeUrl,"/") Then HomeUrl = Left(HomeUrl,inStrRev(HomeUrl,"/")-1)

Dim GBL_FSOString
GBL_FSOString = DEF_FSOString
If GBL_FSOString = "" Then GBL_FSOString = "Scripting.FileSystemObject"

On error Resume Next
Dim Fs,FsFlag
FSFlag = 1
Set fs = Server.CreateObject(DEF_FSOString)
If Err Then
FSFlag = 0
Err.Clear
End If

Sub OpenDatabase

On error Resume Next
set con = Server.CreateObject("ADODB.Connection")
'Con.ConnectionString = "driver={Microsoft Access Driver (*.mdb)};dbq=" & Server.MapPath(DEF_BBS_HomeUrl & DEF_AccessDatabase)
Con.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & Server.MapPath(DEF_BBS_HomeUrl & DEF_AccessDatabase)
con.open
if Err Then
err.Clear
Set Con = Nothing
GBL_CHK_TempStr = GBL_CHK_TempStr & "数据连接错误!"
Response.Write GBL_CHK_TempStr
Response.End
End If

End Sub

Sub CloseDatabase

Con.Close
Set Con = Nothing

End Sub

Function CheckObjInstalled(strClassString)

On Error Resume Next
Dim Temp
Err = 0
Dim TmpObj
Set TmpObj = Server.CreateObject(strClassString)
Temp = Err
If Temp = 0 Then
CheckObjInstalled = True
GBL_CHK_TempStr = "√"
ElseIf Temp = -2147221005 Then
GBL_CHK_TempStr = "组件未安装"
CheckObjInstalled = False
ElseIf Temp = -2147221477 Then
GBL_CHK_TempStr = "√支持此组件"
CheckObjInstalled = True
ElseIf Temp = 1 Then
GBL_CHK_TempStr = "×未知的错误，组件可能未正确安装"
CheckObjInstalled = False
End If
Err.Clear
Set TmpObj = Nothing
Err = 0

End Function

Sub InstallLeadBBS_CSSFile

Dim fs,WriteFile,fileContent,n
For N = 0 to 15
If FSFlag = 1 Then
Set fs = Server.CreateObject(GBL_FSOString)
Set WriteFile = fs.OpenTextFile(Server.MapPath("inc/style" & N & ".css"),1,True)
If Not WriteFile.AtEndOfStream Then
fileContent = WriteFile.ReadAll
End If
WriteFile.Close
Set fs = Nothing

fileContent = GetNewStrCSS(fileContent & "")
Set fs = Server.CreateObject(GBL_FSOString)
Set WriteFile = fs.CreateTextFile(Server.MapPath("inc/style" & N & ".css"),True)
WriteFile.Write fileContent
WriteFile.Close
Set fs = Nothing
Else
fileContent = ADODB_LoadFile("inc/style" & N & ".css")
ADODB_SaveToFile GetNewStrCSS(fileContent),"inc/style" & N & ".css"
Response.Write GBL_CHK_TempStr
End If
Next

If DEF_MasterCookies = "yellowboard" Then
Dim RandomStr,StrLetter
StrLetter = "abcdefghijklmnopqrstuvwxyz"
Randomize
RandomStr = ""
For N = 1 to 5
RandomStr = RandomStr & Mid(StrLetter,Fix(Rnd*Len(StrLetter))+1,1)
Next
If FSFlag = 1 Then
Set fs = Server.CreateObject(GBL_FSOString)
Set WriteFile = fs.OpenTextFile(Server.MapPath("inc/BBSSetup.asp"),1,True)
If Not WriteFile.AtEndOfStream Then
fileContent = WriteFile.ReadAll
End If
WriteFile.Close
Set fs = Nothing

fileContent = Replace(fileContent,"yellowboard",RandomStr)
Set fs = Server.CreateObject(GBL_FSOString)
Set WriteFile = fs.CreateTextFile(Server.MapPath("inc/BBSSetup.asp"),True)
WriteFile.Write fileContent
WriteFile.Close
Set fs = Nothing
Else
fileContent = ADODB_LoadFile("inc/BBSSetup.asp")
ADODB_SaveToFile Replace(fileContent,"yellowboard",RandomStr),"inc/BBSSetup.asp"
Response.Write GBL_CHK_TempStr
End If
End If

End Sub

Function GetNewStrCSS(Str)

dim re
set re = New RegExp
re.Global = True
re.IgnoreCase = True
re.Pattern="url\(([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]?)/images/skin/"
Str=re.Replace(Str,"url(" & HomeUrl & "/images/skin/")
re.Pattern="BACKGROUND=\""([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]?)/images/skin/"
Str=re.Replace(Str,"BACKGROUND=""" & HomeUrl & "/images/skin/")
re.Pattern="BACKGROUND=([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]?)/images/skin/"
Str=re.Replace(Str,"BACKGROUND=" & HomeUrl & "/images/skin/")

re.Pattern="url\(([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]+)/images/skin/"
Str=re.Replace(Str,"url(" & HomeUrl & "/images/skin/")
re.Pattern="BACKGROUND=\""([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]+)/images/skin/"
Str=re.Replace(Str,"BACKGROUND=""" & HomeUrl & "/images/skin/")
re.Pattern="BACKGROUND=([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]+)/images/skin/"
Str=re.Replace(Str,"BACKGROUND=" & HomeUrl & "/images/skin/")
Set Re = Nothing
GetNewStrCSS = Str

End Function

Sub InstallLeadBBS_Skin

Dim Temp_HomeUrl
Temp_HomeUrl = "http://"&Request.ServerVariables("server_name")
If Request.ServerVariables("SERVER_PORT") <> "80" Then Temp_HomeUrl = Temp_HomeUrl & ":" & Request.ServerVariables("SERVER_PORT")
Temp_HomeUrl = Lcase(Temp_HomeUrl & Request.Servervariables("SCRIPT_NAME"))
Temp_HomeUrl = Replace(Temp_HomeUrl,"\","/")
If inStr(Temp_HomeUrl,"/") Then Temp_HomeUrl = Left(Temp_HomeUrl,inStrRev(Temp_HomeUrl,"/")-1)

Dim Rs,Temp
Set Rs = Server.CreateObject("ADODB.RecordSet")
Rs.Open "Select * from LeadBBS_Skin",con,2,2
Do While Not Rs.Eof
Rs("SiteHeadString") = GetNewStr(Rs("SiteHeadString") & "",Temp_HomeUrl)
Rs("SiteBottomString") = GetNewStr(Rs("SiteBottomString") & "",Temp_HomeUrl)
Rs("TableHeadString") = GetNewStr(Rs("TableHeadString") & "",Temp_HomeUrl)
Rs("TableBottomString") = GetNewStr(Rs("TableBottomString") & "",Temp_HomeUrl)
Rs.Update
Rs.MoveNext
Loop
Rs.Close
Set Rs = Nothing

End Sub

Function GetNewStr(Str,Temp_HomeUrl)

dim re
set re = New RegExp
re.Global = True
re.IgnoreCase = True
re.Pattern="=\""([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]?)/images/skin/"
Str=re.Replace(Str,"=""" & HomeUrl & "/images/skin/")
re.Pattern="=([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]?)/images/skin/"
Str=re.Replace(Str,"=" & HomeUrl & "/images/skin/")
re.Pattern="\',\'\',\'([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]?)/images/skin/"
Str=re.Replace(Str,"','','" & HomeUrl & "/images/skin/")

re.Pattern="href=\""([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]?)/user/help/about.asp"
Str=re.Replace(Str,"href=""" & HomeUrl & "/user/help/about.asp")
re.Pattern="href=([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]?)/user/help/about.asp"
Str=re.Replace(Str,"href=" & HomeUrl & "/user/help/about.asp")

re.Pattern="href=\""([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]?)/user/help/help.asp"
Str=re.Replace(Str,"href=""" & HomeUrl & "/user/help/help.asp")
re.Pattern="href=([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]?)/user/help/help.asp"
Str=re.Replace(Str,"href=" & HomeUrl & "/user/help/help.asp")

re.Pattern="href=\""([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]?)/User/UserJoin.asp"
Str=re.Replace(Str,"href=""" & HomeUrl & "/User/UserJoin.asp")
re.Pattern="href=([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]?)/User/UserJoin.asp"
Str=re.Replace(Str,"href=" & HomeUrl & "/User/UserJoin.asp")

re.Pattern="href=\""([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]?)/User/LookUserInfo.asp"
Str=re.Replace(Str,"href=""" & HomeUrl & "/User/LookUserInfo.asp")
re.Pattern="href=([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]?)/User/LookUserInfo.asp"
Str=re.Replace(Str,"href=" & HomeUrl & "/User/LookUserInfo.asp")

re.Pattern="href=\""([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]?)/User/UserTop.asp"
Str=re.Replace(Str,"href=""" & HomeUrl & "/User/UserTop.asp")
re.Pattern="href=([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]?)/User/UserTop.asp"
Str=re.Replace(Str,"href=" & HomeUrl & "/User/UserTop.asp")

re.Pattern="href=\""([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]?)/Search/Search.asp"
Str=re.Replace(Str,"href=""" & HomeUrl & "/Search/Search.asp")
re.Pattern="href=([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]?)/Search/Search.asp"
Str=re.Replace(Str,"href=" & HomeUrl & "/Search/Search.asp")

re.Pattern="action=\""([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]?)/Search/Search.asp"
Str=re.Replace(Str,"action=""" & HomeUrl & "/Search/Search.asp")
re.Pattern="action=([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]?)/Search/Search.asp"
Str=re.Replace(Str,"action=" & HomeUrl & "/Search/Search.asp")

re.Pattern="href=\""([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]?)/Boards.asp"
Str=re.Replace(Str,"href=""" & HomeUrl & "/Boards.asp")
re.Pattern="href=([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]?)/Boards.asp"
Str=re.Replace(Str,"href=" & HomeUrl & "/Boards.asp")

re.Pattern="http://www.leadbbs.com/"
Str=re.Replace(Str,Temp_HomeUrl)

re.Pattern="=\""([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]+)/images/skin/"
Str=re.Replace(Str,"=""" & HomeUrl & "/images/skin/")
re.Pattern="=([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]+)/images/skin/"
Str=re.Replace(Str,"=" & HomeUrl & "/images/skin/")
re.Pattern="\',\'\',\'([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]+)/images/skin/"
Str=re.Replace(Str,"','','" & HomeUrl & "/images/skin/")

re.Pattern="href=\""([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]+)/user/help/about.asp"
Str=re.Replace(Str,"href=""" & HomeUrl & "/user/help/about.asp")
re.Pattern="href=([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]+)/user/help/about.asp"
Str=re.Replace(Str,"href=" & HomeUrl & "/user/help/about.asp")

re.Pattern="href=\""([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]+)/user/help/help.asp"
Str=re.Replace(Str,"href=""" & HomeUrl & "/user/help/help.asp")
re.Pattern="href=([A-Za-z0-9\./=\%\-&_~`@[\]\':+!#\ ]+)/user/help/help.asp"
Str=re.Replace(Str,"href=" & HomeUrl & "/user/help/help.asp")
re.Pattern="http://www.leadbbs.com/"
Str=re.Replace(Str,Temp_HomeUrl)
Set Re = Nothing
GetNewStr = Str

End Function

function deletefiles()

on error resume next
dim fs
Set fs=Server.CreateObject(GBL_FSOString)
if fs.FileExists(Server.Mappath("setup.asp")) then
fs.DeleteFile Server.Mappath("setup.asp"),True
deletefiles = 1
Response.Write "成功删除Setup.asp文件，安装完成．"
else
Response.Write "Setup.asp文件已经不存在，不需要再作删除，安装完成．"
deletefiles = 0
end if
Set fs=nothing

end function

Sub Main

Response.Write "当前安装绝对路径：" & HomeUrl
OpenDatabase
InstallLeadBBS_Skin
Response.Write "完成风格更多参数定义的安装路径更新．"
CloseDatabase
If FSFlag = 0 Then
Response.Write "服务器不支持FSO，将不能完成inc目录下面的CSS文件的目录自动更新，请手动更改． 提示：打开所有的.css文件，将字符串 " & Old_HomeUrl & "images/ 更改为 " & HomeUrl & "images/"
Else
InstallLeadBBS_CSSFile
Response.Write "成功完成16种风格的路径安装．"
End If
Application.Lock
'Application.Contents.RemoveAll()
FreeApplicationMemory
Application.UnLock
Response.Write "成功完成论坛重新启动．"
If FSFlag = 0 Then
Response.Write "服务器不支持FSO，不能自动删除Setup.asp文件，请登录FTP手动删除此文件．(注意一定要删除Setup.asp以保证论坛正常)"
Else
deletefiles
End If
Response.Write "<a href=" & HomeUrl & ">点击这里进入论坛．</a>"

End Sub

Sub Setup

'If Lcase(HomeUrl) = Lcase(Old_HomeUrl) Then
' Response.Write "安装路径已经是 " & Old_HomeUrl & "，不需要更新安装．"
' Response.Write "<a href=" & Old_HomeUrl & ">点击这里进入论坛</a>"
'Else
If Request("submitflag") = "yes" then
Main
Else
%>

========================================================== 
 LeadBBS v3.14初始化安装路径程序 
========================================================== 
 
注意，此功能将完成以下功能： 
      1.自动完成更新更多风格的图片路径。 
      2.自动完成16种风格的CSS文件背景图片路径． 
      3.论坛重新启动． 
      4.删除安装文件． 
安装过程中需要服务器支持文件写入，如果不支持文件写入，将不能完成下列操作： 
      1.INC目录下面16个CSS文件的图片路径的自动更改． 
      2.不支持FSO将不能自动删除Setup.asp文件，请使用FTP手动删除此文件． 
 
确认信息：真的要更新论坛安装路径么？ 

<input type=button value="点击开始安装" onclick="javascript:document.location.href='Setup.asp?submitflag=yes';" class=fmbtn style=FONT-SIZE:9pt;>
<%
End If
'End If

End Sub

Function FreeApplicationMemory

'Response.Write "释放论坛数据列表：<table>" & VbCrLf
Dim Thing
For Each Thing in Application.Contents
If Left(Thing,Len(DEF_MasterCookies)) = DEF_MasterCookies Then
'Response.Write "<tr><td>" & thing & "</td><td> "
If isObject(Application.Contents(Thing)) Then
Application.Contents(Thing).close
Set Application.Contents(Thing) = Nothing
Application.Contents(Thing) = null
'Response.Write "对象成功关闭"
ElseIf isArray(Application.Contents(Thing)) Then
Set Application.Contents(Thing) = Nothing
Application.Contents(Thing) = null
'Response.Write "数组成功释放"
Else
Response.Write htmlencode(Application.Contents(Thing))
Application.Contents(Thing) = null
End If
'Response.Write "</td></tr>"
End If
Next
'Response.Write "</table>"
on error resume next
Application.Contents.RemoveAll

End Function

Function htmlEncode(str)

If len(str)>0 Then
'htmlEncode=Replace(Replace(Replace(Replace(str,"&","&"),">",">"),"<","<"),"""",""")
htmlEncode=Replace(Replace(Replace(str,">",">"),"<","<"),"""",""")
Else
htmlEncode=str
End If

End Function

Function ADODB_LoadFile(ByVal File)

Dim objStream
'On Error Resume Next
Set objStream = Server.CreateObject("ADODB.Stream")
If Err.Number=-2147221005 Then
GBL_CHK_TempStr = "<div align='center'>您的主机不支持ADODB.Stream，无法完成操作，请手工进行</div>"
Err.Clear
Set objStream = Noting
Exit Function
End If
With objStream
.Type = 2
.Mode = 3
.Open
.LoadFromFile Server.MapPath(File)
If Err.Number<>0 Then
GBL_CHK_TempStr = "<div align='center'>文件"&File&"无法被打开，请检查是否存在!</div>"
Err.Clear
.Close
Set objStream = Noting
Exit Function
End If
.Charset = "GB2312"
.Position = 2
ADODB_LoadFile = .ReadText
.Close
End With
Set objStream = Nothing

End Function

'存储内容到文件
Sub ADODB_SaveToFile(ByVal strBody,ByVal File)

Dim objStream
On Error Resume Next
Set objStream = Server.CreateObject("ADODB.Stream")
If Err.Number=-2147221005 Then
GBL_CHK_TempStr = "<div align='center'>您的主机不支持ADODB.Stream，无法完成操作，请手工进行</div>"
Err.Clear
Set objStream = Noting
Exit Sub
End If
With objStream
.Type = 2
.Open
.Charset = "GB2312"
.Position = objStream.Size
.WriteText = strBody
.SaveToFile Server.MapPath(File),2
.Close
End With
Set objStream = Nothing

End Sub

Setup%>

地主发表时间: 06-10-24 09:24

回复: poemail [poemail]

论坛用户

MapPath后面是数据库对象路径，而你这里通过DEF_AccessDatabase再定义了数据库路径，在这段代码中，没有找到DEF_AccessDatabase的定义的语句，证明数据库链接文件不在这个程序中，
以下是你的代码：
------------------------------------
On error Resume Next
set con = Server.CreateObject("ADODB.Connection")
'Con.ConnectionString = "driver={Microsoft Access Driver (*.mdb)};dbq=" & Server.MapPath(DEF_BBS_HomeUrl & DEF_AccessDatabase)
Con.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & Server.MapPath(DEF_BBS_HomeUrl & DEF_AccessDatabase)
con.open
if Err Then
------------------------------------------
不过看到你下面的代码：
----------------------------------------
If FSFlag = 1 Then
Set fs = Server.CreateObject(GBL_FSOString)
Set WriteFile = fs.OpenTextFile(Server.MapPath("inc/BBSSetup.asp"),1,True)
If Not WriteFile.AtEndOfStream Then
fileContent = WriteFile.ReadAll
-----------------------------------------
你打开上面MapPath后面的inc/BBSSetup.asp文件看一下有没有定义数据库的地址？

B1层发表时间: 06-10-24 14:48

回复: asusmlan2 [asusmlan2]

论坛用户

是的啊，是我打开文件打错了，不是这个文件

B2层发表时间: 06-10-24 18:08

论坛: 网站建设