asp制作中常用到的函数库集合第4/8页

'************************************************** 
  '函数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 

最新评论