asp制作中常用到的函数库集合

作者：袖梨 2023-08-10

ASP函数库

'''' 函数目录 ''''

''''-----------------------------------------------''''

'''' 函数ID：0001[截字符串] ''''

'''' 函数ID：0002[过滤html] ''''

'''' 函数ID：0003[打开任意数据表并显示表结构及内容]''''

'''' 函数ID：0004[读取两种路径] ''''

'''' 函数ID：0005[测试某个文件存在否] ''''

'''' 函数ID：0006[删除某个文件] ''''

'''' 函数ID：0007[判断目录是否存在] ''''

'''' 函数ID：0008[创建目录] ''''

'''' 函数ID：0009[删除目录] ''''

'''' 函数ID：0010[指定目录的文件列表] ''''

'''' 函数ID：0011[指定目录的目录列表] ''''

'''' 函数ID：0012[创建文本文件] ''''

'''' 函数ID：0013[读取文本文件] ''''

'''' 函数ID：0014[检测ID是否为数字类型] ''''

'''' 函数ID：0015[正则表达式测试] ''''

'''' 函数ID：0016[获得执行程序的名称] ''''

'''' 函数ID：0017[读取用户IP地址信息] ''''

'''' 函数ID：0018[上传文件到指定目录并改文件名称] ''''

'''' 函数ID：0019[过滤HTML脚本] ''''

'''' 函数ID：0020[创建MsAccess数据库] ''''

'''' 函数ID：0021[创建MsSQLServer数据库] ''''

'''' 函数ID：0022[通过JMAIL发信] ''''

'''' 函数ID：0023[测试组件是否安装] ''''

'''' 函数ID：0024[上传文件的窗口] ''''

'''' 函数ID：0025[取得数据库链接字串] ''''

'''' 函数ID：0026[取得multipart/form-data形式上传文件]

'''' 函数ID：0027[保存或查看上传到数据库中的数据，带调用上传窗口]

'''' 函数ID：0028[取得图像的类型|宽|高] ''''

'''' 函数ID：0029[将本地文件进行二进制分析，并保存到服务器的指定目录下]

'''' 函数ID：0030[将本地数据表或库上传并导入到服务器数据库的表中]

'''' 函数ID：0031[返回服务器信息] ''''

'''' 函数ID：0032[产生20位长度的唯一标识ID] ''''

'''' 函数ID：0033[用于左填充指定数量的字符] ''''

'''' 函数ID：0034[用于右填充指定数量的字符] ''''

'''' 函数ID：0035[格式化时间(显示)] ''''

'''' 函数ID：0036[测试数据库是否存在] ''''

'''' 函数ID：0037[测试数据库中的表是否存在] ''''

'''' 函数ID：0038[在线HTML编辑器] ''''

'''' 函数ID：0039[判断是否奇数] ''''

'''' 函数ID：0040[生成验证码图像BMP] ''''

'''' 函数ID：0041[生成随机密码] ''''

'''' 函数ID：0042[字符加解密] ''''

'''' 函数ID：0043[解密字符加解密] ''''

'''' 函数ID：0044[创建数据表] ''''

'''' 函数ID：0045[在数据库中插入字段值] ''''

'''' 函数ID：0046[Cookie防乱码写入时用] ''''

'''' 函数ID：0047[Cookie防乱码读出时用] ''''

'''' 函数ID：0048[检测用户名和密码是否正确] ''''

'''' 函数ID：0049[生成时间的整数] ''''

'''' 函数ID：0050[获得栏目的所有子栏目字符串并用","隔开]

'''' ''''

'**************************************************''''

'函数ID：0001[截字符串]

'函数名：SubstZFC

'作用：截字符串，汉字一个算两个字符，英文算一个字符

'参数：str ----原字符串

' strlen ----截取长度

'返回值：截取后的字符串

'**************************************************

Public Function SubstZFC(ByVal str, ByVal strlen)

If str = "" Then

SubstZFC = ""

Exit Function

End If

Dim l, t, c, i, strTemp

str = Replace(Replace(Replace(Replace(str, " ", " "), """, Chr(34)), ">", ">"), "<", "<")

l = Len(str)

t = 0

strTemp = str

strlen = CLng(strlen)

For i = 1 To l

c = Abs(Asc(Mid(str, i, 1)))

If c > 255 Then

t = t + 2

Else

t = t + 1

End If

If t >= strlen Then

strTemp = Left(str, i)

Exit For

End If

SubstZFC = Replace(Replace(Replace(Replace(strTemp, " ", " "), Chr(34), """), ">", ">"), "<", "<")

End Function

'**************************************************

'函数ID：0002[过滤html]

'函数名：GlHtml

'作用：过滤html 元素

'参数：str ---- 要过滤字符

'返回值：没有html 的字符

'**************************************************

Public Function GlHtml(ByVal str)

If IsNull(str) Or Trim(str) = "" Then

GlHtml = ""

Exit Function

End If

Dim re

Set re = New RegExp

re.IgnoreCase = True

re.Global = True

re.Pattern = "(<.[^<]*>)"

str = re.Replace(str, " ")

re.Pattern = "(</[^<]*>)"

str = re.Replace(str, " ")

Set re = Nothing

str = Replace(str, "'", "")

str = Replace(str, Chr(34), "")

GlHtml = str

End Function

'**************************************************

'函数ID：0003[打开任意数据表并显示表结构及内容]

'函数名：OpOtherDB

'作用：打开任意数据表并显示表结构及内容

'参数：DBtheStr ---- 要打开表的数据库链接字串

'参数：Opentdname ---- 要打开表名

'返回值：显示表结构及内容

'**************************************************

Public Function OpOtherDB(ByVal DBtheStr,ByVal Opentdname)

Response.write "<table border='0' width='100%' cellspacing='0' cellpadding='0'>" & vbCrlf

Set Opdb_Conn=server.createobject("ADODB.Connection")

Set Opdb_Rs =server.createobject("ADODB.Recordset")

Opdb_Conn.open DBtheStr

Opdb_sql_str="select * from "&Opentdname

Opdb_Rs.open Opdb_Sql_Str,Opdb_Conn,1,1

Nfieldnumber=Opdb_Rs.Fields.count

If Nfieldnumber >0 then

Response.write "<tr>" & vbCrlf

For i=0 to (Nfieldnumber-1)

Response.write "<td style='border-style: ridge; border-width: 1' bgcolor='#E1E1E1' valign='middle' align='center'>"

Response.write Trim(Opdb_Rs.Fields(i).Name)

Response.write "</td>" & vbCrlf

temptbi=0

Do While Not Opdb_Rs.Eof

Response.write "</tr>" & vbCrlf

For i=0 to (Nfieldnumber-1)

If (temptbi<2) Then

Response.write "<td style='border-style: ridge; border-width: 1' bgcolor='#F6F6F6' valign='middle'>"

Response.write Trim(Opdb_Rs.Fields(i))

Response.write "</td>" & vbCrlf

temptbi=temptbi+1

Else

Response.write "<td style='border-style: ridge; border-width: 1' valign='middle'>"

Response.write Trim(Opdb_Rs.Fields(i))

Response.write "</td>" & vbCrlf

If temptbi>=3 Then

temptbi=0

Else

temptbi=temptbi+1

End If

Opdb_Rs.MoveNext

Response.write "</tr>" & vbCrlf

Loop

End If

Opdb_Rs.Close

Opdb_Conn.Close

Set Opdb_Rs = Nothing

Set Opdb_Conn=Nothing

Response.write "</table>" & vbCrlf

End function

'**************************************************

'函数ID：0004[读取两种路径]

'函数名：Readsyspath

'作用：读取路径

'参数：lx ---- 0:服务器IP加路径 1:服务物理路径

'返回值：路径字串

'**************************************************

Public Function Readsyspath(ByVal lx)

Dim templj,aryTemp,newpath

templj=""

newpath=""

