ASP基础

关注公众号 jb51net

关闭
首页 > 网络编程 > ASP编程 > ASP基础 >

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

作者:

asp制作中常用到的函数库集合
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 
   Next 
   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 
   Next 
   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 
   End If 
   Next 
   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 
   Next 
   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 & "|" 
   Next 
   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 & "|" 
   Next 
   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,"") 
   objReg.Pattern="(function|meta|value|window\.|script|js:|about:|file:|Document\.|vbs:|frame|cookie)" 
   strContent=objReg.Replace(strContent,"") 
   objReg.Pattern="(on(finish|mouse|Exit=|error|click|key|load|focus|Blur))" 
   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","mzymcm@yahoo.com.cn","test","mzymcm@163.com","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 "<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'>"&TempBsXX&"</td>" & vbCrlf 
   Response.write "</tr>" & vbCrlf 
   End If 
   Next 
   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)) 
   Next 
  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 
   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 
   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)) 
   next 
   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)) 
   next 
   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)) 
   next 
   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> 
  < % 
  do 
  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没多大的关系,这儿我就不多讲了。
阅读全文