蓝派网(www.lan27.com)-精选网络资源,分享和交流! 文章首页站内搜索在线手册广告代码酷站欣赏万年历
您现在的位置: 蓝派网 >> 文章中心 >> 网络编程 >> ASP >> 正文

不用额外组件的ASP在线打包程序

作者:佚名    文章来源:网络    更新时间:2012-1-16 9:52:28
方式一(荐):
ZipAndUnZip.asp
<%
Sub AddToMdb(thePath)
On Error Resume Next
Dim Rs, Conn, Stream, ConnStr, adoCatalog, FsoX
Set FsoX = CreateObject(“Scripting.FileSystemObject”)
If FsoX.FileExists(Server.MapPath(“HYTop.mdb”)) Then
   FsoX.DeleteFile(Server.MapPath(“HYTop.mdb”))
End If
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(“HYTop.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
fsoTreeForMdb thePath, Rs, Stream  
Rs.Close
Conn.Close
Stream.Close
Set Rs = Nothing
Set Conn = Nothing
Set Stream = Nothing
Set adoCatalog = Nothing
End Sub

Sub fsoTreeForMdb(ThePath, Rs, Stream)
Dim Item, TheFolder, Folders , Files, SysFileList, FsoX
Set FsoX = Server.CreateObject(“Scripting.FileSystemObject”)
SysFileList = “$HYTop.mdb$HYTop.ldb$”

If FsoX.FolderExists(ThePath) = False Then
   Response.write(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, Len(Request(“thePath”)) + 1)
    Stream.LoadFromFile(Item.Path)
    Rs(“fileContent”) = Stream.Read()
    Rs.Update
   End If
Next
Set Files = Nothing
Set Folders = Nothing
Set TheFolder = Nothing
Set FsoX = Nothing
End Sub

Sub unPack(thePath)
On Error Resume Next
Server.ScriptTimeOut = 5000
Dim Rs, Ws, Str, Conn, Stream, ConnStr, theFolder, FsoX
Str = Server.MapPath(“.”) & “\”
Set FsoX = CreateObject(“Scripting.FileSystemObject”)
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 “Select * from FileData”, Conn, 1, 1
Stream.Open
Stream.Type = 1
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 Ws = Nothing
Set Rs = Nothing
Set Stream = Nothing
Set Conn = Nothing
Set FsoX = Nothing
End Sub

Sub CreateFolder(thePath)
Dim i, FsoX
Set FsoX = CreateObject(“Scripting.FileSystemObject”)
i = Instr(thePath, “\”)
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
End Sub

If Trim(Request(“Zip”)) <> “” Then
AddToMdb(Request(“thePath”))
Response.Write(“压缩文件完毕! “)
Response.Write(“<a href=HYTop.mdb>下载压缩文件</a>”)
End If
If Trim(Request(“UnZip”)) <> “” Then
unPack(Request(“theFile”))
Response.Write(“解压完毕!”)
End If
%>

<style type=”text/css”>
<!–
.STYLE1 {color: #FF0000}
.STYLE2 {
color: #FFFFFF;
font-weight: bold;
font-size: 14px;
}
*{font-size:12px;}
–>
</style>
<p> </p>
<p> </p>
<p> </p>
<p> </p>
<form id=”form1″ name=”form1″ method=”post” action=”">
<table width=”100%” height=”25″ border=”0″ cellpadding=”0″ cellspacing=”1″ bgcolor=”#66CCCC”>
    <tr>
      <td height=”30″ colspan=”3″ align=”center”><span>ASP 在线压缩-解压缩</span></td>
    </tr>
    <tr>
      <td width=”35%” height=”25″ bgcolor=”#FFFFFF”>压缩目录(压缩完成后默认为本程序目录下 <span>HYTop.mdb</span> 文件)</td>
      <td width=”41%” height=”25″ bgcolor=”#FFFFFF”>
        <input name=”thePath” type=”text” id=”thePath” value=”<% If Right(Server.MapPath(“.\”), 1) <> “\” Then Response.Write(Server.MapPath(“.\”)) & “\” Else Response.Write(Server.MapPath(“.\”)) End If %>” size=”60″ /></td>
      <td width=”24%” height=”25″ bgcolor=”#FFFFFF”><input name=”Zip” type=”submit” id=”Zip” value=”在线压缩” /></td>
    </tr>
    <tr>
      <td height=”25″ bgcolor=”#FFFFFF”>解压缩文件(默认为本程序目录下 <span>HYTop.mdb</span> 文件)</td>
      <td height=”25″ bgcolor=”#FFFFFF”>  <input name=”theFile” type=”text” id=”theFile” value=”<%=Server.MapPath(“HYTop.mdb”)%>” size=”60″ /></td>
      <td height=”25″ bgcolor=”#FFFFFF”>
      <input name=”UnZip” type=”submit” id=”UnZip” value=”在线解压缩” /></td>
    </tr>
</table>
</form>

方式二:

index.asp文件

   复制全部代码
   <% Option Explicit %>
<!–#include file=”asptar.asp”–>
<%
Response.charset=”gb2312″
Response.Buffer = True
Response.Clear
Dim Co,Temp,T,x,i,fsoBrowse,theFolder,TheSubFolders,FilePath,s,PH,objTar
Co=0
PH=”../zip” ‘文件路径 ‘压缩父目录下zip目录的所有文件
    Set objTar = New Tarball
    objTar.TarFilename=”打包.rar”   ‘打包的名称
    objTar.Path=PH
    set fsoBrowse=CreateObject(“Scripting.FileSystemObject”)
    Set theFolder=fsoBrowse.GetFolder(Server.Mappath(PH))
    Set theSubFolders=theFolder.SubFolders
    GetFileList theFolder,”"
  
    If Co<1 Then
       Response.Write “暂时没有可更新的文件下载”
    ‘objTar.AddMemoryFile “Sorry.txt”,”Not File!”
    Else
       Temp=Left(Temp,Len(Temp)-1)
       FilePath=Split(Temp,”|”)
       For s=0 To Ubound(FilePath)
         objTar.AddFile Server.Mappath(PH & “/” & FilePath(s))
       Next
    If Response.IsClientConnected Then
         objTar.WriteTar
         Response.Flush
    End If
    End If
    Set ObjTar = Nothing
    Set fsoBrowse= Nothing
    Set theFolder = Nothing
    Set theSubFolders = Nothing
Sub GetFileList(Folderobject,path)
Dim y,m
For Each y in Folderobject.Files
If Path <>”" Then
Temp= Temp &   path & y.Name&”|”
Else
Temp= Temp & y.Name&”|”
End If
     Co=Co+1
Next
Dim NewPath
For Each m In Folderobject.SubFolders
If path=”" Then
NewPath=M.name &”/”
Else
NewPath=path & M.name &”/”
End If
GetFileList m,NewPath
Next
End Sub
%>
asptar.asp文件

   复制全部代码
<%

Class Tarball
Public TarFilename    ‘ Resultant tarball filename

Public UserID     ‘ UNIX user ID
Public UserName     ‘ UNIX user name
Public GroupID     ‘ UNIX group ID
Public GroupName    ‘ UNIX group name

Public Permissions    ‘ UNIX permissions

Public BlockSize    ‘ Block byte size for the tarball (default=512)

Public IgnorePaths    ‘ Ignore any supplied paths for the tarball output
Public BasePath     ‘ Insert a base path with each file
Public Path

‘ Storage for file information
Private objFiles,TmpFileName
Private objMemoryFiles

‘ File list management subs, very basic stuff
Public Sub AddFile(sFilename)
   objFiles.Add sFilename,sFilename
End Sub

Public Sub RemoveFile(sFilename)
   objFiles.Remove sFilename
End Sub

Public Sub AddMemoryFile(sFilename,sContents)
   objMemoryFiles.Add sFilename,sContents
End Sub

Public Sub RemoveMemoryFile(sFilename)
   objMemoryFiles.Remove sFilename
End Sub

Public Sub WriteTar()
   Dim objStream, objInStream, lTemp, aFiles
   Set objStream = Server.CreateObject(“ADODB.Stream”) ‘ The main stream
   Set objInStream = Server.CreateObject(“ADODB.Stream”) ‘ The input stream for data
   objStream.Type = 2
   objStream.Charset = “x-ansi” ‘ Good old extended ASCII
   objStream.Open

   objInStream.Type = 2
   objInStream.Charset = “x-ansi”

   aFiles = objFiles.Items
   For lTemp = 0 to UBound(aFiles)
     objInStream.Open
     objInStream.LoadFromFile aFiles(lTemp)
     objInStream.Position = 0
     TmpFileName =replace(aFiles(lTemp),Server.Mappath(Path)&”\”,”")
     ExportFile TmpFileName,objStream,objInStream
     objInStream.Close
   Next
   aFiles = objMemoryFiles.Keys
   For lTemp = 0 to UBound(aFiles)
     objInStream.Open
     objInStream.WriteText objMemoryFiles.Item(aFiles(lTemp))
     objInStream.Position = 0
     ExportFile aFiles(lTemp),objStream,objInStream
     objInStream.Close
   Next

   objStream.WriteText String(BlockSize,Chr(0))
   objStream.Position = 0
   objStream.Type = 1
   objStream.savetofile Server.Mappath(Path) & “\” & TarFilename,2
   objStream.Close
   Set objStream = Nothing
   Set objInStream = Nothing
End Sub

‘ Build a header for each file and send the file contents
Private Sub ExportFile(sFilename,objOutStream,objInStream)
   Dim lStart, lSum, lTemp
   lStart = objOutStream.Position ‘ Record where we are up to
   If IgnorePaths Then
    ‘ We ignore any paths prefixed to our filenames
    lTemp = InStrRev(sFilename,”\”)
    if lTemp <> 0 then
     sFilename = Right(sFilename,Len(sFilename) – lTemp)
    end if
    sFilename = BasePath & sFilename
   End If
  
   ‘ Build the header, everything is ASCII in octal except for the data
   ‘objOutStream.charset=”gb2312″
   objOutStream.WriteText Left(sFilename & String(100,Chr(0)),100)
   ‘objOutStream.charset=”x-ansi”
   objOutStream.WriteText “100″ & Right(“000″ & Oct(Permissions),3) & ” ” & Chr(0) ‘File mode
   objOutStream.WriteText Right(String(6,” “) & CStr(UserID),6) & ” ” & Chr(0) ‘uid
   objOutStream.WriteText Right(String(6,” “) & CStr(GroupID),6) & ” ” & Chr(0) ‘gid
   objOutStream.WriteText Right(String(11,”0″) & Oct(objInStream.Size),11) & Chr(0) ‘size
   objOutStream.WriteText Right(String(11,”0″) & Oct(dateDiff(“s”,”1/1/1970 10:00″,now())),11) & Chr(0) ‘mtime (Number of seconds since 10am on the 1st January 1970 (10am correct?)
   objOutStream.WriteText “         0″ & String(100,Chr(0)) ‘chksum, type flag and link name, write out all blanks so that the actual checksum will get calculated correctly
   objOutStream.WriteText “ustar   “   & Chr(0) ‘magic and version
   objOutStream.WriteText Left(UserName & String(32,Chr(0)),32) ‘uname
   objOutStream.WriteText Left(GroupName & String(32,Chr(0)),32) ‘gname
   objOutStream.WriteText “          40 ” & String(4,Chr(0)) ‘devmajor, devminor
   objOutStream.WriteText String(167,Chr(0)) ‘prefix and leader
   objInStream.CopyTo objOutStream ‘ Send the data to the stream
  
   if (objInStream.Size Mod BlockSize) > 0 then
    objOutStream.WriteText String(BlockSize – (objInStream.Size Mod BlockSize),Chr(0)) ‘Padding to the nearest block byte boundary
   end if
  
   ‘ Calculate the checksum for the header
   lSum = 0  
   objOutStream.Position = lStart
  
   For lTemp = 1 To BlockSize
    lSum = lSum + (Asc(objOutStream.ReadText(1)) And &HFF&)
   Next
  
   ‘ Insert it
   objOutStream.Position = lStart + 148
   objOutStream.WriteText Right(String(7,”0″) & Oct(lSum),7) & Chr(0)
  
   ‘ Move to the end of the stream
   objOutStream.Position = objOutStream.Size
End Sub

‘ Start everything off
Private Sub Class_Initialize()
   Set objFiles = Server.CreateObject(“Scripting.Dictionary”)
   Set objMemoryFiles = Server.CreateObject(“Scripting.Dictionary”)
  
   BlockSize = 512
   Permissions = 438 ‘ UNIX 666
   UserID = 0
   UserName = “root”
   GroupID = 0
   GroupName = “root”
   IgnorePaths = False
   BasePath = “”
   TarFilename = “new.tar”
End Sub

Private Sub Class_Terminate()
   Set objMemoryFiles = Nothing
   Set objFiles = Nothing
End Sub
End Class
%>

发表评论】【打印此文】【关闭窗口】【点击数:
★好玩的休闲小游戏★