If lx=0 Then

templj="http://"&Request("SERVER_NAME")&Request("PATH_INFO")

aryTemp = Split(templj,"/")

Else

templj=Request("PATH_TRANSLATED")

aryTemp = Split(templj,"")

End If

For i = LBound(aryTemp) To UBound(aryTemp)-1

If lx=0 Then

newpath=newpath&aryTemp(i)&"/"

Else

newpath=newpath&aryTemp(i)&""

End If

Readsyspath=newpath

End Function

'**************************************************

'函数ID：0005[测试某个文件存在否]

'函数名：CheckFile

'作用：测试某个文件存在否

'参数：ckFilename ---- 被测试的文件名（包括路径）

'返回值：文件存在返回True,否则False

'**************************************************

Public Function CheckFile(ByVal ckFilename)

Dim M_fso

CheckFile=False

Set M_fso = CreateObject("Scripting.FileSystemObject")

If M_fso.FileExists(ckFilename) Then

CheckFile=True

End If

Set M_fso = Nothing

End Function

'**************************************************

'函数ID：0006[删除某个文件]

'函数名：DelFile

'作用：删除某个文件

'参数：dFilename ---- 被删除的文件名（包括路径）

'返回值：文件删除返回True,否则False

'**************************************************

Public Function DelFile(ByVal dFilename)

Dim M_fso

DelFile=False

Set M_fso = CreateObject("Scripting.FileSystemObject")

If M_fso.FileExists(dFilename) Then

M_fso.DeleteFile(dFilename)

DelFile=True

End If

Set M_fso = Nothing

End Function

'**************************************************

'函数ID：0007[判断目录是否存在]

'函数名：CheckDir

'作用：判断目录是否存在

'参数：ckDirname ---- 目录名（包括路径）

'返回值：目录存在返回True,否则False

'**************************************************

Public Function CheckDir(ByVal ckDirname)

Dim M_fso

CheckDir=False

Set M_fso = CreateObject("Scripting.FileSystemObject")

If (M_fso.FolderExists(ckDirname)) Then

CheckDir=True

End If

Set M_fso = Nothing

End Function

'**************************************************

'函数ID：0008[创建目录]

'函数名：CreateDir

'作用：创建目录

'参数：crDirname ---- 目录名（包括路径）

'返回值：目录创建成功返回True,否则False

'**************************************************

Public Function CreateDir(ByVal crDirname)

Dim M_fso

CreateDir=False

Set M_fso = CreateObject("Scripting.FileSystemObject")

If (M_fso.FolderExists(crDirname)) Then

CreateDir=False

Else

M_fso.CreateFolder(crDirname)

CreateDir=True

End If

Set M_fso = Nothing

End Function

'**************************************************

'函数ID：0009[删除目录]

'函数名：DelDir

'作用：删除目录

'参数：DlDirname ---- 目录名（包括路径）

'返回值：目录删除成功返回True,否则False

'**************************************************

Public Function DelDir(ByVal DlDirname)

Dim M_fso

DelDir=False

Set M_fso = CreateObject("Scripting.FileSystemObject")

If (M_fso.FolderExists(DlDirname)) Then

M_fso.DeleteFolder(DlDirname)

DelDir=True

End If

Set M_fso = Nothing

End Function

'**************************************************

'函数ID：0010[指定目录的文件列表]

'函数名：ListFiles

'作用：指定目录的文件列表

'参数：Dirname ---- 目录名（包括路径）

'返回值：文件列表字符串，之间用“|”相隔

'**************************************************

Public Function ListFiles(ByVal Dirname)

Dim M_fso,fNS,fLS,Fnames,FnamesN

Set M_fso = CreateObject("Scripting.FileSystemObject")

If (M_fso.FolderExists(Dirname)) Then

Set fNS = M_fso.GetFolder(Dirname)

Set fLS=fNS.Files

For Each FnamesN in fLS

Fnames=Fnames & FnamesN.name

Fnames=Fnames & "|"

ListFiles=Fnames

End If

Set M_fso = Nothing

End Function

'**************************************************

'函数ID：0011[指定目录的目录列表]

'函数名：ListDirs

'参数：Dirname ---- 目录名（包括路径）

'返回值：目录列表字符串，之间用“|”相隔

'**************************************************

Public Function ListDirs(ByVal Dirname)

Dim M_fso,fNS,fLS,Fnames,FnamesN

Set M_fso = CreateObject("Scripting.FileSystemObject")

If (M_fso.FolderExists(Dirname)) Then

Set fNS = M_fso.GetFolder(Dirname)

Set fLS=fNS.SubFolders

For Each FnamesN in fLS

Fnames=Fnames & FnamesN.name

Fnames=Fnames & "|"

ListDirs=Fnames

End If

Set M_fso = Nothing

End Function

'**************************************************

'函数ID：0012[创建文本文件]

'函数名：WritTextFile

'作用：创建文本文件

'参数：Fname ---- 文本文件名称（包括路径）

'参数：WritString ---- 写入的内容

'返回值：创建成功返回True，否则False

'**************************************************

Public Function WritTextFile(ByVal Fname,ByVal WritString)

Dim M_fso,FnameN

WritTextFile=False

Set M_fso = CreateObject("Scripting.FileSystemObject")

Set FnameN= M_fso.OpenTextFile(Fname,2,True)

FnameN.Write WritString

FnameN.Close

Set M_fso = Nothing

WritTextFile=True

End Function

'**************************************************

'函数ID：0013[读取文本文件]

'函数名：ReadTextFile

'作用：读取文本文件

'参数：Fname ---- 文本文件名称（包括路径）

'返回值：返回读取的文本内容

'**************************************************

Public Function ReadTextFile(ByVal Fname)

Dim M_fso,FnameN,Fnr

ReadTextFile=""

Set M_fso = CreateObject("Scripting.FileSystemObject")

Set FnameN= M_fso.OpenTextFile(Fname,1,True)

Fnr=FnameN.ReadAll

FnameN.Close

Set M_fso = Nothing

ReadTextFile=Fnr

End Function

'**************************************************

'函数ID：0014[检测ID是否为数字类型]

'函数名：JCID

'作用：检测ID是否为数字类型

'参数：ParaValue ---- 被检测的ID值

'返回值：返回ID值，如果不为数字类型返回0

'**************************************************

Public Function JCID(ByVal ParaValue)

If ((Not isNumeric(ParaValue)) OR (Trim(ParaValue)="")) Then

JCID=0

Else

JCID=ParaValue

End If

End function

'**************************************************

'函数ID：0015[正则表达式测试]

'函数名：CheckExp

'作用：正则表达式测试

'参数：patrn ---- 正则表达式

'参数：strng ---- 要测试的字符串

'返回值：测试如果成立返回 True 否则 False

'例 CheckExp("(<.[^<]*>)","<br>")

'**************************************************

Public Function CheckExp(ByVal patrn, ByVal strng)

Dim regEx, retVal

Set regEx = New RegExp

regEx.Pattern = patrn

regEx.IgnoreCase = False

retVal = regEx.Test(strng)

CheckExp = retVal

End Function

'**************************************************

'函数ID：0016[获得执行程序的名称]

'函数名：GT_the_proname

'作用：获得执行程序的名称

'参数：

'返回值：返回执行程序的名称

'**************************************************

Public Function GT_the_proname()

Dim fu_name,temp,tempsiz

temp=Request.ServerVariables("PATH_INFO")

fu_name=Split(temp, "/", -1, 1)

tempsiz=UBound(fu_name)

GT_the_proname=fu_name(tempsiz)

End function

'**************************************************

'函数ID：0017[读取用户IP地址信息]

'函数名：Readusip

'作用：读取用户IP地址信息

'参数：

'返回值：返回用户IP地址

'**************************************************

Public Function Readusip()

Dim strIPAddr

If Request.ServerVariables("HTTP_X_FORWARDED_FOR") = "" OR InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), "unknown") > 0 Then

