[xanburzum]

CÓDIGO

<%@LANGUAGE="VBSCRIPT" CODEPAGE="1252"%>
<!--#include file="conexao/conexao1.asp"-->
<!--#include file="compactar.asp"-->
<%
Dim rec, id
id = Request.QueryString("ID")

Set rec = Server.CreateObject("ADODB.Recordset")
rec.ActiveConnection = conexao
rec.Source = "SELECT * FROM tabela WHERE ID = "& id &""
rec.Open()

Set FSO = Server.CreateObject("Scripting.FileSystemObject")
Set PASTA = FSO.GetFolder(server.mapPath("imagens_vist/"& rec.Fields.Item("pasta").Value &"/"))
Set Arquivos = Pasta.Files
Dim objTar
Set objTar = New Tarball
FOR EACH arquivo IN arquivos
objTar.AddFile arquivo
NEXT
objTar.WriteTar
set FSO = nothing
Response.Write "<br>Arquivos copiados e compactados com sucesso!"
%>

compactar.asp

CÓDIGO

<%
Class Tarball

Public TarFilename
Public UserID
Public UserName
Public GroupID
Public GroupName
Public Permissions
Public BlockSize
Public IgnorePaths
Public BasePath

Private objFiles
Private objMemoryFiles

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")
Set objInStream = Server.CreateObject("ADODB.Stream")

objStream.Type = 2
objStream.Charset = "x-ansi"
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
ExportFile aFiles(lTemp),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

Response.AddHeader "Content-Disposition","filename=" & TarFilename
Response.ContentType = "application/x-zip"
Response.BinaryWrite objStream.Read

objStream.Close
Set objStream = Nothing
Set objInStream = Nothing
End Sub

Private Sub ExportFile(sFilename,objOutStream,objInStream)
Dim lStart, lSum, lTemp

lStart = objOutStream.Position

If IgnorePaths Then
lTemp = InStrRev(sFilename,"\")
if lTemp <> 0 then
sFilename = Right(sFilename,Len(sFilename) - lTemp)
end if
sFilename = BasePath & sFilename
End If
objOutStream.WriteText Left(sFilename & String(100,Chr(0)),100)
objOutStream.WriteText "100" & Right("000" & Oct(Permissions),3) & " " & Chr(0)
objOutStream.WriteText Right(String(6," ") & CStr(UserID),6) & " " & Chr(0)
objOutStream.WriteText Right(String(6," ") & CStr(GroupID),6) & " " & Chr(0)
objOutStream.WriteText Right(String(11,"0") & Oct(objInStream.Size),11) & Chr(0)
objOutStream.WriteText Right(String(11,"0") & Oct(dateDiff("s","1/1/1970 10:00",now())),11) & Chr(0)
objOutStream.WriteText "        0" & String(100,Chr(0))
objOutStream.WriteText "ustar  "  & Chr(0)
objOutStream.WriteText Left(UserName & String(32,Chr(0)),32)
objOutStream.WriteText Left(GroupName & String(32,Chr(0)),32)
objOutStream.WriteText "         40 " & String(4,Chr(0))
objOutStream.WriteText String(167,Chr(0))
objInStream.CopyTo objOutStream

if (objInStream.Size Mod BlockSize) > 0 then
objOutStream.WriteText String(BlockSize - (objInStream.Size Mod BlockSize),Chr(0))
end if

lSum = 0
objOutStream.Position = lStart

For lTemp = 1 To BlockSize
lSum = lSum + (Asc(objOutStream.ReadText(1)) And &HFF&)
Next

objOutStream.Position = lStart + 148
objOutStream.WriteText Right(String(7,"0") & Oct(lSum),7) & Chr(0)

objOutStream.Position = objOutStream.Size
End Sub

Private Sub Class_Initialize()
Set objFiles = Server.CreateObject("Scripting.Dictionary")
Set objMemoryFiles = Server.CreateObject("Scripting.Dictionary")

BlockSize = 512
Permissions = 438

UserID = 0
UserName = "root"
GroupID = 0
GroupName = "root"

IgnorePaths = True
BasePath = "fotos/"

TarFilename = "vistoria_" & date & "_" & time & ".zip"
End Sub

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

conexao1.asp

CÓDIGO

<% sub abreconexao
constring="provider=microsoft.JET.OLEDB.4.0;Data Source=" & Server.MapPath("db/quaddra.mdb")
Set conexao=Server.CreateObject("ADODB.Connection")
conexao.open constring
end sub

sub fechaconexao
set conexao=nothing
end sub
%>