HOME
BBS
深山帮帮欢迎您,您可以注册或者
qq登录只需一步,快速开始
深山旅行社网站管理系统开发完成,欢迎各位网友测试! 点这里测试
565449214 给站长留言
订阅本栏目 RSS您所在的位置: 深山工作室 > ASP学习 > 正文

asp在线把整站打包成为.mdb形式文件

深山行者个人网站 2009-8-17 9:14:52 深山行者 字体:  浏览 1822 我要评论

<%
Function IsInteger(Para)
 IsInteger=False
 If Not (IsNull(Para) Or Trim(Para)="" Or Not IsNumeric(Para)) Then
  IsInteger=True
 End If
End Function

%>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312">
<title>asp在线把整站打包成为.mdb形式文件</title>
<style type="text/css">
<!--
body{font-family: "宋体","Times New Roman", Times, serif; font-size:12px; text-align:center;}
td,select{font-size:12px;}
.table{border-left:1px #999999 solid;}
.trtrb{border-top:1px #999999 solid;border-right:1px #999999 solid; border-bottom:1px #999999 solid;}
.trtr{border-top:1px #999999 solid;border-right:1px #999999 solid;}
.tx{font-family: "宋体";font-size:12px;border:1px solid;border-color:black black #000000;color: #0000FF;}
.button{border:1px #666666 solid; background-color:#FFFFFF; height:18px;}
-->
</style>
</head>
<body leftmargin="0">
<%
dim act,thePath
act=lcase(trim(request("action")))
if act="combine" then
   '用ASP将文件分割器分割的文件合并
   dim fname,f,newname
   newname=request("newname")
   set f=request("f")
   for i=1 to f.count
 if f(i)<>"" then
  fname=fname&"|"&f(i)
 end if
   next
   if newname="" then
 call back("新文件名不能为空!")
   end if
   if fname="" then
 call back("需合并文件名不能全为空!")
   end if
   call combine(fname,newname)
elseif act="addtomdb" or act="releasefrommdb" then
 thePath = Request("thePath")
 Script_TimeOut = trim(request("timeout"))
 if IsInteger(Script_TimeOut) then
  Script_TimeOut = round(Script_TimeOut*60,0)
 else
  Script_TimeOut = 3600
 end if
 Server.ScriptTimeOut = Script_TimeOut
 if act="addtomdb" then
  addToMdb(thePath)
  response.write "<script language=javascript>alert('操作完成!');window.close();</script>"
 elseif act="releasefrommdb" then
  unPack(thePath)
  response.write "<script language=javascript>alert('操作完成!');window.close();</script>"
 end if
end if
%>


<table width="542" border="0" cellspacing="0" cellpadding="0" align="center" class="table">
    <tr bgcolor="#CCCCCC">
      <td class="trtr" height="22" align="center" valign="middle" bgcolor="#CCCCCC"><B>ASP文件打包/解包器 v1.0 by 秋忆</B></td>
    </tr>
 <tr><td>
<table width="542" border="0" cellspacing="0" cellpadding="0" align="center">


<form method=post target=_blank action="<%=selfname%>">
  <tr height="30">
    <td class="trtr">&nbsp;文件夹打包:</td>
    <td class="trtr">&nbsp;
 <input type="text" name="thePath" value="<%=Server.MapPath(".")%>" class="tx" style="width:300px">
 <input type="hidden" value="addToMdb" name="action">
 <select name="theMethod">
 <option value="fso">FSO</option>
 <option value="app">无FSO</option>
 </select>
 </td>
  </tr>
  <tr>
    <td class="trtr" colspan="2" height="25" align="center">
 脚本超时:<input type="text" name="timeout" value="60" class="tx" style="width:40px" />分钟  
 <input type="submit" value="开始打包" class="button">
 </td>
  </tr>
  <tr>
    <td class="trtr" colspan="2" height="30">&nbsp;注:打包生成Qiuyi.mdb文件,位于当前页面目录<%=Server.MapPath(".")%>下。</td>
  </tr>
  <tr>
    <td class="trtr" colspan="2" height="40">&nbsp;</td>
  </tr>
  </form>
 
 
</table>
</td></tr>
<tr><td>
<table width="542" border="0" cellspacing="0" cellpadding="0" align="center">
<form method=post target=_blank action="<%=selfname%>">
  <tr>
    <td class="trtr" nowrap="nowrap" height="30">&nbsp;文件夹解包(需FSO支持):</td>
    <td class="trtr" nowrap="nowrap">&nbsp;
 <input type="text" name="thePath" value="<%=Server.MapPath(".")%>\Qiuyi.mdb" class="tx" style="width:300px">
 <input type="hidden" value="releaseFromMdb" name="action">
 </td>
  </tr>
  <tr>
    <td class="trtr" colspan="2" height="25" align="center">
 脚本超时:<input type="text" name="timeout" value="60" class="tx" style="width:40px" />分钟  
 <input type="submit" value="开始解包" class="button">
 </td>
  </tr>
  <tr>
    <td class="trtrb" colspan="2" height="30">&nbsp;注:解开的所有文件都位于当前页面目录<%=Server.MapPath(".")%>下。也可以亲自使用本系统附带的undo.vbs文件解开压缩包。</td>
  </tr>
</form>
</table>
</td></tr>
</table>
<table width="542" border="0" cellspacing="0" cellpadding="0" align="center">
<tr><td align="center">
<span style='position:relative;top:4px; text-align:center;line-height:120%;'>
<%
endtime=timer()
if endtime<starttime then
 endtime=endtime+24*3600
end if
response.Write(copyright)
%><br>Processed in <%=(endtime-starttime)*1000%> MSEL
</span>
</td></tr>
</table>
</body>
</html>
<%

sub back(str)
 response.write "<meta http-equiv=""Content-Type"" content=""text/html; charset=gb2312"">" & vbcrlf
 response.write "<script language=javascript>alert('"& str &"');history.back();</script>"
 response.end
end sub

sub combine(Filename,newname)
 on error resume next
 dim n,i,fso,dr
 newname=server.MapPath(newname)
 Filename=split(Filename,"|")
 i=ubound(Filename)
 redim fstr(i)
 
 if Err then Err.Clear
 set fso = Server.CreateObject("Scripting.FileSystemObject")
 if not Err then
  for n=1 to i
     fname(n)=server.MapPath(Filename(n))
     if not fso.FileExists(fname(n)) then
   set fso=nothing
   call back("文件“"&replace(Filename(n),"\","\\")&"”找不到!")
     end if
  next
  set fso=nothing
 else
  Err.Clear
 end if
 
 if Err then Err.Clear
 set dr=Server.CreateObject("Adodb.Stream")
 if Err then
  Err.Clear
  call back("服务器不支持Adodb.Stream,无法使用合并功能!")
 end if
 for n=1 to i
    dr.Mode=3
    dr.Type=1
    dr.Open
    dr.LoadFromFile(fname(n))
    fstr(n)=dr.read
 next
 
 dr.Mode=3
 dr.Type=1
 dr.Open
 for n=1 to i
    dr.write=fstr(n)
 next
 dr.SaveToFile newname,2
 dr.Close
 set dr=nothing
 response.write "新文件<b>"&newname&"</b>成功生成!"
 if Err then
  Err.Clear
  Response.Write("<h1>Error: </h1>" & Err.Description & "<p>")
 end if
end sub

Sub addToMdb(thePath)
 On Error Resume Next
 Dim rs, conn, stream, connStr, adoCatalog
 set rs = Server.CreateObject("Scripting.FileSystemObject")
 if not rs.FolderExists(thePath) then
  set rs = nothing
  response.Write("目录"&thePath&"不存在!")
  response.end
 end if
 set rs = nothing
 
 Set rs = Server.CreateObject("ADODB.RecordSet")
 Set stream = Server.CreateObject("ADODB.Stream")
 Set conn = Server.CreateObject("ADODB.Connection")
 Set adoCatalog = Server.CreateObject("ADOX.Catalog")
 connStr = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & Server.MapPath("Qiuyi.mdb")
 
 adoCatalog.Create connStr
 conn.Open connStr
 conn.Execute("Create Table FileData(Id int IDENTITY(0,1) PRIMARY KEY CLUSTERED, thePath VarChar, fileContent Image)")
 
 stream.Open
 stream.Type = 1
 rs.Open "FileData", conn, 3, 3
 
 If lcase(trim(Request("theMethod"))) = "fso" Then
  fsoTreeForMdb thePath, rs, stream
  Else
  saTreeForMdb thePath, rs, stream
 End If
 
 rs.Close
 Conn.Close
 stream.Close
 Set rs = Nothing
 Set conn = Nothing
 Set stream = Nothing
 Set adoCatalog = Nothing
 if Err then
  Err.Clear
  Response.Write("<h1>Error: </h1>" & Err.Description & "<p>")
 end if
End Sub

Function fsoTreeForMdb(thePath, rs, stream)
 Dim item, theFolder, folders, files, sysFileList,fsoX
 sysFileList = "$Qiuyi.mdb$Qiuyi.ldb$"
 set fsoX = Server.CreateObject("Scripting.FileSystemObject")
 If fsoX.FolderExists(thePath) = False Then
  call back(thePath & " 目录不存在或者不允许访问!")
 End If
 Set theFolder = fsoX.GetFolder(thePath)
 Set files = theFolder.Files
 Set folders = theFolder.SubFolders
 
 For Each item In folders
  fsoTreeForMdb item.Path, rs, stream
 Next
 
 For Each item In files
  If InStr(sysFileList, "$" & item.Name & "$") <= 0 Then
   rs.AddNew
   rs("thePath") = Mid(item.Path, 4)
   stream.LoadFromFile(item.Path)
   rs("fileContent") = stream.Read()
   rs.Update
  End If
 Next
 
 set fsoX = Nothing
 Set files = Nothing
 Set folders = Nothing
 Set theFolder = Nothing
End Function

Sub saTreeForMdb(thePath, rs, stream)
  on error resume next
  Dim item, theFolder, sysFileList,saX
  sysFileList = "$Qiuyi.mdb$Qiuyi.ldb$"
  Set saX = Server.CreateObject("Shell.Application")
  Set theFolder = saX.NameSpace(thePath)
  
  For Each item In theFolder.Items
   If item.IsFolder = True Then
    saTreeForMdb item.Path, rs, stream
    Else
    If InStr(sysFileList, "$" & item.Name & "$") <= 0 Then
     rs.AddNew
     rs("thePath") = Mid(item.Path, 4)
     stream.LoadFromFile(item.Path)
     rs("fileContent") = stream.Read()
     rs.Update
    End If
   End If
  Next

  Set saX = Nothing
  Set theFolder = Nothing
  if Err then
   Err.Clear
   Response.Write("<h1>Error: </h1>" & Err.Description & "<p>")
  end if
End Sub

Sub unPack(thePath)
  On Error Resume Next
  'Server.ScriptTimeOut = 5000
  Dim rs, ws, str, conn, stream, connStr, theFolder,fsoX
  set rs = Server.CreateObject("Scripting.FileSystemObject")
  if not rs.FileExists(thePath) then
   set rs = nothing
   response.Write("文件"&thePath&"不存在!")
   response.end
  end if
  set rs = nothing

  str = Server.MapPath(".") & "\"
  Set rs = CreateObject("ADODB.RecordSet")
  Set stream = CreateObject("ADODB.Stream")
  Set conn = CreateObject("ADODB.Connection")
  connStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & thePath & ";"

  conn.Open connStr
  rs.Open "FileData", conn, 1, 1
  stream.Open
  stream.Type = 1

  set fsoX = Server.CreateObject("Scripting.FileSystemObject")
  Do Until rs.Eof
   theFolder = Left(rs("thePath"), InStrRev(rs("thePath"), "\"))
   If fsoX.FolderExists(str & theFolder) = False Then
    createFolder(str & theFolder)
   End If
   stream.SetEos()
   stream.Write rs("fileContent")
   stream.SaveToFile str & rs("thePath"), 2
   rs.MoveNext
  Loop

  rs.Close
  conn.Close
  stream.Close
  set fsoX = Nothing
  Set ws = Nothing
  Set rs = Nothing
  Set stream = Nothing
  Set conn = Nothing
  if Err then
   Err.Clear
   Response.Write("<h1>Error: </h1>" & Err.Description & "<p>")
  end if
End Sub

Sub createFolder(thePath)
  on error resume next
  Dim i,fsoX
  i = Instr(thePath, "\")
  set fsoX = Server.CreateObject("Scripting.FileSystemObject")
  Do While i > 0
   If fsoX.FolderExists(Left(thePath, i)) = False Then
    fsoX.CreateFolder(Left(thePath, i - 1))
   End If
   If InStr(Mid(thePath, i + 1), "\") Then
    i = i + Instr(Mid(thePath, i + 1), "\")
    Else
    i = 0
   End If
  Loop
  set fsoX = Nothing
  if Err then
   Err.Clear
   Response.Write("<h1>Error: </h1>" & Err.Description & "<p>")
  end if
End Sub
%>

Ads loading...
相关阅读
( 2018-3-20 15:13:15 )asp利用sina提供的ip库端口来获得当前IP所有的地区,所在国,所在省,所在市,在线解析json
( 2015-10-22 17:42:13 )深山旅行社网站管理系统5.0发布
( 2014-9-20 22:17:36 )用于深山在线投票的一个javascript统计checkbox现在选中的个数一边点复选框一边验证并计算现在选了多少个复选框
( 2014-5-20 14:31:43 )asp防止多个后台用户同时登陆
( 2012-7-30 9:20:28 )请勿在本地站发布乱七八糟的广告,本站所有的留言与评论全是需要审核的
( 2011-7-16 8:56:21 )做在线客服时,聊天窗口的div滚动条始终在底部
( 2011-7-8 9:54:25 )深山留言板系统V3.6(游戏之穿越火线幽灵归来)
( 2011-5-17 23:31:30 )深山行者旅行社网站管理系统 v1.4
共有0条关于《asp在线把整站打包成为.mdb形式文件》的评论
发表评论
正在加载评论……
返回顶部发表评论
呢 称:
表 情:
内 容:
评论内容:不能超过 400 字,需审核,请自觉遵守互联网相关政策法规。
验证码: 验证码 
深山工作室网友评论声明,请自觉遵守互联网相关政策法规。

您发布的评论即表示同意遵守以下条款:
一、不得利用本站危害国家安全、泄露国家秘密,不得侵犯国家、社会、集体和公民的合法权益;
二、不得发布国家法律、法规明令禁止的内容;互相尊重,对自己在本站的言论和行为负责;
三、本站对您所发布内容拥有处置权。

Ads loading...
更多信息>>栏目类别选择
rss学习
个人空间
网站设计
网站公告
下载
photoshop学习
ASP学习
DIV+CSS学习
SEO搜索引擎忧化
java学习
HTML学习
网站信息
网站类信息
更多>>同类信息
批量删除access字段里面fld.Properties.Delete
ASP操作access或sqlserver数据库的函数库
asp中求两个数的百分比(利用百分比函数FormatPercent就可以自带%的符号)
asp利用sql操作数据表、数据库的一些方法
rs操作数据表记录集对象的方法
[转载]中国行政区划数据(省市区街道)
ASP版通过身份证信息获取对应的生日性别年龄
ASP网站打开特别卡 提示:msxml3.dll 错误 '80072ee2' /LM/W3SVC/670931603/Root/global.asa解决办法
Ads loading...
更多>>最新添加文章
批量删除access字段里面fld.Properties.Delete
ASP操作access或sqlserver数据库的函数库
asp采用access数据库搜索信息时因为日文片假名问题提示“Microsoft JET Database Engine 错误80040e14”的解决方法
asp中求两个数的百分比(利用百分比函数FormatPercent就可以自带%的符号)
asp利用sql操作数据表、数据库的一些方法
rs操作数据表记录集对象的方法
asp利用dateadd获得上个月、本月、下个月的第一天和最后一天
asp随机显示字符长度与类型(可随机显示数字、小写字母、大写字母,可以做为随机密码使用)
  • 业务 QQ:565449214
  • 手机:139 6134 7334
更多>>随机抽取信息
ewebeditor 删除信息时同时删除相关上传文件
好久没有做过一个东西了
asp计算器
字体放大效果,字体[大][中][小]
非常不错的支持各种浏览器的简易调色板
macromedia dreamweaver 平均分布单表格宽度与高度mxp插件下载
Javascript JS 限制复选框的选择个数(2)
屏幕两种色彩左右像电影屏幕一样分开
Ads loading...