strIPAddr = Request.ServerVariables("REMOTE_ADDR")

ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",") > 0 Then

strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",")-1)

ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";") > 0 Then

strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";")-1)

Else

strIPAddr = Request.ServerVariables("HTTP_X_FORWARDED_FOR")

End If

Readusip = Trim(Mid(strIPAddr, 1, 30))

End Function

'**************************************************

'函数ID：0018[无组件上传文件到指定目录并改文件名称]

'函数名：UpFsRn

'作用：无组件上传文件到指定目录并更改文件名称

'参数：RetSize--- 上传限止大小（单位是M）

'参数：Fdir ---- 目标路径

'参数：Objwj ---- 目标文件名称

'返回值：如果成功 True 否则 False

'例 UpFsRn(10,Readsyspath(1)&"zfkhauto","test.txt")

'使用表单提取文件 <form method='POST' action='function.asp' enctype='multipart/form-data'><input type='file' name='T1'><input type='submit' value='提交' name='B1'></form>

'**************************************************

Public Function UpFsRn(ByVal RetSize,ByVal Fdir,ByVal Objwj)

UpFsRn=False

Dim oUpStream,oStream,formsize,Formdata,strFileName,strFileDir,ObjAllPath,datastart,dataend

strFileDir = Fdir

strFileName = Swj

ObjAllPath = ""

If Right(strFileDir,1)<>"" Then strFileDir=strFileDir&""

ObjAllPath =strFileDir&Objwj

If CheckFile(ObjAllPath) Then DelFile(ObjAllPath)

formsize=Request.TotalBytes

if (formsize<=(RetSize*1024*1024)) then

Formdata=Request.BinaryRead(formsize)

Pos_ts=LenB(getByteString(Chr(13) & Chr(10) & Chr(13) & Chr(10)))

Pos_b=InstrB(Formdata,getByteString(Chr(13) & Chr(10) & Chr(13) & Chr(10)))+Pos_ts

nFormdata=MidB(Formdata,Pos_b)

Pos_ts=InstrB(nFormdata,getByteString(Chr(13) & Chr(10) & "--"))

nnFormdata=MidB(nFormdata,Pos_ts)

Pos_e=LenB(Formdata)-LenB(nnFormdata)-Pos_b+1

datastart =Pos_b

dataend=Pos_e

set oUpStream = Server.CreateObject("adodb.stream")

oUpStream.Type = 1

oUpStream.Mode = 3

oUpStream.Open

set oStream = Server.CreateObject("adodb.stream")

oStream.Type = 1

oStream.Mode = 3

oStream.Open

oUpStream.Write Formdata

oUpStream.position=datastart-1

oUpStream.copyto oStream,dataend

oStream.SaveToFile ObjAllPath,2

oStream.Close

set oStream=nothing

UpFsRn=True

End If

End function

'**************************************************

'函数ID：0019[过滤HTML脚本]

'函数名：FilterJS

'作用：过滤HTML脚本

'参数：strHTML ---- 被检测的HTML字串

'返回值：返回过滤后的HTML

'**************************************************

Function FilterJS(ByVal strHTML)

Dim objReg,strContent

If IsNull(strHTML) OR strHTML="" Then Exit Function

Set objReg=New RegExp

objReg.IgnoreCase =True

objReg.Global=True

objReg.Pattern="(&#)"

strContent=objReg.Replace(strHTML,"")

strContent=objReg.Replace(strContent,"")

strContent=objReg.Replace(strContent,"")

FilterJS=strContent

strContent=""

Set objReg=Nothing

End Function

'**************************************************

'函数ID：0020[创建MsAccess数据库]

'函数名：CrDb_MsAccess

'作用：创建MsAccess数据库

'参数：DbPath ---- 目标目录信息

'参数：DbFileName ---- 目标库文件名称

'参数：DbUpwd ---- 目标库打开密码

'返回值：建立成功返回 True 否则 False

'**************************************************

Public Function CrDb_MsAccess(ByVal DbPath,ByVal DbFileName,ByVal DbUpwd)

CrDb_MsAccess=False

On Error GoTo 0

On Error Resume Next

DIM fxztxt,fu_fu_db_str,fu_db_str

fxztxt=Chr(60)&"%Response.end()%"&Chr(62)

If Right(DbPath,1)<>"" Then DbPath=DbPath & ""

fu_fu_db_str="Provider=Microsoft.Jet.OLEDB.4.0;Data Source="&DbPath&"temp.mdb;"

fu_db_str ="Provider=Microsoft.Jet.OLEDB.4.0;Data Source="&DbPath&DbFileName&";Jet OLEDB:Database Password="&DbUpwd&";"

Set fu_Ca = Server.CreateObject("ADOX.Catalog")

fu_Ca.Create fu_fu_db_str

Set fu_Ca = Nothing

Set fu_Je = Server.CreateObject("JRO.JetEngine")

fu_Je.CompactDatabase fu_fu_db_str,fu_db_str

Set fu_fso = CreateObject("Scripting.FileSystemObject")

fu_fso.DeleteFile(DbPath&"temp.mdb")

Set fu_Je = Nothing

Set fu_fso = Nothing

set fu_Conn =server.createobject("ADODB.Connection")

set fu_Rs =server.createobject("ADODB.Recordset")

fu_Conn.open fu_db_str

fu_Sql_Str="CREATE TABLE [0] ([0] Text DEFAULT Notxt NOT NULL,[11] int IDENTITY (1, 1) NOT NULL PRIMARY KEY)"

fu_Conn.Execute(fu_Sql_Str)

fu_Sql_Str="Select * From [0]"

fu_Rs.open fu_Sql_Str,fu_Conn,1,3

fu_Rs.addnew

fu_Rs("0")=fxztxt

fu_Rs.update

fu_Rs.Close

fu_Conn.Close

Set fu_Rs = Nothing

Set fu_Conn = Nothing

If Err.Number = 0 Then

CrDb_MsAccess=True

End If

On Error GoTo 0

End function

'**************************************************

'函数ID：0021[创建MsSQLServer数据库]

'函数名：CrDb_MsSQLServer

'作用：创建MsSQLServer数据库

'参数：DbIp ---- 数据库所在IP或主机名称

'参数：DbSamc ---- 数据库超管用户名称

'参数：DbSapwd---- 数据库超管用户口令

'参数：DbName ---- 新建数据库名称

'参数：DbUpmc ---- 新建数据库所属用户名称

'参数：DbUpwd ---- 新建数据库所属用户密码

'返回值：建立成功返回 True 否则 False

'**************************************************

Public Function CrDb_MsSQLServer(ByVal DbIp,ByVal DbSamc,ByVal DbSapwd,ByVal DbName,ByVal DbUpmc,ByVal DbUpwd)

CrDb_MsSQLServer=False

On Error GoTo 0

On Error Resume Next

DIM fu_Sa_Str,fu_Ua_Str,fu_Conn,fu_Rs,fu_Sql_Str,fxztxt

fxztxt=Chr(60)&"%Response.end()%"&Chr(62)

fu_Sa_Str ="DRIVER=SQL Server;UID="&DbSamc&";DATABASE=master;SERVER="&DbIp&";PWD="&DbSapwd&";"

fu_Ua_Str ="DRIVER=SQL Server;UID="&DbUpmc&";DATABASE="&DbName&";SERVER="&DbIp&";PWD="&DbUpwd&";"

Set fu_Conn = Server.CreateObject("ADODB.Connection")

fu_Conn.Open fu_Sa_Str

fu_Conn.Execute "CREATE DATABASE " &DbName

fu_Conn.Close

fu_DB_Conn_Str="DRIVER=SQL Server;UID="&DbSamc&";DATABASE="&DbName&";SERVER="&DbIp&";PWD="&DbSapwd&";"

fu_Conn.Open fu_DB_Conn_Str

fu_Sql_Str="EXEC sp_addlogin '"&DbUpmc&"','"&DbUpwd&"','"&DbName&"'"

fu_Conn.Execute fu_Sql_Str

fu_Sql_Str="EXEC sp_grantdbaccess '"&DbUpmc&"'"

fu_Conn.Execute fu_Sql_Str

fu_Sql_Str="EXEC sp_addrolemember 'db_owner', '"&DbUpmc&"'"

fu_Conn.Execute fu_Sql_Str

fu_Sql_Str="EXEC sp_defaultdb "&DbUpmc&","&DbName

fu_Conn.Execute fu_Sql_Str

fu_Conn.Close

fu_Conn.open fu_Ua_Str

fu_Sql_Str="CREATE TABLE [0] ([0] Text DEFAULT ('Notxt') NOT NULL,[11] int IDENTITY (1, 1) NOT NULL PRIMARY KEY)"

fu_Conn.Execute fu_Sql_Str

Set fu_Rs=server.createobject("ADODB.Recordset")

fu_Sql_Str="Select * From [0]"

fu_Rs.open fu_Sql_Str,fu_Conn,1,3

fu_Rs.addnew

fu_Rs("0")=fxztxt

fu_Rs.update

fu_Rs.Close

fu_Conn.Close

Set fu_Rs = Nothing

Set fu_Conn=Nothing

If Err.Number = 0 Then

CrDb_MsSQLServer=True

End If

On Error GoTo 0

End function

'**************************************************

'函数ID：0022[通过JMAIL发信]

'函数名：MSMail

'作用：通过JMAIL发信

'参数：subject ---- 邮件的标题

'参数：mailaddress ---- 邮件服务器地址

'参数：senderName ---- 发件人名称

'参数：email ---- 收件人E-MAIL地址

'参数：content ---- 邮件内容

'参数：fromer ---- 发件人E-MAIL地址

'参数：serEmailUser ---- 邮件服务器权限用户名

'参数：serEmailPass ---- 邮件服务器权限用户密码

'返回值：发送成功返回 True 否则 False

'示例：MSMail("test","smtp.163.com","mzy","[email protected]","test","[email protected]","mzymcm","abcmzy1029abc")

'**************************************************

Public Function MSMail(ByVal subject, ByVal mailaddress, ByVal senderName, ByVal email, ByVal content, ByVal fromer, ByVal serEmailUser, ByVal serEmailPass)

dim JmailMsg

MSMail=False

set JmailMsg=server.createobject("jmail.message")

JmailMsg.mailserverusername=serEmailUser

JmailMsg.mailserverpassword=serEmailPass

JmailMsg.addrecipient email

JmailMsg.from=fromer

JmailMsg.fromname=senderName

JmailMsg.charset="gb2312"

JmailMsg.logging=true

JmailMsg.silent=true

JmailMsg.subject=Subject

JmailMsg.body=Server.HTMLEncode(content)

JmailMsg.htmlbody=content

if not JmailMsg.send(mailaddress) then

MSMail=False

else

MSMail=True

end if

JmailMsg.close

set JmailMsg=nothing

End function

'**************************************************

'函数ID：0023[测试组件是否安装]

'函数名：IsObjInstalled

'作用：测试组件是否安装

'参数：strClassString ---- 组件名称或标识字串

'返回值：测试成功返回 True 否则 False

'示例：IsObjInstalled("JMAIL.Message")

'**************************************************

Public Function IsObjInstalled(ByVal strClassString)

On Error Resume Next

IsObjInstalled = False

Err = 0

Dim xTestObj

Set xTestObj = Server.CreateObject(strClassString)

If 0 = Err Then IsObjInstalled = True

Set xTestObj = Nothing

Err = 0

End Function

'**************************************************

'函数名：GetObjVer

'作用：返回组件版本信息

'参数：strClassString ---- 组件名称或标识字串

'返回值：返回组件版本信息字串

'示例：GetObjVer("JMAIL.Message")

'**************************************************

Public Function GetObjVer(ByVal strClassString)

On Error Resume Next

GetObjVer=""

Err = 0

Dim xTestObj

Set xTestObj = Server.CreateObject(strClassString)

If 0 = Err Then GetObjVer=xtestobj.version

Set xTestObj = Nothing

Err = 0

End Function

'**************************************************

'函数名：ListObjInfo

'作用：列出组件安装信息

'参数： ----

'返回值：列出组件安装信息

'示例：ListObjInfo()

'**************************************************

Public Function ListObjInfo()

Dim TempBs,TempBsXX,TempObjType,tmpObjs

TempBs="×"

TempBsXX=""

TempObjType=""

tmpObjs=""

tmpObjs=tmpObjs& "JMail.Message|"

tmpObjs=tmpObjs& "ADODB.Stream|"

tmpObjs=tmpObjs& "MSWC.AdRotator|"

tmpObjs=tmpObjs& "MSWC.BrowserType|"

tmpObjs=tmpObjs& "MSWC.NextLink|"

tmpObjs=tmpObjs& "MSWC.Tools|"

tmpObjs=tmpObjs& "MSWC.Status|"

tmpObjs=tmpObjs& "MSWC.Counters|"

tmpObjs=tmpObjs& "MSWC.PermissionChecker|"

tmpObjs=tmpObjs& "Scripting.FileSystemObject|"

tmpObjs=tmpObjs& "adodb.connection|"

tmpObjs=tmpObjs& "SoftArtisans.FileUp|"

tmpObjs=tmpObjs& "SoftArtisans.FileManager|"

tmpObjs=tmpObjs& "CDONTS.NewMail|"

tmpObjs=tmpObjs& "Persits.MailSender|"

tmpObjs=tmpObjs& "LyfUpload.UploadFile|"

tmpObjs=tmpObjs& "Persits.Upload.1|"

tmpObjs=tmpObjs& "w3.upload|"

tmpObjs=Split(tmpObjs,"|")

Response.write "<center><table border='1' bordercolor='#000000' cellspacing='0' cellpadding='0' style='font-size: 9pt;"">宋体'><tr><td width='33%' valign='middle' align='center' style='border-left: 1 solid #808080; border-right: 1 solid #FFFFFF; border-top: 1 solid #FFFFFF; border-bottom: 1 solid #808080; padding-left: 2; padding-right: 2; padding-top: 1; padding-bottom: 1'>组件标识</td><td width='33%' valign='middle' align='center' style='border-left: 1 solid #808080; border-right: 1 solid #FFFFFF; border-top: 1 solid #FFFFFF; border-bottom: 1 solid #808080; padding-left: 2; padding-right: 2; padding-top: 1; padding-bottom: 1'>√|×</td><td width='34%' valign='middle' align='center' style='border-left: 1 solid #808080; border-right: 1 solid #FFFFFF; border-top: 1 solid #FFFFFF; border-bottom: 1 solid #808080; padding-left: 2; padding-right: 2; padding-top: 1; padding-bottom: 1'>版本</td></tr>" & vbCrlf

For i = LBound(tmpObjs) To UBound(tmpObjs)

If Trim(tmpObjs(i))<>"" Then

If IsObjInstalled(tmpObjs(i)) Then

TempObjType=tmpObjs(i)

TempBs="√"

TempBsXX=GetObjVer(tmpObjs(i))

If TempBsXX="" Then TempBsXX=" "

Else

TempObjType="<font color='#800000'>"&tmpObjs(i)&"</font>"

TempBs="<font color='#800000'>×</font>"

TempBsXX=" "

End If

Response.write "<tr>" & vbCrlf

Response.write "<td valign='middle' style='border-left: 1 solid #808080; border-right: 1 solid #FFFFFF; border-top: 1 solid #FFFFFF; border-bottom: 1 solid #808080; padding-left: 2; padding-right: 2; padding-top: 1; padding-bottom: 1'>"&TempObjType&"</td>" & vbCrlf

Response.write "<td valign='middle' align='center' style='border-left: 1 solid #808080; border-right: 1 solid #FFFFFF; border-top: 1 solid #FFFFFF; border-bottom: 1 solid #808080; padding-left: 2; padding-right: 2; padding-top: 1; padding-bottom: 1'>"&TempBs&"</td>" & vbCrlf

Response.write "</tr>" & vbCrlf

End If

Response.write "</table></center>" & vbCrlf

End Function

'**************************************************

'函数ID：0024[上传文件的窗口]

'函数名：PosImageWin

'作用：上传选择文件窗口，可自动提取文件名及类型

'参数：PfUrlstr ---- 处理二进制文件信息的URL地址

'返回值：网页HTML文件

'示例：库结构例子 CREATE TABLE [IMAGES] ([ID] int IDENTITY (1,1) NOT NULL PRIMARY KEY,[MC] varchar(50),[LX] varchar(20),[MEM] Text,[IMGS] image)

'**************************************************

Public Function PosImageWin(ByVal PfUrlstr)

PosImageWin=""

PosImageWin=PosImageWin & "<center><table border='0' width='0' cellspacing='0' cellpadding='0' style='font-size: 9pt'>" & vbCrlf

PosImageWin=PosImageWin & "<SCRIPT LANGUAGE=javascript>"&vbCrlf

PosImageWin=PosImageWin & "function ckfilelx(){"&vbCrlf

PosImageWin=PosImageWin & "tempwjm=POFile.ImageFs.value;"&vbCrlf

PosImageWin=PosImageWin & "fgwjm=tempwjm.split('.');"&vbCrlf

PosImageWin=PosImageWin & "newwjm=fgwjm.reverse();"&vbCrlf

PosImageWin=PosImageWin & "POMem.ImageType.value=newwjm[0].toUpperCase();"&vbCrlf

PosImageWin=PosImageWin & "tempwjm=newwjm[1].toUpperCase();"&vbCrlf

PosImageWin=PosImageWin & "fgwjm=tempwjm.split('\');"&vbCrlf

PosImageWin=PosImageWin & "newwjm=fgwjm.reverse();"&vbCrlf

PosImageWin=PosImageWin & "POMem.ImageName.value=newwjm[0].toUpperCase();"&vbCrlf

PosImageWin=PosImageWin & "POMem.ImageReadme.value=newwjm[0].toUpperCase();"&vbCrlf

PosImageWin=PosImageWin & "}"&vbCrlf

PosImageWin=PosImageWin & "function Reedit(){POFile.reset();POMem.reset();}"&vbCrlf

PosImageWin=PosImageWin & "function PostDo(){if (POFile.ImageFs.value==''){alert('没有选择文件哟！');}else{bc.innerHTML='正在上传，请稍后...';POFile.action=POFile.action+'&mc='+POMem.ImageName.value+'&lx='+POMem.ImageType.value+'&mem='+POMem.ImageReadme.value;bc.style.visibility='visible';ReEd.disabled=true;PoSe.disabled=true;POFile.submit();POFile.ImageFs.disabled=true;}}"&vbCrlf

PosImageWin=PosImageWin & "</SCRIPT>"&vbCrlf

PosImageWin=PosImageWin & "<tr><form method='POST' name='POFile' enctype='multipart/form-data' ACTION='"&PfUrlstr&"' target='tempa'><td width='100%' valign='middle'>" & vbCrlf

PosImageWin=PosImageWin & "选择文件：<input type='file' name='ImageFs' ONCHANGE='ckfilelx();' style='font-size: 9pt;width:300;'>" & vbCrlf

PosImageWin=PosImageWin & "</td></form></tr>" & vbCrlf

PosImageWin=PosImageWin & "<tr><form method='POST' name='POMem'><td width='100%' valign='middle'>" & vbCrlf

PosImageWin=PosImageWin & "文件ID号：<input type='text' name='ImageID' ReadOnly style='font-size: 9pt;width:300;'><br>" & vbCrlf

PosImageWin=PosImageWin & "文件名称：<input type='text' name='ImageName' style='font-size: 9pt;width:300;'><br>" & vbCrlf

PosImageWin=PosImageWin & "文件类型：<input type='text' name='ImageType' ReadOnly style='font-size: 9pt;width:300;'><br>" & vbCrlf

PosImageWin=PosImageWin & "文件介绍：<textarea rows='8' name='ImageReadme' cols='20' style='font-size: 9pt;width:300;'>还没有</textarea>" & vbCrlf

PosImageWin=PosImageWin & "</td></form></tr>" & vbCrlf

PosImageWin=PosImageWin & "<tr><td width='100%' valign='middle' align='center'>" & vbCrlf

PosImageWin=PosImageWin & "<input type='button' value='重置' name='ReEd' OnClick='Reedit();'> <input type='button' value='上传' name='PoSe' OnClick='PostDo();'>" & vbCrlf

PosImageWin=PosImageWin & "</td></tr></table></center><div id='bc' name='bc' style='position: absolute; left: 45%; top:40%; z-index: 0;background-color: #EAEAEA;visibility: hidden;' valign='middle' align='center'></div>" & vbCrlf

PosImageWin=PosImageWin & "<iframe src='' ID='tempa' NAME='tempa' frameborder='0' width='0' height='0' style='width:0;Height:0;'>" & vbCrlf

End Function

'**************************************************

'函数ID：0025[取得数据库链接字串]

'函数名：GetConnStr

'作用：取得数据库链接字串，能生成MsAccess和MsSqlServer链接串

'参数：Lx ---- 0 是MsAccess , 1 是MsSqlServer

'参数：Dbiporpath ---- 数据库IP或路径

'参数：Dbmc ---- 数据库名称

'参数：Dbuid ---- 数据库用户名称

'参数：Dbupwd ---- 数据库用户密码

'返回值：链接字串

'示例：http://www.knowsky.com/

'**************************************************

Public Function GetConnStr(ByVal Lx,ByVal Dbiporpath,ByVal Dbmc,ByVal Dbuid,ByVal Dbupwd)

GetConnStr=""

If Lx=0 Then

If Right(Dbiporpath,1)<>"" Then Dbiporpath=Dbiporpath & ""

GetConnStr ="Provider=Microsoft.Jet.OLEDB.4.0;Data Source="&Dbiporpath&Dbmc&";Jet OLEDB:Database Password="&Dbupwd&";"

End If

If Lx=1 Then

GetConnStr ="DRIVER=SQL Server;UID="&Dbuid&";DATABASE="&Dbmc&";SERVER="&Dbiporpath&";PWD="&Dbupwd&";"

End If

End Function

'**************************************************

'函数ID：0026[取得multipart/form-data形式上传文件]

'函数名：GetImageData

'作用：取得multipart/form-data形式上传文件

'参数：MaxSize ---- 上传的限止大小,单位：M(兆)

'返回值：二进制数据

'示例：

'**************************************************

Public Function GetImageData(ByVal MaxSize)

GetImageData=""

DIM formsize,Formdata,bncrlf,divider,datastart,dataend,mydata

formsize=Request.TotalBytes

if (formsize<=(MaxSize*1024*1024)) then

Formdata=Request.BinaryRead(formsize)

Pos_ts=LenB(getByteString(Chr(13) & Chr(10) & Chr(13) & Chr(10)))

Pos_b=InstrB(Formdata,getByteString(Chr(13) & Chr(10) & Chr(13) & Chr(10)))+Pos_ts

nFormdata=MidB(Formdata,Pos_b)

Pos_ts=InstrB(nFormdata,getByteString(Chr(13) & Chr(10) & "--"))

nnFormdata=MidB(nFormdata,Pos_ts)

Pos_e=LenB(Formdata)-LenB(nnFormdata)-Pos_b+1

datastart =Pos_b

dataend=Pos_e

mydata=midb(Formdata,datastart,dataend)

End If

GetImageData=mydata

End Function

'''' 将字串转为二进制串

Function getByteString(StringStr)

For i=1 to Len(StringStr)

char=Mid(StringStr,i,1)

getByteString=getByteString & chrB(AscB(char))

End function

'**************************************************

'函数ID：0027[保存或查看上传到数据库中的数据，带调用上传窗口]

'函数名：GoImgToDb

'作用：保存或查看上传到数据库中的数据，带调用上传窗口

'参数：PPLX ---- 执行类型(空为保存，ID号为查看该ID的文件)

'参数：PUrl ---- 主执行程序的URL部份

'参数：ConnStr ---- 上传文件的数据库链接字串

'参数：ImagTbname ---- 文件保存的数据表名称

'参数：Did ---- 文件ID字段名

'参数：Dmc ---- 文件名称字段名

'参数：Dlx ---- 文件类型字段名

'参数：Dmem ---- 文件说明字段名

'参数：Ddata ---- 文件的二进制数据的字段名

'参数：MaxSize ---- 上传的限止大小,单位：M(兆)

'参数：IDLX ---- 标识ID字段的类型 ( 0 字符型 1 数值(非自增量型) 2 数值型(自增量型) )

'返回值：成功保存的JAVASCRIPT 注在非自动增量情况下标识字段长度应超过20个字符

'示例：GoImgToDb("17","http://127.0.0.1/function.asp",GetConnStr(1,"127.0.0.1","temp","sa","mzy1029"),"img","id","mc","lx","mem","data",20)

'示例：GoImgToDb("","http://127.0.0.1/function.asp",GetConnStr(1,"127.0.0.1","temp","sa","mzy1029"),"img","id","mc","lx","mem","data",20)

'**************************************************

Public Function GoImgToDb(ByVal PPLX,ByVal PUrl,ByVal ConnStr,ByVal ImagTbname,ByVal Did,ByVal Dmc,ByVal Dlx,ByVal Dmem,ByVal Ddata,ByVal MaxSize,ByVal IDLX)

DIM Pjobs,Pjurl

tempimg_conn_str=ConnStr

Set fu_Conn=server.createobject("ADODB.Connection")

Set fu_Rs=server.createobject("ADODB.Recordset")

fu_Conn.open tempimg_conn_str

If JCID(PPLX)=0 Then

Pjobs=Request("img")

If InStr(PUrl,"?")>0 Then

Pjurl=PUrl&"&img=sav"

Else

Pjurl=PUrl&"?img=sav"

End If

If Pjobs="" then Response.write PosImageWin(Pjurl)

If Pjobs="sav" Then

Sql_Str="SELECT "&Did&","&Dmc&","&Dlx&","&Dmem&","&Ddata&" FROM "&ImagTbname

fu_Rs.open Sql_Str,fu_Conn,3,3

fu_Rs.addnew

If IDLX < 2 Then

fu_Rs(Did) =MakeTheID()

End If

fu_Rs(Dmc) =Request("mc")

fu_Rs(Dlx) =Request("lx")

fu_Rs(Dmem) =Request("mem")

fu_Rs(Ddata).AppendChunk GetImageData(JCID(MaxSize))

fu_Rs.update

fu_Rs.Close

fu_Rs.open Sql_Str,fu_Conn,3,3

fu_Rs.MoveLast

Response.write "<SCRIPT LANGUAGE=JAVASCRIPT>"&vbCrlf

Response.write "parent.POMem.ImageID.value='"&fu_Rs(Did)&"';"&vbCrlf

Response.write "parent.bc.innerHTML='已成功保存数据!';"

Response.write "</SCRIPT>"&vbCrlf

End If

Else

If IDLX > 0 Then

Sql_Str="SELECT "&Did&","&Dmc&","&Dlx&","&Dmem&","&Ddata&" FROM "&ImagTbname&" WHERE ("&Did&" ="&PPLX&")"

Else

Sql_Str="SELECT "&Did&","&Dmc&","&Dlx&","&Dmem&","&Ddata&" FROM "&ImagTbname&" WHERE ("&Did&" ='"&PPLX&"')"

End If

fu_Rs.open Sql_Str,fu_Conn,1,1

If fu_Rs.RecordCount >0 Then

tempaa=Trim(fu_Rs(Dlx))

Response.Clear

Response.Expires = -9999

Response.AddHeader "pragma", "no-cache"

Response.AddHeader "cache-ctrol", "no-cache"

Response.Buffer = TRUE

Response.AddHeader "Content-Disposition:","attachment;filename="&fu_Rs(Dmc)&"."&tempaa

Response.ContentType="application/"&Trim(fu_Rs(Dlx))

Response.Flush

Response.BinaryWrite fu_Rs(Ddata)

Response.End

End If

fu_Rs.Close

fu_Conn.close

Set fu_Rs = Nothing

Set fu_Conn = Nothing

End Function

'**************************************************''''

'函数ID：0028[取得图像的类型|宽|高]

'函数名：GetImageDx

'作用：取得图像的类型|宽|高

'参数：filepath ---- 文件路径及文件命名

'返回值："类型|宽|高"

'**************************************************''''

Public Function GetImageDx(ByVal filepath)

DIM Tempsm,NBxx,WJXX(3)

SET Tempsm = Server.CreateObject("ADODB.Stream")

Tempsm.Mode=3

Tempsm.Type=1

Tempsm.Open

Tempsm.LoadFromFile filepath

NBxx=Hex(BinVal(Tempsm.Read(3)))

WJXX(0)=NBxx

WJXX(1)="0"

WJXX(2)="0"

If NBxx="464947" Then

WJXX(0)="GIF"

Tempsm.Read(3)

WJXX(1)=BinVal(Tempsm.Read(2))

WJXX(2)=BinVal(Tempsm.Read(2))

End If

If NBxx="FFD8FF" Then

WJXX(0)="JPG"

do: p1=binVal(Tempsm.Read(1)): loop while p1=255 and not Tempsm.EOS

if p1>191 and p1<196 then exit do else Tempsm.Read(binval2(Tempsm.Read(2))-2)

do:p1=binVal(Tempsm.Read(1)):loop while p1<255 and not Tempsm.EOS

loop while true

Tempsm.Read(3)

WJXX(2)=binval2(Tempsm.Read(2))

WJXX(1)=binval2(Tempsm.Read(2))

End If

If Mid(NBxx,3)="4D42" Then

Tempsm.Read(15)

WJXX(0)="BMP"

WJXX(1)=binval(Tempsm.Read(4))

WJXX(2)=binval(Tempsm.Read(4))

End If

If NBxx="4E5089" Then

WJXX(0)="PNG"

Tempsm.Read(15)

WJXX(1)=BinVal2(Tempsm.Read(2))

Tempsm.Read(2)

WJXX(2)=BinVal2(Tempsm.Read(2))

End If

If NBxx="535743" Then

WJXX(0)="SWF"

Tempsm.Read(5)

binData=Tempsm.Read(1)

sConv=Num2Str(ascb(binData),2 ,8)

nBits=Str2Num(left(sConv,5),2)

sConv=mid(sConv,6)

while(len(sConv)<nBits*4)

binData=Tempsm.Read(1)

sConv=sConv&Num2Str(ascb(binData),2 ,8)

wend

WJXX(1)=int(abs(Str2Num(mid(sConv,1*nBits+1,nBits),2)-Str2Num(mid(sConv,0*nBits+1,nBits),2))/20)

WJXX(2)=int(abs(Str2Num(mid(sConv,3*nBits+1,nBits),2)-Str2Num(mid(sConv,2*nBits+1,nBits),2))/20)

End If

Tempsm.Close

SET Tempsm=nothing

GetImageDx = WJXX(0)&"|"&WJXX(1)&"|"&WJXX(2)

End Function

Function BinVal(bin)

dim ret

ret = 0

for i = lenb(bin) to 1 step -1

ret = ret *256 + ascb(midb(bin,i,1))

BinVal=ret

End Function

Function BinVal2(bin)

dim ret

ret = 0

for i = 1 to lenb(bin)

ret = ret *256 + ascb(midb(bin,i,1))

BinVal2=ret

End Function

Function Str2Num(str,base)

dim ret

ret = 0

for i=1 to len(str)

ret = ret *base + cint(mid(str,i,1))

Str2Num=ret

End Function

Function Num2Str(num,base,lens)

dim ret

ret = ""

while(num>=base)

ret = (num mod base) & ret

num = (num - num mod base)/base

wend

Num2Str = right(string(lens,"0") & num & ret,lens)

End Function

（3）将资料中的单引号改成两个单引号，并且在前后加上单引号

Function SqlStr( data )

SqlStr = "'" & Replace( data,"'", "''" ) & "'"

End Function

'写入数据库

sql = "Insert Into 内容表 (看板id,主题id,作者id,标题,内容)Values( "

sql = sql & SqlStr(topicid) & ","

sql = sql & SqlStr(boardid) & ","

sql = sql & SqlStr(author) & ","

sql = sql & SqlStr(title) & ","

sql = sql & SqlStr(content) & ")"

conn.Execute sql

%＞

＜ h2＞文章已经被发送到数据库，当板主审阅后就可以看到了＜h2＞

＜ /body＞

＜ /html＞

　　到这儿，文章已经被保存在数据库中了。但是，它并不能够立刻被显示出来，还需要版主的认可才行。下面，就来看看论坛的管理部分的内容。

　　4、论坛的管理部分

　　这儿是我们这个论坛的核心之所在，但它实现起来也没有什么特别的地方。还是那些老东西：窗体处理，数据库查询，在用ASP把他们有机的结合起来。当进入了文章审阅模式（前面提到的板务处理）之后，最为首要的内容，应该是对版主的身份进行验证了。下面来看看版主登陆页面：

＜ %

boardid=request("boardid")

（注：boardid是由进入这个页面的连接所传递过来的，是要进行板务处理的看板的ID。通过它才能知道处理的是那个板的板务。）

Set conn = erver.CreateObject("ADODB.Connection")

conn.Open "driver={Microsoft AccessDriver (*.mdb)};dbq=" & Server.MapPath("bbssystem.mdb")

Set cmd = Server.CreateObject("ADODB.Command")

Set cmd.ActiveConnection = conn

cmd.CommandText = "板主密码查询"

ReDim param(0)

param(0) = CLng(boardid) //注：CLng 不可忽略

Set rs = cmd.Execute( ,param )

boardmanager=rs("板主")

set cmd=nothing

%＞

＜ html＞

＜ head＞

＜ title＞Untitled Document＜ /title＞

＜ meta http-equiv="Content-Type"content="text/html; charset=GB2312"＞

＜ /head＞

＜ body bgcolor="#FFFFFF"＞

＜ p＞只有板主＜ %=boardmanager%＞才能够进入这个地方＜/p＞

＜ p＞请输入验证密码, 并且为了保持身份验证，请打开浏览器的Cookies。＜/p＞

＜ form method="post" action="managerloginrest.asp"＞

＜ input type="password" name="password"＞

＜ input type="hidden" name="boardid"value=＜ %=boardid%＞＞

＜ input type="submit" name="Submit"value="确定"＞

＜ /form＞

　　注：这个页面仅仅是用来登陆用的，它得到斑竹输入的密码后，并不能进行验证，而是将验证的工作放到下一个页面中进行。实际上，密码输入和验证的工作是可以放在一个页面中完成的，只不过程序代码的结构安排上有点麻烦。

＜ /body＞

＜ /html＞

＜ %

set rs=nothing

conn.close

set conn=nothing

%＞

　　现在得到了版主ID和输入的密码，下面就是进行验证的工作managerloginrest.asp了，它接受上面那个文件中窗体的内容，并进行相关处理：

＜ %

response.buffer=true

　　注：把缓冲区设置为允许使用。这一条一般来说，是应该加在每个ASP页面的首部的，这样能够提高ASP页面的性能。在打开了缓冲区后，ASP中还有一些相应的特殊用法，在后面会提及。

boardid=request("boardid")

password=request("password")

Set conn = Server.CreateObject("ADODB.Connection")

conn.Open "driver={Microsoft AccessDriver (*.mdb)};dbq=" & Server.MapPath("bbssystem.mdb")

Set cmd = Server.CreateObject("ADODB.Command")

Set cmd.ActiveConnection = conn

cmd.CommandText = "板主密码查询"

ReDim param(0) ' 声明

param(0) = CLng(boardid)//注：CLng不可忽略

Set rs = cmd.Execute( ,param )

boardmanager=rs("板主")

if password＜＞ rs("密码")then %＞

＜ html＞

＜ head＞

＜ title＞身份验证＜ /title＞

＜ meta http-equiv="Content-Type"content="text/html; charset=GB2312"＞

＜ /head＞

＜ body bgcolor="#FFFFFF"＞

密码错误

＜ /body＞

＜ /html＞

＜ %

else

session("beenthere")=boarded

　　注：使用Session来保持对版主的身份验证，这必须要求客户端浏览器的cookie被打开了。因为Session是通过cookie来实现的。在这儿，把看板ID赋给Session变量beenthere，表明版主主已经通过了身份验证。在后面的每个版务处理的页面中，都要检查beenthere是否和相应的看版ID相符。

url="boardmanager.asp?boardid="& boardid

response.redirect url

　　补充：初学ASP的时候总是为response.redirect这个方法感到困惑，屡用不爽，现在我来告诉你一些技巧。使用它之前，必须通过response.buffer=true来让ASP页面使用缓冲区。这时，在ASP被解释成HTML程序代码之前，它是放在缓冲区中的，而不直接被发送的客户端浏览器。还有一个必须要知道的是：在使用response.redirect之前，是不能有任何实际的HTML程序代码被发送到客户端浏览器的，否则就会出错。当然也有变通的方法，如果在response.redirect之前已经有HTML程序代码被解释出来，可以用response.clear方法来清除缓冲区，然后就可以使用它来进行复位向了。

end if

%＞

　　注：下面就是在上面身份验证通过后复位向的目标：boardmanager.asp。它将列出了所有别有被处理的文章。

＜ %

boardid=request("boardid")

if session("beenthere")＜＞boardidthen response.redirect "forums.asp"

　　注：这就是检验版主身份的地方，因为前面已经通过cookie在斑竹的浏览器中作了标记，现在我们就能够通过seesion来辨认版主的身份了。如果标示不符，就会通过response.redirect返回到最开始的登陆页面。如果版主浏览器的cookie没有打开，那么seesion（"beenthere"）的值会为空，同样也无法进入这个页面。

Set conn = Server.CreateObject("ADODB.Connection")

conn.Open "driver={Microsoft AccessDriver (*.mdb)};dbq=" & Server.MapPath("bbssystem.mdb")

Set cmd = Server.CreateObject("ADODB.Command")

Set cmd.ActiveConnection = conn

sql="select 名称 from 看板列表 whereid=" & boardid

set rs=conn.execute(sql)

boardname=rs("名称")

cmd.commandtext="未发表文章列表"

ReDim param(0)

param(0) = CLng(boardid)//注：Clng 不可忽略

Set rs = cmd.Execute( ,param )

set cmd=nothing

%＞

＜ html＞

＜ head＞

＜ title＞版务处理＜ /title＞

＜ meta http-equiv="Content-Type"content="text/html; charset=GB2312"＞

＜ /head＞

＜ body bgcolor="#FFFFFF"＞

＜ h1 align="center"＞＜%=boardname%＞版务管理＜ /h1＞

＜ hr＞

＜ %

if rs.eof or rs.bof then response.write "＜H2＞现在没有文章要处理＜ /h2＞"

response.end

%＞

注：如果没有新文章被网友发布，这给出相应的提示，并用response.end来结束此页的显示。

＜ table width="90%" border="0"cellspacing="0" cellpadding="0"align="center" ＞

＜ tr bgcolor="#FFFFCC"＞

＜ td width="40%" height="20"＞主题＜/td＞

＜ td width="40%" height="20"＞文章标题＜/td＞

＜ td width="8%" height="20"＞作者＜/td＞

＜ td width="12%" height="20"＞日期＜/td＞

＜ /tr＞

＜ %

topicid=rs("主题id")

articleid=rs("文章id")

data=rs("日期")

datastr=cstr(year(data)) & "-"& cstr(month(data)) &"-"& cstr(day(data))

author=rs("作者")

articlename=rs("标题")

topicname=rs("主题")

response.write "＜ tr＞＜ td＞＜a href=qtopic.asp?topicid="& topicid& "＞" & topicname &"＜ /A＞＜ /td＞"

response.write "＜ td＞＜ a href=managearticle.asp?articleid="&articleid & "&boardid="& boardid &"＞" &articlename & "＜ /A＞＜ /td＞"

response.write "＜ td＞＜ a href=qauthor.asp?author="&author & "＞" & author& "＜ /a＞＜ /td＞"

response.write "＜ td＞" &datastr & "＜ /td＞＜ /tr＞"

rs.movenext

loop until rs.eof

%＞

＜ /table＞

＜ /html＞

＜ %

set rs=nothing

conn.close

set conn=nothing

%＞

＜ /body＞

当点击了相应文章的联结后，就进入此文章的处理页面managearticle.asp：

＜ %

articleid=request("articleid")

boardid=request("boardid")

if session("beenthere")＜＞boardidthen response.redirect "forums.asp"

Set conn = Server.CreateObject("ADODB.Connection")

conn.Open "driver={Microsoft AccessDriver (*.mdb)};dbq=" & Server.MapPath("bbssystem.mdb")

Set cmd = Server.CreateObject("ADODB.Command")

Set cmd.ActiveConnection = conn

cmd.CommandText = "按id查询文章"

ReDim param(0)

param(0) = CLng(articleid)//注：Clng 不可忽略

Set rs = cmd.Execute( ,param )

author=rs("作者id")

title=rs("标题")

data=rs("日期")

rate=rs("推荐度")

boardid=rs("看板id")

topicid=rs("主题id")

boardname=rs("看板名")

topicname=rs("主题名")

content=rs("内容")

content=replace(content,vbCrlf,"＜/p＞＜ p＞")

content="＜ p＞" & content& "＜ /p＞"

set cmd=nothing

%＞

＜ html＞

＜ head＞

＜ title＞Untitled Document＜ /title＞

＜ meta http-equiv="Content-Type"content="text/html; charset=GB2312"＞

＜ /head＞

＜ body bgcolor="#E9E9E4"＞

＜ table width="89%" border="0"cellspacing="0" cellpadding="0"align="center"＞

＜ tr bgcolor="#CCCCCC"＞

＜ td＞作者：＜ font color="#FF3366"＞＜a href="qauthor.asp?author=＜ %=author%＞"＞＜ %=author%＞＜ /a＞＜ /font＞发表日期：＜ font color="#FF3333"＞＜%=data%＞＜ /font＞

看板：＜ font color="#FF3333"＞＜a href="qboard.asp?boardid=＜ %=boardid%＞"＞＜ %=boardname%＞＜ /a＞＜ /font＞板主推荐：＜ font color="#FF3333"＞#rate#＜/font＞＜ /td＞

＜ /tr＞

＜ tr bgcolor="#CCCCCC"＞

＜ td＞标题：＜ font color="#FF3333"＞＜%=title%＞

主题：＜ a href="qtopic.asp?topicid=＜%=topicid%＞"＞＜ %=topicname%＞＜ /a＞＜ /font＞＜ /td＞

＜ /tr＞

＜ tr valign="top"＞

＜ td＞

＜ hr＞

＜ font color="#FF3366"＞文章内容：＜ /font＞＜ br＞

＜ br＞

＜ font color=blue＞＜ %response.writecontent%＞＜ /font＞

＜ br＞

＜ hr＞

＜ /td＞

＜ /tr＞

＜ tr valign="top"＞

＜ form method="post" action="manageresult.asp"＞

＜ td height="18"＞

＜ table width="100%" border="1"cellspacing="1" cellpadding="1"＞

＜ tr＞

＜ td width="29%"＞

＜ div align="right"＞

＜ input type="hidden" name="boardid"value="＜ %=boardid%＞"＞

＜ input type="hidden" name="topicid"value="＜ %=topicid%＞"＞

＜ input type="hidden" name="articleid"value="＜ %=articleid%＞"＞

文章处理：＜ /div＞

＜ /td＞

＜ td width="12%" bordercolor="#006666"＞删除:

＜ input type="radio" name="manage"value=1＞

＜ /td＞

＜ td width="30%" bordercolor="#006666"＞发表:

＜ input type="radio" name="manage"value=2＞

推荐等级

＜ select name="select"＞

＜ option value="1"＞1＜/option＞

＜ option value="2"＞2＜/option＞

＜ option value="3" selected＞3＜/option＞

＜ option value="4"＞4＜/option＞

＜ option value="5"＞5＜/option＞

＜ /select＞

＜ /td＞

＜ td width="20%" bordercolor="#006666"＞以后再处理:

＜ input type="radio" name="manage"value=3＞

＜ /td＞

＜ td width="9%"＞

＜ input type="submit" name="Submit"value="确定"＞

＜ /td＞

＜ /tr＞

＜ /table＞

＜ /td＞

＜ /form＞

＜ /tr＞

＜ /table＞

＜ /body＞

＜ /html＞

＜ %

set rs=nothing

conn.close

set conn=nothing

%＞

　　注：这一页和文章显示模块中的article.asp基本上是一样的，仅仅是多加入了版主处理的窗体，在这儿就不多讲了。

　　下面，要根据版主的处理过程，修该数据库相应部分

＜ %response.buffer=true%＞

＜ html＞

＜ head＞

＜ title＞文章处理＜ /title＞

＜ meta http-equiv="Content-Type"content="text/html; charset=GB2312"＞

＜ /head＞

＜ body bgcolor="#E9E9E4"＞

＜ %

articleid=request("articleid")

boardid=request("boardid")

topicid=request("topicid")

manage=request("manage")

'接受窗体内容

response.write manage '显示斑竹ID

if session("beenthere")＜＞boardidthen response.redirect "forums.asp"

Set conn = Server.CreateObject("ADODB.Connection")

conn.Open "driver={Microsoft AccessDriver (*.mdb)};dbq=" & Server.MapPath("bbssystem.mdb")

根据上页中版主的操作，下面进行相应的处理。

if CLng(request("manage"))=1 then

sql="delete from 内容表 where id="& articleid

conn.execute sql

response.write "＜ h1＞文章已经被删除＜/h1＞"

response.write "＜ a href=＞back＜/a＞"

elseif CLng(request("manage"))=2then

sql="update 内容表 set 发表=true whereid=" & articleid

conn.execute sql

sql="update 主题表 set 文章数=文章数+1where id=" & topicid

conn.execute sql

response.write "＜ h1＞文章已经发表＜/h1＞"

response.write "＜ a href=＞back＜/a＞"

else

response.clear

response.redirect "boardmanager.asp?boardid="& boarded

end if

%＞

＜ /body＞

＜ /html＞

＜ %

conn.close

set conn=nothing

%＞

　　经过上面几步，所有的部分就算是基本完成了，当然，这时还不能拿来用，摆不上台面的。如果想要能够拿得出来的话，还要在版面设计，客户端资料验证等方面多下一些功夫。不过那都是HTML的内容了，和ASP没多大的关系，这儿我就不多讲了。

asp制作中常用到的函数库集合

相关文章

精彩推荐