ALGUEM EH CAPAZ DE DESVENDAR ESSE CODIGO DE ZIPA?
Option Explicit
eh um frm e um bas
frmZip_AT
'- Função - : Compactar arquivos
'-------------------------------------------------------
'strDir : Diretório de onde serão pegos os arquivos
' para compactar (Desde que <> de .OUT)
'strExt : Extensões a serem zipadas
'strNomeZip : Nome do arquivo .ZIP a ser gerado
Public Function Zip(ByVal strDir As String, ByVal strExt As String, ByVal strNomeZip As String) As Boolean
Dim intI As Integer
Dim intTentativa As Integer: intTentativa = 0
Dim strMeio As String
Zip = False
For intI = 0 To 99
zZipFileNames.zFiles(intI) = ""
Next intI
Screen.MousePointer = vbHourglass
fileZIP.Path = strDir
fileZIP.Pattern = "*." & strExt
fileZIP.Refresh
zDate = vbNullString
zJunkDir = 1 ' 1 = Throw Away Path Names
zRecurse = 0 ' 1 = Recurse -R 2 = Recurse -r 2 = Most Useful :)
zUpdate = 0 ' 1 = Update Only If Newer
zFreshen = 0 ' 1 = Freshen - Overwrite Only
zLevel = Asc(9) ' Compression Level (0 - 9)
zEncrypt = 0 ' Encryption = 1 For Password Else 0
zComment = 0 ' Comment = 1 if required
'Adicionando arquivos à  matriz...
For intI = 0 To fileZIP.ListCount - 1
'Somente adiciona à  matriz se já não for um arquivo xxxxxx.ZIP.xxx
strMeio = Mid(fileZIP.List(intI), InStr(1, fileZIP.List(intI), ".") + 1, 3)
If UCase(strMeio) <> "ZIP" Then
prLog ("Arquivo ") & fileZIP.List(intI) & " compactado"
zZipFileNames.zFiles(intI) = strDir & "\" & fileZIP.List(intI)
End If
Next intI
zArgc = fileZIP.ListCount
zRootDir = Left(App.Path, 3)
zZipFileName = strDir & "\" & strNomeZip
TentaNovamente:
intTentativa = intTentativa + 1
'Zipando...
RetCode = VBZip32
'Arquivo de Log (C:\Windows\ZipErr.LOG)
Call CodRetZIP(strNomeZip, 0)
If RetCode = 12 Then Exit Function
If RetCode <> 0 Then
If intTentativa > 3 Then
prLog ("O arquivo " & strNomeZip & " não foi Compactado. Ele será movido para o diretório 'ZipErr'")
If Dir(App.Path & "\ZipErr", vbDirectory) = "" Then
MkDir App.Path & "\ZipErr"
End If
If Dir(App.Path & "\ZipErr\" & strNomeZip, vbArchive) <> "" Then
Kill App.Path & "\ZipErr\" & strNomeZip
End If
Name strDir As App.Path & "\ZipErr\" & strNomeZip
Exit Function
Else
intTentativa = intTentativa + 1
GoTo TentaNovamente 'vai p/ linha 48
End If
Else
'Move para o Backup
If Dir(strDir & "\Backup", vbDirectory) = "" Then MkDir (strDir & "\Backup")
For intI = 0 To fileZIP.ListCount - 1
If Dir(strDir & "\Backup\" & fileZIP.List(intI), vbArchive) <> "" Then
Kill strDir & "\Backup\" & fileZIP.List(intI)
End If
Name strDir & "\" & fileZIP.List(intI) As strDir & "\Backup\" & fileZIP.List(intI)
Next intI
Zip = True
End If
Screen.MousePointer = vbNormal
End Function
'Função : Descompactar arquivos
'strArq : Caminho e Nome do arquivo .ZIP
'strDir : Diretório para onde irão os arquivos descompactados
'strNome: Nome Original do arquivo
Public Function UnZip(ByVal strArq As String, ByVal strDir As String, ByVal strNome As String)
Dim intTentativa As Integer: intTentativa = 0
lblMsg.Caption = "Descompactando " & strNome
uPromptOverWrite = 0 ' 1 = Prompt To Overwrite
uOverWriteFiles = 1 ' 1 = Always Overwrite Files
uDisplayComment = 0 ' 1 = Display comment ONLY!!!
uExtractList = 0 ' 1 = List Contents Of Zip 0 = Extract
uHonorDirectories = 0 ' 1 = Honour Zip Directories
uZipFileName = strArq 'Nome do arquivo
uExtractDir = strDir 'Diretório a gravar
If uExtractDir <> "" Then uExtractList = 0 ' unzip if dir specified
'Chama função para Descompactar
TentaNovamente: ' funcao descompactar
Call VBUnZip32
'Arquivo de Log (C:\Windows\ZipErr.LOG)
Call CodRetZIP(strNome, 1)
If RetCode <> 0 Then
If intTentativa > 3 Then
prLog ("O arquivo " & strNome & " não foi descompactado. Ele será movido para o diretório ZipErr")
If Dir(App.Path & "\ZipErr", vbDirectory) = "" Then
MkDir App.Path & "\ZipErr"
End If
If Dir(App.Path & "\ZipErr\" & strNome, vbArchive) <> "" Then
Kill App.Path & "\ZipErr\" & strNome
End If
Name strArq As App.Path & "\ZipErr\" & strNome
Exit Function
Else
intTentativa = intTentativa + 1
GoTo TentaNovamente 'vai p/ linha 111
End If
Else
'Move para o Backup
If Dir(strDir & "\BackZip", vbDirectory) = "" Then MkDir (strDir & "\BackZip")
If Dir(strDir & "\BackZip\" & strNome) <> "" Then Kill (strDir & "\BackZip\" & strNome)
' arq atual, arq copia
FileCopy strArq, strDir & "\BackZip\" & strNome
Kill strArq
End If
DoEvents
If Dir(strArq, vbArchive) <> "" Then
prLog ("Ocorreu um erro de acesso no arquivo " & strNome & "Para evitar duplicidades o processamento será finalizado!")
MsgBox "Ocorreu um erro de acesso no arquivo " & strNome & vbCrLf & "Para evitar duplicidades o processamento será finalizado!", vbCritical, App.Title
End
End If
Screen.MousePointer = vbNormal
End Function
'Sub CodRetZIP (Código de Retorno ZIP)
'Função : Retornar uma String de acordo com o código retornado
' pela função de ZIP
Private Sub CodRetZIP(ByVal NomeArq As String, ByVal Funcao As Integer)
If Funcao = 0 Then
prLog ("Compactação de " & NomeArq)
Else
prLog ("Descompactação de " & NomeArq)
End If
Select Case RetCode
Case 0 ' Sucesso (Não houveram erros)
If Funcao = 0 Then
prLog ("Arquivo Compactado com Sucesso")
Else
prLog ("Arquivo descompactado com Sucesso")
End If
Case 1
'Não encontrei este número de erro
Exit Sub
Case 2 ' Fim inesperado de arquivo ZIP
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Fim Inesperado de arquivo .ZIP")
Case 3 ' Erro na estrutura do arquivo ZIP
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Erro na estrutura do arquivo ZIP")
Case 4 ' Falta de memória disponÃvel
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Falta de memória disponÃvel (Out of Memory)")
Case 5 ' Erro Interno
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Erro Interno do procedimento (DLL)")
Case 6 ' Entrada muito grande para (separar/dividir) o erro
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Entrada muito grande para isolar o erro. Erro não identificado")
Case 7 ' Formato de Comentário Inválido
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Formato de Comentário Inválido")
Case 8 ' Falha no teste do Zip (- T) ou falta de memória disponÃvel
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Falha no teste do Zip (- T) ou falta de memória disponÃvel")
Case 9 ' Interrompido pelo usuário
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Interrompido pelo usuário")
Case 10 ' Erro ao usar arquivo temporário
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Erro ao usar arquivo temporário")
Case 11 ' Erro de Leitura ou Pesquisa
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Erro de Leitura ou Pesquisa")
Case 12 ' Sem função (Nenhum arquivo a ser compactado)
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Sem função (Nenhum arquivo a ser compactado/descompactado)")
Case 13 ' Arquivo ZIP vazio ou não encontrado
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Arquivo ZIP vazio ou não encontrado")
Case 14 ' Erro ao gravar o arquivo
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Erro ao gravar o arquivo")
Case 15 ' Erro na abertura do arquivo para Gravação
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Erro na abertura do arquivo para Gravação")
Case 16 ' Linha de Comando Errada ou Inválida
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Linha de Comando Errada ou Inválida")
Case 17
'Não encontrei este número de erro !!!
Exit Sub
Case 18 ' Erro na abertura de um arquivo especificado para leitura
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Erro na abertura de um arquivo especificado para leitura")
End Select
prLog (Space(70))
End Sub
basZip
Option Explicit
'************** ZIP DECLARAÇÕES *********************
Public RetCode As Long
'-- Holds The Zip Archive Filenames
Public Type ZIPnames
zFiles(0 To 99) As String
End Type
'-- Call Back "String"
Public Type ZipCBChar
ch(4096) As Byte
End Type
'-- ZPOPT Is Used To Set The Options In The ZIP32.DLL
Public Type ZPOPT
date As String ' US Date (8 Bytes Long) "12/31/98"?
szRootDir As String ' Root Directory Pathname (Up To 256 Bytes Long)
szTempDir As String ' Temp Directory Pathname (Up To 256 Bytes Long)
fTemp As Long ' 1 If Temp dir Wanted, Else 0
fSuffix As Long ' Include Suffixes (Not Yet Implemented!)
fEncrypt As Long ' 1 If Encryption Wanted, Else 0
fSystem As Long ' 1 To Include System/Hidden Files, Else 0
fVolume As Long ' 1 If Storing Volume Label, Else 0
fExtra As Long ' 1 If Excluding Extra Attributes, Else 0
fNoDirEntries As Long ' 1 If Ignoring Directory Entries, Else 0
fExcludeDate As Long ' 1 If Excluding Files Earlier Than Specified Date, Else 0
fIncludeDate As Long ' 1 If Including Files Earlier Than Specified Date, Else 0
fVerbose As Long ' 1 If Full Messages Wanted, Else 0
fQuiet As Long ' 1 If Minimum Messages Wanted, Else 0
fCRLF_LF As Long ' 1 If Translate CR/LF To LF, Else 0
fLF_CRLF As Long ' 1 If Translate LF To CR/LF, Else 0
fJunkDir As Long ' 1 If Junking Directory Names, Else 0
fGrow As Long ' 1 If Allow Appending To Zip File, Else 0
fForce As Long ' 1 If Making Entries Using DOS File Names, Else 0
fMove As Long ' 1 If Deleting Files Added Or Updated, Else 0
fDeleteEntries As Long ' 1 If Files Passed Have To Be Deleted, Else 0
fUpdate As Long ' 1 If Updating Zip File-Overwrite Only If Newer, Else 0
fFreshen As Long ' 1 If Freshing Zip File-Overwrite Only, Else 0
fJunkSFX As Long ' 1 If Junking SFX Prefix, Else 0
fLatestTime As Long ' 1 If Setting Zip File Time To Time Of Latest File In Archive, Else 0
fComment As Long ' 1 If Putting Comment In Zip File, Else 0
fOffsets As Long ' 1 If Updating Archive Offsets For SFX Files, Else 0
fPrivilege As Long ' 1 If Not Saving Privileges, Else 0
fEncryption As Long ' Read Only Property!!!
fRecurse As Long ' 1 (-r), 2 (-R) If Recursing Into Sub-Directories, Else 0
fRepair As Long ' 1 = Fix Archive, 2 = Try Harder To Fix, Else 0
flevel As Byte ' Compression Level - 0 = Stored 6 = Default 9 = Max
End Type
'-- This Structure Is Used For The ZIP32.DLL Function Callbacks
Public Type ZIPUSERFUNCTIONS
ZDLLPrnt As Long ' Callback ZIP32.DLL Print Function
ZDLLCOMMENT As Long ' Callback ZIP32.DLL Comment Function
ZDLLPASSWORD As Long ' Callback ZIP32.DLL Password Function
ZDLLSERVICE As Long ' Callback ZIP32.DLL Service Function
End Type
'-- Local Declarations
Public ZOPT As ZPOPT
Public ZUSER As ZIPUSERFUNCTIONS
'-- This Assumes ZIP32.DLL Is In Your \Windows\System Directory!
'-- (alternatively, a copy of ZIP32.DLL needs to be located in the program
'-- directory or in some other directory listed in the PATH.)
Private Declare Function ZpInit Lib "zip32.dll" _
(ByRef Zipfun As ZIPUSERFUNCTIONS) As Long '-- Set Zip Callbacks
Private Declare Function ZpSetOptions Lib "zip32.dll" _
(ByRef Opts As ZPOPT) As Long '-- Set Zip Options
Private Declare Function ZpGetOptions Lib "zip32.dll" _
() As ZPOPT '-- Used To Check Encryption Flag Only
Private Declare Function ZpArchive Lib "zip32.dll" _
(ByVal argc As Long, ByVal funame As String, _
ByRef argv As ZIPnames) As Long '-- Real Zipping Action
'-------------------------------------------------------
'-- Public Variables For Setting The ZPOPT Structure...
'-- (WARNING!!!) You Must Set The Options That You
'-- Want The ZIP32.DLL To Do!
'-- Before Calling VBZip32!
'-------------------------------------------------------
Public zDate As String
Public zRootDir As String
Public zTempDir As String
Public zSuffix As Integer
Public zEncrypt As Integer
Public zSystem As Integer
Public zVolume As Integer
Public zExtra As Integer
Public zNoDirEntries As Integer
Public zExcludeDate As Integer
Public zIncludeDate As Integer
Public zVerbose As Integer
Public zQuiet As Integer
Public zCRLF_LF As Integer
Public zLF_CRLF As Integer
Public zJunkDir As Integer
Public zRecurse As Integer
Public zGrow As Integer
Public zForce As Integer
Public zMove As Integer
Public zDelEntries As Integer
Public zUpdate As Integer
Public zFreshen As Integer
Public zJunkSFX As Integer
Public zLatestTime As Integer
Public zComment As Integer
Public zOffsets As Integer
Public zPrivilege As Integer
Public zEncryption As Integer
Public zRepair As Integer
Public zLevel As Integer
'-- Public Program Variables
Public zArgc As Integer ' Number Of Files To Zip Up
Public zZipFileName As String ' The Zip File Name ie: Myzip.zip
Public zZipFileNames As ZIPnames ' File Names To Zip Up
Public zZipInfo As String ' Holds The Zip File Information
'-- Public Constants
'-- For Zip & UnZip Error Codes!
Public Const ZE_OK = 0 ' Success (No Error)
Public Const ZE_EOF = 2 ' Unexpected End Of Zip File Error
Public Const ZE_FORM = 3 ' Zip File Structure Error
Public Const ZE_MEM = 4 ' Out Of Memory Error
Public Const ZE_LOGIC = 5 ' Internal Logic Error
Public Const ZE_BIG = 6 ' Entry Too Large To Split Error
Public Const ZE_NOTE = 7 ' Invalid Comment Format Error
Public Const ZE_TEST = 8 ' Zip Test (-T) Failed Or Out Of Memory Error
Public Const ZE_ABORT = 9 ' User Interrupted Or Termination Error
Public Const ZE_TEMP = 10 ' Error Using A Temp File
Public Const ZE_READ = 11 ' Read Or Seek Error
Public Const ZE_NONE = 12 ' Nothing To Do Error
Public Const ZE_NAME = 13 ' Missing Or Empty Zip File Error
Public Const ZE_WRITE = 14 ' Error Writing To A File
Public Const ZE_CREAT = 15 ' Could't Open To Write Error
Public Const ZE_PARMS = 16 ' Bad Command Line Argument Error
Public Const ZE_OPEN = 18 ' Could Not Open A Specified File To Read Error
'***************** UNZIP DECLARAÇÕES ***********************
'-- C Style argv
Private Type UNZIPnames
uzFiles(0 To 99) As String
End Type
'-- Callback Large "String"
Private Type UNZIPCBChar
ch(32800) As Byte
End Type
'-- Callback Small "String"
Private Type UNZIPCBCh
ch(256) As Byte
End Type
'-- UNZIP32.DLL DCL Structure
Private Type DCLIST
ExtractOnlyNewer As Long ' 1 = Extract Only Newer, Else 0
SpaceToUnderscore As Long ' 1 = Convert Space To Underscore, Else 0
PromptToOverwrite As Long ' 1 = Prompt To Overwrite Required, Else 0
fQuiet As Long ' 2 = No Messages, 1 = Less, 0 = All
ncflag As Long ' 1 = Write To Stdout, Else 0
ntflag As Long ' 1 = Test Zip File, Else 0
nvflag As Long ' 0 = Extract, 1 = List Zip Contents
nUflag As Long ' 1 = Extract Only Newer, Else 0
nzflag As Long ' 1 = Display Zip File Comment, Else 0
ndflag As Long ' 1 = Honor Directories, Else 0
noflag As Long ' 1 = Overwrite Files, Else 0
naflag As Long ' 1 = Convert CR To CRLF, Else 0
nZIflag As Long ' 1 = Zip Info Verbose, Else 0
C_flag As Long ' 1 = Case Insensitivity, 0 = Case Sensitivity
fPrivilege As Long ' 1 = ACL, 2 = Privileges
Zip As String ' The Zip Filename To Extract Files
ExtractDir As String ' The Extraction Directory, NULL If Extracting To Current Dir
End Type
'-- UNZIP32.DLL Userfunctions Structure
Private Type USERFUNCTION
UZDLLPrnt As Long ' Pointer To Apps Print Function
UZDLLSND As Long ' Pointer To Apps Sound Function
UZDLLREPLACE As Long ' Pointer To Apps Replace Function
UZDLLPASSWORD As Long ' Pointer To Apps Password Function
UZDLLMESSAGE As Long ' Pointer To Apps Message Function
UZDLLSERVICE As Long ' Pointer To Apps Service Function (Not Coded!)
TotalSizeComp As Long ' Total Size Of Zip Archive
TotalSize As Long ' Total Size Of All Files In Archive
CompFactor As Long ' Compression Factor
NumMembers As Long ' Total Number Of All Files In The Archive
cchComment As Integer ' Flag If Archive Has A Comment!
End Type
'-- UNZIP32.DLL Version Structure
Private Type UZPVER
structlen As Long ' Length Of The Structure Being Passed
flag As Long ' Bit 0: is_beta bit 1: uses_zlib
beta As String * 10 ' e.g., "g BETA" or ""
date As String * 20 ' e.g., "4 Sep 95" (beta) or "4 September 1995"
zlib As String * 10 ' e.g., "1.0.5" or NULL
UnZip(1 To 4) As Byte ' Version Type Unzip
zipinfo(1 To 4) As Byte ' Version Type Zip Info
os2dll As Long ' Version Type OS2 DLL
windll(1 To 4) As Byte ' Version Type Windows DLL
End Type
'-- This Assumes UNZIP32.DLL Is In Your \Windows\System Directory!
Private Declare Function Wiz_SingleEntryUnzip Lib "unzip32.dll" _
(ByVal ifnc As Long, ByRef ifnv As UNZIPnames, _
ByVal xfnc As Long, ByRef xfnv As UNZIPnames, _
dcll As DCLIST, Userf As USERFUNCTION) As Long
Private Declare Sub UzpVersion2 Lib "unzip32.dll" (uzpv As UZPVER)
'-- Private Variables For Structure Access
Private UZDCL As DCLIST
Private UZUSER As USERFUNCTION
Private UZVER As UZPVER
'-- Public Variables For Setting The
'-- UNZIP32.DLL DCLIST Structure
'-- These Must Be Set Before The Actual Call To VBUnZip32
Public uExtractNewer As Integer ' 1 = Extract Only Newer, Else 0
Public uSpaceUnderScore As Integer ' 1 = Convert Space To Underscore, Else 0
Public uPromptOverWrite As Integer ' 1 = Prompt To Overwrite Required, Else 0
Public uQuiet As Integer ' 2 = No Messages, 1 = Less, 0 = All
Public uWriteStdOut As Integer ' 1 = Write To Stdout, Else 0
Public uTestZip As Integer ' 1 = Test Zip File, Else 0
Public uExtractList As Integer ' 0 = Extract, 1 = List Contents
Public uExtractOnlyNewer As Integer ' 1 = Extract Only Newer, Else 0
Public uDisplayComment As Integer ' 1 = Display Zip File Comment, Else 0
Public uHonorDirectories As Integer ' 1 = Honor Directories, Else 0
Public uOverWriteFiles As Integer ' 1 = Overwrite Files, Else 0
Public uConvertCR_CRLF As Integer ' 1 = Convert CR To CRLF, Else 0
Public uVerbose As Integer ' 1 = Zip Info Verbose
Public uCaseSensitivity As Integer ' 1 = Case Insensitivity, 0 = Case Sensitivity
Public uPrivilege As Integer ' 1 = ACL, 2 = Privileges, Else 0
Public uZipFileName As String ' The Zip File Name
Public uExtractDir As String ' Extraction Directory, Null If Current Directory
'-- Public Program Variables
Public uZipNumber As Long ' Zip File Number
Public uNumberFiles As Long ' Number Of Files
Public uNumberXFiles As Long ' Number Of Extracted Files
Public uZipMessage As String ' For Zip Message
Public uZipInfo As String ' For Zip Information
Public uZipNames As UNZIPnames ' Names Of Files To Unzip
Public uExcludeNames As UNZIPnames ' Names Of Zip Files To Exclude
Public uVbSkip As Integer ' For DLL Password Function
'-- These Functions Are For The ZIP32.DLL
'--
'-- Puts A Function Pointer In A Structure
'-- For Use With Callbacks...
Public Function FnPtr(ByVal lp As Long) As Long
FnPtr = lp
End Function
'-- Callback For ZIP32.DLL - DLL Print Function
Public Function ZDLLPrnt(ByRef fname As ZipCBChar, ByVal x As Long) As Long
Dim s0 As String
Dim xx As Long
'-- Always Put This In Callback Routines!
On Error Resume Next
s0 = ""
'-- Get Zip32.DLL Message For processing
For xx = 0 To x
If fname.ch(xx) = 0 Then
Exit For
Else
s0 = s0 + Chr(fname.ch(xx))
End If
Next
DoEvents
ZDLLPrnt = 0
End Function
'-- Callback For ZIP32.DLL - DLL Service Function
Public Function ZDLLServ(ByRef mname As ZipCBChar, ByVal x As Long) As Long
Dim s0 As String
Dim xx As Long
'-- Always Put This In Callback Routines!
On Error Resume Next
s0 = ""
'-- Get Zip32.DLL Message For processing
For xx = 0 To x
If mname.ch(xx) = 0 Then
Exit For
Else
s0 = s0 + Chr(mname.ch(xx))
End If
Next
' At this point, s0 contains the message passed from the DLL
' It is up to the developer to code something useful here :)
ZDLLServ = 0 ' Setting this to 1 will abort the zip!
End Function
'-- Callback For ZIP32.DLL - DLL Password Function
Public Function ZDLLPass(ByRef p As ZipCBChar, _
ByVal n As Long, ByRef m As ZipCBChar, _
ByRef Name As ZipCBChar) As Integer
Dim prompt As String
Dim xx As Integer
Dim szpassword As String
'-- Always Put This In Callback Routines!
On Error Resume Next
ZDLLPass = 1
'-- If There Is A Password Have The User Enter It!
'-- This Can Be Changed
szpassword = InputBox("Please Enter The Password!")
'-- The User Did Not Enter A Password So Exit The Function
If szpassword = "" Then Exit Function
'-- User Entered A Password So Proccess It
For xx = 0 To 255
If m.ch(xx) = 0 Then
Exit For
Else
prompt = prompt & Chr(m.ch(xx))
End If
Next
For xx = 0 To n - 1
p.ch(xx) = 0
Next
For xx = 0 To Len(szpassword) - 1
p.ch(xx) = Asc(Mid(szpassword, xx + 1, 1))
Next
p.ch(xx) = Chr(0) ' Put Null Terminator For C
ZDLLPass = 0
End Function
'-- Callback For ZIP32.DLL - DLL Comment Function
Public Function ZDLLComm(ByRef s1 As ZipCBChar) As Integer
Dim xx%, szcomment$
'-- Always Put This In Callback Routines!
On Error Resume Next
ZDLLComm = 1
szcomment = InputBox("Enter the comment")
If szcomment = "" Then Exit Function
For xx = 0 To Len(szcomment) - 1
s1.ch(xx) = Asc(Mid$(szcomment, xx + 1, 1))
Next xx
s1.ch(xx) = Chr(0) ' Put null terminator for C
End Function
'-- Main ZIP32.DLL Subroutine.
Public Function VBZip32() As Long
On Error Resume Next
RetCode = 0
'-- Set Address Of ZIP32.DLL Callback Functions
ZUSER.ZDLLPrnt = FnPtr(AddressOf ZDLLPrnt)
ZUSER.ZDLLPASSWORD = FnPtr(AddressOf ZDLLPass)
ZUSER.ZDLLCOMMENT = FnPtr(AddressOf ZDLLComm)
ZUSER.ZDLLSERVICE = FnPtr(AddressOf ZDLLServ)
'-- Set ZIP32.DLL Callbacks
RetCode = ZpInit(ZUSER)
'-- Setup ZIP32 Options
ZOPT.date = zDate ' "12/31/79"? US Date?
ZOPT.szRootDir = zRootDir ' Root Directory Pathname
ZOPT.szTempDir = zTempDir ' Temp Directory Pathname
ZOPT.fSuffix = zSuffix ' Include Suffixes (Not Yet Implemented)
ZOPT.fEncrypt = zEncrypt ' 1 If Encryption Wanted
ZOPT.fSystem = zSystem ' 1 To Include System/Hidden Files
ZOPT.fVolume = zVolume ' 1 If Storing Volume Label
ZOPT.fExtra = zExtra ' 1 If Including Extra Attributes
ZOPT.fNoDirEntries = zNoDirEntries ' 1 If Ignoring Directory Entries
ZOPT.fExcludeDate = zExcludeDate ' 1 If Excluding Files Earlier Than A Specified Date
ZOPT.fIncludeDate = zIncludeDate ' 1 If Including Files Earlier Than A Specified Date
ZOPT.fVerbose = zVerbose ' 1 If Full Messages Wanted
ZOPT.fQuiet = zQuiet ' 1 If Minimum Messages Wanted
ZOPT.fCRLF_LF = zCRLF_LF ' 1 If Translate CR/LF To LF
ZOPT.fLF_CRLF = zLF_CRLF ' 1 If Translate LF To CR/LF
ZOPT.fJunkDir = zJunkDir ' 1 If Junking Directory Names
ZOPT.fGrow = zGrow ' 1 If Allow Appending To Zip File
ZOPT.fForce = zForce ' 1 If Making Entries Using DOS Names
ZOPT.fMove = zMove ' 1 If Deleting Files Added Or Updated
ZOPT.fDeleteEntries = zDelEntries ' 1 If Files Passed Have To Be Deleted
ZOPT.fUpdate = zUpdate ' 1 If Updating Zip File-Overwrite Only If Newer
ZOPT.fFreshen = zFreshen ' 1 If Freshening Zip File-Overwrite Only
ZOPT.fJunkSFX = zJunkSFX ' 1 If Junking SFX Prefix
ZOPT.fLatestTime = zLatestTime ' 1 If Setting Zip File Time To Time Of Latest File In Archive
ZOPT.fComment = zComment ' 1 If Putting Comment In Zip File
ZOPT.fOffsets = zOffsets ' 1 If Updating Archive Offsets For SFX Files
ZOPT.fPrivilege = zPrivilege ' 1 If Not Saving Privelages
ZOPT.fEncryption = zEncryption ' Read Only Property!
ZOPT.fRecurse = zRecurse ' 1 or 2 If Recursing Into Subdirectories
ZOPT.fRepair = zRepair ' 1 = Fix Archive, 2 = Try Harder To Fix
ZOPT.flevel = zLevel ' Compression Level - (0 To 9) Should Be 0!!!
'-- Set ZIP32.DLL Options
RetCode = ZpSetOptions(ZOPT)
'-- Go Zip It Them Up!
RetCode = ZpArchive(zArgc, zZipFileName, zZipFileNames)
'-- Return The Function Code
VBZip32 = RetCode
End Function
'-- Callback For UNZIP32.DLL - Receive Message Function
Public Sub UZReceiveDLLMessage(ByVal ucsize As Long, _
ByVal csiz As Long, _
ByVal cfactor As Integer, _
ByVal mo As Integer, _
ByVal dy As Integer, _
ByVal yr As Integer, _
ByVal hh As Integer, _
ByVal mm As Integer, _
ByVal c As Byte, ByRef fname As UNZIPCBCh, _
ByRef meth As UNZIPCBCh, ByVal crc As Long, _
ByVal fCrypt As Byte)
Dim s0 As String
Dim xx As Long
Dim strout As String * 80
'-- Always Put This In Callback Routines!
On Error Resume Next
'------------------------------------------------
'-- This Is Where The Received Messages Are
'-- Printed Out And Displayed.
'-- You Can Modify Below!
'------------------------------------------------
strout = Space(80)
'-- For Zip Message Printing
If uZipNumber = 0 Then
Mid(strout, 1, 50) = "Filename:"
Mid(strout, 53, 4) = "Size"
Mid(strout, 62, 4) = "Date"
Mid(strout, 71, 4) = "Time"
uZipMessage = strout & vbNewLine
strout = Space(80)
End If
s0 = ""
'-- Do Not Change This For Next!!!
For xx = 0 To 255
If fname.ch(xx) = 0 Then Exit For
s0 = s0 & Chr(fname.ch(xx))
Next
'-- Assign Zip Information For Printing
Mid(strout, 1, 50) = Mid(s0, 1, 50)
Mid(strout, 51, 7) = Right(" " & Str(ucsize), 7)
Mid(strout, 60, 3) = Right("0" & Trim(Str(mo)), 2) & "/"
Mid(strout, 63, 3) = Right("0" & Trim(Str(dy)), 2) & "/"
Mid(strout, 66, 2) = Right("0" & Trim(Str(yr)), 2)
Mid(strout, 70, 3) = Right(Str(hh), 2) & ":"
Mid(strout, 73, 2) = Right("0" & Trim(Str(mm)), 2)
'-- Do Not Modify Below!!!
uZipMessage = uZipMessage & strout & vbNewLine
uZipNumber = uZipNumber + 1
End Sub
'-- Callback For UNZIP32.DLL - Print Message Function
Public Function UZDLLPrnt(ByRef fname As UNZIPCBChar, ByVal x As Long) As Long
Dim s0 As String
Dim xx As Long
'-- Always Put This In Callback Routines!
On Error Resume Next
s0 = ""
'-- Gets The UNZIP32.DLL Message For Displaying.
For xx = 0 To x - 1
If fname.ch(xx) = 0 Then Exit For
s0 = s0 & Chr(fname.ch(xx))
Next
'-- Assign Zip Information
If Mid$(s0, 1, 1) = vbLf Then s0 = vbNewLine ' Damn UNIX :-)
uZipInfo = uZipInfo & s0
UZDLLPrnt = 0
End Function
'-- Callback For UNZIP32.DLL - DLL Service Function
Public Function UZDLLServ(ByRef mname As UNZIPCBChar, ByVal x As Long) As Long
Dim s0 As String
Dim xx As Long
'-- Always Put This In Callback Routines!
On Error Resume Next
s0 = ""
'-- Get Zip32.DLL Message For processing
For xx = 0 To x - 1
If mname.ch(xx) = 0 Then Exit For
s0 = s0 + Chr(mname.ch(xx))
Next
' At this point, s0 contains the message passed from the DLL
' It is up to the developer to code something useful here :)
UZDLLServ = 0 ' Setting this to 1 will abort the zip!
End Function
'-- Callback For UNZIP32.DLL - Password Function
Public Function UZDLLPass(ByRef p As UNZIPCBCh, _
ByVal n As Long, ByRef m As UNZIPCBCh, _
ByRef Name As UNZIPCBCh) As Integer
Dim prompt As String
Dim xx As Integer
Dim szpassword As String
'-- Always Put This In Callback Routines!
On Error Resume Next
UZDLLPass = 1
If uVbSkip = 1 Then Exit Function
'-- Get The Zip File Password
szpassword = InputBox("Please Enter The Password!")
'-- No Password So Exit The Function
If szpassword = "" Then
uVbSkip = 1
Exit Function
End If
'-- Zip File Password So Process It
For xx = 0 To 255
If m.ch(xx) = 0 Then
Exit For
Else
prompt = prompt & Chr(m.ch(xx))
End If
Next
For xx = 0 To n - 1
p.ch(xx) = 0
Next
For xx = 0 To Len(szpassword) - 1
p.ch(xx) = Asc(Mid(szpassword, xx + 1, 1))
Next
p.ch(xx) = Chr(0) ' Put Null Terminator For C
UZDLLPass = 0
End Function
'-- Callback For UNZIP32.DLL - Report Function To Overwrite Files.
'-- This Function Will Display A MsgBox Asking The User
'-- If They Would Like To Overwrite The Files.
Public Function UZDLLRep(ByRef fname As UNZIPCBChar) As Long
Dim s0 As String
Dim xx As Long
'-- Always Put This In Callback Routines!
On Error Resume Next
UZDLLRep = 100 ' 100 = Do Not Overwrite - Keep Asking User
s0 = ""
For xx = 0 To 255
If fname.ch(xx) = 0 Then xx = 99999 Else s0 = s0 & Chr(fname.ch(xx))
Next
'-- This Is The MsgBox Code
xx = MsgBox("Overwrite " & s0 & "?", vbExclamation & vbYesNoCancel, _
"VBUnZip32 - File Already Exists!")
If xx = vbNo Then Exit Function
If xx = vbCancel Then
UZDLLRep = 104 ' 104 = Overwrite None
Exit Function
End If
UZDLLRep = 102 ' 102 = Overwrite 103 = Overwrite All
End Function
'-- ASCIIZ To String Function
Public Function szTrim(szString As String) As String
Dim pos As Integer
Dim ln As Integer
pos = InStr(szString, Chr(0))
ln = Len(szString)
Select Case pos
Case Is > 1
szTrim = Trim(Left(szString, pos - 1))
Case 1
szTrim = ""
Case Else
szTrim = Trim(szString)
End Select
End Function
'-- Main UNZIP32.DLL UnZip32 Subroutine
'-- (WARNING!) Do Not Change!
Public Sub VBUnZip32()
Dim MsgStr As String
'-- Set The UNZIP32.DLL Options
'-- (WARNING!) Do Not Change
UZDCL.ExtractOnlyNewer = uExtractNewer ' 1 = Extract Only Newer
UZDCL.SpaceToUnderscore = uSpaceUnderScore ' 1 = Convert Space To Underscore
UZDCL.PromptToOverwrite = uPromptOverWrite ' 1 = Prompt To Overwrite Required
UZDCL.fQuiet = uQuiet ' 2 = No Messages 1 = Less 0 = All
UZDCL.ncflag = uWriteStdOut ' 1 = Write To Stdout
UZDCL.ntflag = uTestZip ' 1 = Test Zip File
UZDCL.nvflag = uExtractList ' 0 = Extract 1 = List Contents
UZDCL.nUflag = uExtractOnlyNewer ' 1 = Extract Only Newer
UZDCL.nzflag = uDisplayComment ' 1 = Display Zip File Comment
UZDCL.ndflag = uHonorDirectories ' 1 = Honour Directories
UZDCL.noflag = uOverWriteFiles ' 1 = Overwrite Files
UZDCL.naflag = uConvertCR_CRLF ' 1 = Convert CR To CRLF
UZDCL.nZIflag = uVerbose ' 1 = Zip Info Verbose
UZDCL.C_flag = uCaseSensitivity ' 1 = Case insensitivity, 0 = Case Sensitivity
UZDCL.fPrivilege = uPrivilege ' 1 = ACL 2 = Priv
UZDCL.Zip = uZipFileName ' ZIP Filename
UZDCL.ExtractDir = uExtractDir ' Extraction Directory, NULL If Extracting
' To Current Directory
'-- Set Callback Addresses
'-- (WARNING!!!) Do Not Change
UZUSER.UZDLLPrnt = FnPtr(AddressOf UZDLLPrnt)
UZUSER.UZDLLSND = 0& '-- Not Supported
UZUSER.UZDLLREPLACE = FnPtr(AddressOf UZDLLRep)
UZUSER.UZDLLPASSWORD = FnPtr(AddressOf UZDLLPass)
UZUSER.UZDLLMESSAGE = FnPtr(AddressOf UZReceiveDLLMessage)
UZUSER.UZDLLSERVICE = FnPtr(AddressOf UZDLLServ)
'-- Set UNZIP32.DLL Version Space
'-- (WARNING!!!) Do Not Change
With UZVER
.structlen = Len(UZVER)
.beta = Space(9) & vbNullChar
.date = Space(19) & vbNullChar
.zlib = Space(9) & vbNullChar
End With
'-- Get Version
Call UzpVersion2(UZVER)
'-- Go UnZip The Files! (Do Not Change Below!!!)
'-- This Is The Actual UnZip Routine
RetCode = Wiz_SingleEntryUnzip(uNumberFiles, uZipNames, uNumberXFiles, _
uExcludeNames, UZDCL, UZUSER)
'---------------------------------------------------------------
Select Case RetCode
Case 9
Exit Sub
End Select
End Sub
por favor eh soh o codigo de compactacao
eh um frm e um bas
frmZip_AT
'- Função - : Compactar arquivos
'-------------------------------------------------------
'strDir : Diretório de onde serão pegos os arquivos
' para compactar (Desde que <> de .OUT)
'strExt : Extensões a serem zipadas
'strNomeZip : Nome do arquivo .ZIP a ser gerado
Public Function Zip(ByVal strDir As String, ByVal strExt As String, ByVal strNomeZip As String) As Boolean
Dim intI As Integer
Dim intTentativa As Integer: intTentativa = 0
Dim strMeio As String
Zip = False
For intI = 0 To 99
zZipFileNames.zFiles(intI) = ""
Next intI
Screen.MousePointer = vbHourglass
fileZIP.Path = strDir
fileZIP.Pattern = "*." & strExt
fileZIP.Refresh
zDate = vbNullString
zJunkDir = 1 ' 1 = Throw Away Path Names
zRecurse = 0 ' 1 = Recurse -R 2 = Recurse -r 2 = Most Useful :)
zUpdate = 0 ' 1 = Update Only If Newer
zFreshen = 0 ' 1 = Freshen - Overwrite Only
zLevel = Asc(9) ' Compression Level (0 - 9)
zEncrypt = 0 ' Encryption = 1 For Password Else 0
zComment = 0 ' Comment = 1 if required
'Adicionando arquivos à  matriz...
For intI = 0 To fileZIP.ListCount - 1
'Somente adiciona à  matriz se já não for um arquivo xxxxxx.ZIP.xxx
strMeio = Mid(fileZIP.List(intI), InStr(1, fileZIP.List(intI), ".") + 1, 3)
If UCase(strMeio) <> "ZIP" Then
prLog ("Arquivo ") & fileZIP.List(intI) & " compactado"
zZipFileNames.zFiles(intI) = strDir & "\" & fileZIP.List(intI)
End If
Next intI
zArgc = fileZIP.ListCount
zRootDir = Left(App.Path, 3)
zZipFileName = strDir & "\" & strNomeZip
TentaNovamente:
intTentativa = intTentativa + 1
'Zipando...
RetCode = VBZip32
'Arquivo de Log (C:\Windows\ZipErr.LOG)
Call CodRetZIP(strNomeZip, 0)
If RetCode = 12 Then Exit Function
If RetCode <> 0 Then
If intTentativa > 3 Then
prLog ("O arquivo " & strNomeZip & " não foi Compactado. Ele será movido para o diretório 'ZipErr'")
If Dir(App.Path & "\ZipErr", vbDirectory) = "" Then
MkDir App.Path & "\ZipErr"
End If
If Dir(App.Path & "\ZipErr\" & strNomeZip, vbArchive) <> "" Then
Kill App.Path & "\ZipErr\" & strNomeZip
End If
Name strDir As App.Path & "\ZipErr\" & strNomeZip
Exit Function
Else
intTentativa = intTentativa + 1
GoTo TentaNovamente 'vai p/ linha 48
End If
Else
'Move para o Backup
If Dir(strDir & "\Backup", vbDirectory) = "" Then MkDir (strDir & "\Backup")
For intI = 0 To fileZIP.ListCount - 1
If Dir(strDir & "\Backup\" & fileZIP.List(intI), vbArchive) <> "" Then
Kill strDir & "\Backup\" & fileZIP.List(intI)
End If
Name strDir & "\" & fileZIP.List(intI) As strDir & "\Backup\" & fileZIP.List(intI)
Next intI
Zip = True
End If
Screen.MousePointer = vbNormal
End Function
'Função : Descompactar arquivos
'strArq : Caminho e Nome do arquivo .ZIP
'strDir : Diretório para onde irão os arquivos descompactados
'strNome: Nome Original do arquivo
Public Function UnZip(ByVal strArq As String, ByVal strDir As String, ByVal strNome As String)
Dim intTentativa As Integer: intTentativa = 0
lblMsg.Caption = "Descompactando " & strNome
uPromptOverWrite = 0 ' 1 = Prompt To Overwrite
uOverWriteFiles = 1 ' 1 = Always Overwrite Files
uDisplayComment = 0 ' 1 = Display comment ONLY!!!
uExtractList = 0 ' 1 = List Contents Of Zip 0 = Extract
uHonorDirectories = 0 ' 1 = Honour Zip Directories
uZipFileName = strArq 'Nome do arquivo
uExtractDir = strDir 'Diretório a gravar
If uExtractDir <> "" Then uExtractList = 0 ' unzip if dir specified
'Chama função para Descompactar
TentaNovamente: ' funcao descompactar
Call VBUnZip32
'Arquivo de Log (C:\Windows\ZipErr.LOG)
Call CodRetZIP(strNome, 1)
If RetCode <> 0 Then
If intTentativa > 3 Then
prLog ("O arquivo " & strNome & " não foi descompactado. Ele será movido para o diretório ZipErr")
If Dir(App.Path & "\ZipErr", vbDirectory) = "" Then
MkDir App.Path & "\ZipErr"
End If
If Dir(App.Path & "\ZipErr\" & strNome, vbArchive) <> "" Then
Kill App.Path & "\ZipErr\" & strNome
End If
Name strArq As App.Path & "\ZipErr\" & strNome
Exit Function
Else
intTentativa = intTentativa + 1
GoTo TentaNovamente 'vai p/ linha 111
End If
Else
'Move para o Backup
If Dir(strDir & "\BackZip", vbDirectory) = "" Then MkDir (strDir & "\BackZip")
If Dir(strDir & "\BackZip\" & strNome) <> "" Then Kill (strDir & "\BackZip\" & strNome)
' arq atual, arq copia
FileCopy strArq, strDir & "\BackZip\" & strNome
Kill strArq
End If
DoEvents
If Dir(strArq, vbArchive) <> "" Then
prLog ("Ocorreu um erro de acesso no arquivo " & strNome & "Para evitar duplicidades o processamento será finalizado!")
MsgBox "Ocorreu um erro de acesso no arquivo " & strNome & vbCrLf & "Para evitar duplicidades o processamento será finalizado!", vbCritical, App.Title
End
End If
Screen.MousePointer = vbNormal
End Function
'Sub CodRetZIP (Código de Retorno ZIP)
'Função : Retornar uma String de acordo com o código retornado
' pela função de ZIP
Private Sub CodRetZIP(ByVal NomeArq As String, ByVal Funcao As Integer)
If Funcao = 0 Then
prLog ("Compactação de " & NomeArq)
Else
prLog ("Descompactação de " & NomeArq)
End If
Select Case RetCode
Case 0 ' Sucesso (Não houveram erros)
If Funcao = 0 Then
prLog ("Arquivo Compactado com Sucesso")
Else
prLog ("Arquivo descompactado com Sucesso")
End If
Case 1
'Não encontrei este número de erro
Exit Sub
Case 2 ' Fim inesperado de arquivo ZIP
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Fim Inesperado de arquivo .ZIP")
Case 3 ' Erro na estrutura do arquivo ZIP
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Erro na estrutura do arquivo ZIP")
Case 4 ' Falta de memória disponÃvel
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Falta de memória disponÃvel (Out of Memory)")
Case 5 ' Erro Interno
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Erro Interno do procedimento (DLL)")
Case 6 ' Entrada muito grande para (separar/dividir) o erro
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Entrada muito grande para isolar o erro. Erro não identificado")
Case 7 ' Formato de Comentário Inválido
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Formato de Comentário Inválido")
Case 8 ' Falha no teste do Zip (- T) ou falta de memória disponÃvel
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Falha no teste do Zip (- T) ou falta de memória disponÃvel")
Case 9 ' Interrompido pelo usuário
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Interrompido pelo usuário")
Case 10 ' Erro ao usar arquivo temporário
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Erro ao usar arquivo temporário")
Case 11 ' Erro de Leitura ou Pesquisa
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Erro de Leitura ou Pesquisa")
Case 12 ' Sem função (Nenhum arquivo a ser compactado)
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Sem função (Nenhum arquivo a ser compactado/descompactado)")
Case 13 ' Arquivo ZIP vazio ou não encontrado
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Arquivo ZIP vazio ou não encontrado")
Case 14 ' Erro ao gravar o arquivo
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Erro ao gravar o arquivo")
Case 15 ' Erro na abertura do arquivo para Gravação
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Erro na abertura do arquivo para Gravação")
Case 16 ' Linha de Comando Errada ou Inválida
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Linha de Comando Errada ou Inválida")
Case 17
'Não encontrei este número de erro !!!
Exit Sub
Case 18 ' Erro na abertura de um arquivo especificado para leitura
prLog ("Erro encontrado : " & Now())
prLog ("Código de Retorno ==> " & RetCode)
prLog ("Descrição ==> Erro na abertura de um arquivo especificado para leitura")
End Select
prLog (Space(70))
End Sub
basZip
Option Explicit
'************** ZIP DECLARAÇÕES *********************
Public RetCode As Long
'-- Holds The Zip Archive Filenames
Public Type ZIPnames
zFiles(0 To 99) As String
End Type
'-- Call Back "String"
Public Type ZipCBChar
ch(4096) As Byte
End Type
'-- ZPOPT Is Used To Set The Options In The ZIP32.DLL
Public Type ZPOPT
date As String ' US Date (8 Bytes Long) "12/31/98"?
szRootDir As String ' Root Directory Pathname (Up To 256 Bytes Long)
szTempDir As String ' Temp Directory Pathname (Up To 256 Bytes Long)
fTemp As Long ' 1 If Temp dir Wanted, Else 0
fSuffix As Long ' Include Suffixes (Not Yet Implemented!)
fEncrypt As Long ' 1 If Encryption Wanted, Else 0
fSystem As Long ' 1 To Include System/Hidden Files, Else 0
fVolume As Long ' 1 If Storing Volume Label, Else 0
fExtra As Long ' 1 If Excluding Extra Attributes, Else 0
fNoDirEntries As Long ' 1 If Ignoring Directory Entries, Else 0
fExcludeDate As Long ' 1 If Excluding Files Earlier Than Specified Date, Else 0
fIncludeDate As Long ' 1 If Including Files Earlier Than Specified Date, Else 0
fVerbose As Long ' 1 If Full Messages Wanted, Else 0
fQuiet As Long ' 1 If Minimum Messages Wanted, Else 0
fCRLF_LF As Long ' 1 If Translate CR/LF To LF, Else 0
fLF_CRLF As Long ' 1 If Translate LF To CR/LF, Else 0
fJunkDir As Long ' 1 If Junking Directory Names, Else 0
fGrow As Long ' 1 If Allow Appending To Zip File, Else 0
fForce As Long ' 1 If Making Entries Using DOS File Names, Else 0
fMove As Long ' 1 If Deleting Files Added Or Updated, Else 0
fDeleteEntries As Long ' 1 If Files Passed Have To Be Deleted, Else 0
fUpdate As Long ' 1 If Updating Zip File-Overwrite Only If Newer, Else 0
fFreshen As Long ' 1 If Freshing Zip File-Overwrite Only, Else 0
fJunkSFX As Long ' 1 If Junking SFX Prefix, Else 0
fLatestTime As Long ' 1 If Setting Zip File Time To Time Of Latest File In Archive, Else 0
fComment As Long ' 1 If Putting Comment In Zip File, Else 0
fOffsets As Long ' 1 If Updating Archive Offsets For SFX Files, Else 0
fPrivilege As Long ' 1 If Not Saving Privileges, Else 0
fEncryption As Long ' Read Only Property!!!
fRecurse As Long ' 1 (-r), 2 (-R) If Recursing Into Sub-Directories, Else 0
fRepair As Long ' 1 = Fix Archive, 2 = Try Harder To Fix, Else 0
flevel As Byte ' Compression Level - 0 = Stored 6 = Default 9 = Max
End Type
'-- This Structure Is Used For The ZIP32.DLL Function Callbacks
Public Type ZIPUSERFUNCTIONS
ZDLLPrnt As Long ' Callback ZIP32.DLL Print Function
ZDLLCOMMENT As Long ' Callback ZIP32.DLL Comment Function
ZDLLPASSWORD As Long ' Callback ZIP32.DLL Password Function
ZDLLSERVICE As Long ' Callback ZIP32.DLL Service Function
End Type
'-- Local Declarations
Public ZOPT As ZPOPT
Public ZUSER As ZIPUSERFUNCTIONS
'-- This Assumes ZIP32.DLL Is In Your \Windows\System Directory!
'-- (alternatively, a copy of ZIP32.DLL needs to be located in the program
'-- directory or in some other directory listed in the PATH.)
Private Declare Function ZpInit Lib "zip32.dll" _
(ByRef Zipfun As ZIPUSERFUNCTIONS) As Long '-- Set Zip Callbacks
Private Declare Function ZpSetOptions Lib "zip32.dll" _
(ByRef Opts As ZPOPT) As Long '-- Set Zip Options
Private Declare Function ZpGetOptions Lib "zip32.dll" _
() As ZPOPT '-- Used To Check Encryption Flag Only
Private Declare Function ZpArchive Lib "zip32.dll" _
(ByVal argc As Long, ByVal funame As String, _
ByRef argv As ZIPnames) As Long '-- Real Zipping Action
'-------------------------------------------------------
'-- Public Variables For Setting The ZPOPT Structure...
'-- (WARNING!!!) You Must Set The Options That You
'-- Want The ZIP32.DLL To Do!
'-- Before Calling VBZip32!
'-------------------------------------------------------
Public zDate As String
Public zRootDir As String
Public zTempDir As String
Public zSuffix As Integer
Public zEncrypt As Integer
Public zSystem As Integer
Public zVolume As Integer
Public zExtra As Integer
Public zNoDirEntries As Integer
Public zExcludeDate As Integer
Public zIncludeDate As Integer
Public zVerbose As Integer
Public zQuiet As Integer
Public zCRLF_LF As Integer
Public zLF_CRLF As Integer
Public zJunkDir As Integer
Public zRecurse As Integer
Public zGrow As Integer
Public zForce As Integer
Public zMove As Integer
Public zDelEntries As Integer
Public zUpdate As Integer
Public zFreshen As Integer
Public zJunkSFX As Integer
Public zLatestTime As Integer
Public zComment As Integer
Public zOffsets As Integer
Public zPrivilege As Integer
Public zEncryption As Integer
Public zRepair As Integer
Public zLevel As Integer
'-- Public Program Variables
Public zArgc As Integer ' Number Of Files To Zip Up
Public zZipFileName As String ' The Zip File Name ie: Myzip.zip
Public zZipFileNames As ZIPnames ' File Names To Zip Up
Public zZipInfo As String ' Holds The Zip File Information
'-- Public Constants
'-- For Zip & UnZip Error Codes!
Public Const ZE_OK = 0 ' Success (No Error)
Public Const ZE_EOF = 2 ' Unexpected End Of Zip File Error
Public Const ZE_FORM = 3 ' Zip File Structure Error
Public Const ZE_MEM = 4 ' Out Of Memory Error
Public Const ZE_LOGIC = 5 ' Internal Logic Error
Public Const ZE_BIG = 6 ' Entry Too Large To Split Error
Public Const ZE_NOTE = 7 ' Invalid Comment Format Error
Public Const ZE_TEST = 8 ' Zip Test (-T) Failed Or Out Of Memory Error
Public Const ZE_ABORT = 9 ' User Interrupted Or Termination Error
Public Const ZE_TEMP = 10 ' Error Using A Temp File
Public Const ZE_READ = 11 ' Read Or Seek Error
Public Const ZE_NONE = 12 ' Nothing To Do Error
Public Const ZE_NAME = 13 ' Missing Or Empty Zip File Error
Public Const ZE_WRITE = 14 ' Error Writing To A File
Public Const ZE_CREAT = 15 ' Could't Open To Write Error
Public Const ZE_PARMS = 16 ' Bad Command Line Argument Error
Public Const ZE_OPEN = 18 ' Could Not Open A Specified File To Read Error
'***************** UNZIP DECLARAÇÕES ***********************
'-- C Style argv
Private Type UNZIPnames
uzFiles(0 To 99) As String
End Type
'-- Callback Large "String"
Private Type UNZIPCBChar
ch(32800) As Byte
End Type
'-- Callback Small "String"
Private Type UNZIPCBCh
ch(256) As Byte
End Type
'-- UNZIP32.DLL DCL Structure
Private Type DCLIST
ExtractOnlyNewer As Long ' 1 = Extract Only Newer, Else 0
SpaceToUnderscore As Long ' 1 = Convert Space To Underscore, Else 0
PromptToOverwrite As Long ' 1 = Prompt To Overwrite Required, Else 0
fQuiet As Long ' 2 = No Messages, 1 = Less, 0 = All
ncflag As Long ' 1 = Write To Stdout, Else 0
ntflag As Long ' 1 = Test Zip File, Else 0
nvflag As Long ' 0 = Extract, 1 = List Zip Contents
nUflag As Long ' 1 = Extract Only Newer, Else 0
nzflag As Long ' 1 = Display Zip File Comment, Else 0
ndflag As Long ' 1 = Honor Directories, Else 0
noflag As Long ' 1 = Overwrite Files, Else 0
naflag As Long ' 1 = Convert CR To CRLF, Else 0
nZIflag As Long ' 1 = Zip Info Verbose, Else 0
C_flag As Long ' 1 = Case Insensitivity, 0 = Case Sensitivity
fPrivilege As Long ' 1 = ACL, 2 = Privileges
Zip As String ' The Zip Filename To Extract Files
ExtractDir As String ' The Extraction Directory, NULL If Extracting To Current Dir
End Type
'-- UNZIP32.DLL Userfunctions Structure
Private Type USERFUNCTION
UZDLLPrnt As Long ' Pointer To Apps Print Function
UZDLLSND As Long ' Pointer To Apps Sound Function
UZDLLREPLACE As Long ' Pointer To Apps Replace Function
UZDLLPASSWORD As Long ' Pointer To Apps Password Function
UZDLLMESSAGE As Long ' Pointer To Apps Message Function
UZDLLSERVICE As Long ' Pointer To Apps Service Function (Not Coded!)
TotalSizeComp As Long ' Total Size Of Zip Archive
TotalSize As Long ' Total Size Of All Files In Archive
CompFactor As Long ' Compression Factor
NumMembers As Long ' Total Number Of All Files In The Archive
cchComment As Integer ' Flag If Archive Has A Comment!
End Type
'-- UNZIP32.DLL Version Structure
Private Type UZPVER
structlen As Long ' Length Of The Structure Being Passed
flag As Long ' Bit 0: is_beta bit 1: uses_zlib
beta As String * 10 ' e.g., "g BETA" or ""
date As String * 20 ' e.g., "4 Sep 95" (beta) or "4 September 1995"
zlib As String * 10 ' e.g., "1.0.5" or NULL
UnZip(1 To 4) As Byte ' Version Type Unzip
zipinfo(1 To 4) As Byte ' Version Type Zip Info
os2dll As Long ' Version Type OS2 DLL
windll(1 To 4) As Byte ' Version Type Windows DLL
End Type
'-- This Assumes UNZIP32.DLL Is In Your \Windows\System Directory!
Private Declare Function Wiz_SingleEntryUnzip Lib "unzip32.dll" _
(ByVal ifnc As Long, ByRef ifnv As UNZIPnames, _
ByVal xfnc As Long, ByRef xfnv As UNZIPnames, _
dcll As DCLIST, Userf As USERFUNCTION) As Long
Private Declare Sub UzpVersion2 Lib "unzip32.dll" (uzpv As UZPVER)
'-- Private Variables For Structure Access
Private UZDCL As DCLIST
Private UZUSER As USERFUNCTION
Private UZVER As UZPVER
'-- Public Variables For Setting The
'-- UNZIP32.DLL DCLIST Structure
'-- These Must Be Set Before The Actual Call To VBUnZip32
Public uExtractNewer As Integer ' 1 = Extract Only Newer, Else 0
Public uSpaceUnderScore As Integer ' 1 = Convert Space To Underscore, Else 0
Public uPromptOverWrite As Integer ' 1 = Prompt To Overwrite Required, Else 0
Public uQuiet As Integer ' 2 = No Messages, 1 = Less, 0 = All
Public uWriteStdOut As Integer ' 1 = Write To Stdout, Else 0
Public uTestZip As Integer ' 1 = Test Zip File, Else 0
Public uExtractList As Integer ' 0 = Extract, 1 = List Contents
Public uExtractOnlyNewer As Integer ' 1 = Extract Only Newer, Else 0
Public uDisplayComment As Integer ' 1 = Display Zip File Comment, Else 0
Public uHonorDirectories As Integer ' 1 = Honor Directories, Else 0
Public uOverWriteFiles As Integer ' 1 = Overwrite Files, Else 0
Public uConvertCR_CRLF As Integer ' 1 = Convert CR To CRLF, Else 0
Public uVerbose As Integer ' 1 = Zip Info Verbose
Public uCaseSensitivity As Integer ' 1 = Case Insensitivity, 0 = Case Sensitivity
Public uPrivilege As Integer ' 1 = ACL, 2 = Privileges, Else 0
Public uZipFileName As String ' The Zip File Name
Public uExtractDir As String ' Extraction Directory, Null If Current Directory
'-- Public Program Variables
Public uZipNumber As Long ' Zip File Number
Public uNumberFiles As Long ' Number Of Files
Public uNumberXFiles As Long ' Number Of Extracted Files
Public uZipMessage As String ' For Zip Message
Public uZipInfo As String ' For Zip Information
Public uZipNames As UNZIPnames ' Names Of Files To Unzip
Public uExcludeNames As UNZIPnames ' Names Of Zip Files To Exclude
Public uVbSkip As Integer ' For DLL Password Function
'-- These Functions Are For The ZIP32.DLL
'--
'-- Puts A Function Pointer In A Structure
'-- For Use With Callbacks...
Public Function FnPtr(ByVal lp As Long) As Long
FnPtr = lp
End Function
'-- Callback For ZIP32.DLL - DLL Print Function
Public Function ZDLLPrnt(ByRef fname As ZipCBChar, ByVal x As Long) As Long
Dim s0 As String
Dim xx As Long
'-- Always Put This In Callback Routines!
On Error Resume Next
s0 = ""
'-- Get Zip32.DLL Message For processing
For xx = 0 To x
If fname.ch(xx) = 0 Then
Exit For
Else
s0 = s0 + Chr(fname.ch(xx))
End If
Next
DoEvents
ZDLLPrnt = 0
End Function
'-- Callback For ZIP32.DLL - DLL Service Function
Public Function ZDLLServ(ByRef mname As ZipCBChar, ByVal x As Long) As Long
Dim s0 As String
Dim xx As Long
'-- Always Put This In Callback Routines!
On Error Resume Next
s0 = ""
'-- Get Zip32.DLL Message For processing
For xx = 0 To x
If mname.ch(xx) = 0 Then
Exit For
Else
s0 = s0 + Chr(mname.ch(xx))
End If
Next
' At this point, s0 contains the message passed from the DLL
' It is up to the developer to code something useful here :)
ZDLLServ = 0 ' Setting this to 1 will abort the zip!
End Function
'-- Callback For ZIP32.DLL - DLL Password Function
Public Function ZDLLPass(ByRef p As ZipCBChar, _
ByVal n As Long, ByRef m As ZipCBChar, _
ByRef Name As ZipCBChar) As Integer
Dim prompt As String
Dim xx As Integer
Dim szpassword As String
'-- Always Put This In Callback Routines!
On Error Resume Next
ZDLLPass = 1
'-- If There Is A Password Have The User Enter It!
'-- This Can Be Changed
szpassword = InputBox("Please Enter The Password!")
'-- The User Did Not Enter A Password So Exit The Function
If szpassword = "" Then Exit Function
'-- User Entered A Password So Proccess It
For xx = 0 To 255
If m.ch(xx) = 0 Then
Exit For
Else
prompt = prompt & Chr(m.ch(xx))
End If
Next
For xx = 0 To n - 1
p.ch(xx) = 0
Next
For xx = 0 To Len(szpassword) - 1
p.ch(xx) = Asc(Mid(szpassword, xx + 1, 1))
Next
p.ch(xx) = Chr(0) ' Put Null Terminator For C
ZDLLPass = 0
End Function
'-- Callback For ZIP32.DLL - DLL Comment Function
Public Function ZDLLComm(ByRef s1 As ZipCBChar) As Integer
Dim xx%, szcomment$
'-- Always Put This In Callback Routines!
On Error Resume Next
ZDLLComm = 1
szcomment = InputBox("Enter the comment")
If szcomment = "" Then Exit Function
For xx = 0 To Len(szcomment) - 1
s1.ch(xx) = Asc(Mid$(szcomment, xx + 1, 1))
Next xx
s1.ch(xx) = Chr(0) ' Put null terminator for C
End Function
'-- Main ZIP32.DLL Subroutine.
Public Function VBZip32() As Long
On Error Resume Next
RetCode = 0
'-- Set Address Of ZIP32.DLL Callback Functions
ZUSER.ZDLLPrnt = FnPtr(AddressOf ZDLLPrnt)
ZUSER.ZDLLPASSWORD = FnPtr(AddressOf ZDLLPass)
ZUSER.ZDLLCOMMENT = FnPtr(AddressOf ZDLLComm)
ZUSER.ZDLLSERVICE = FnPtr(AddressOf ZDLLServ)
'-- Set ZIP32.DLL Callbacks
RetCode = ZpInit(ZUSER)
'-- Setup ZIP32 Options
ZOPT.date = zDate ' "12/31/79"? US Date?
ZOPT.szRootDir = zRootDir ' Root Directory Pathname
ZOPT.szTempDir = zTempDir ' Temp Directory Pathname
ZOPT.fSuffix = zSuffix ' Include Suffixes (Not Yet Implemented)
ZOPT.fEncrypt = zEncrypt ' 1 If Encryption Wanted
ZOPT.fSystem = zSystem ' 1 To Include System/Hidden Files
ZOPT.fVolume = zVolume ' 1 If Storing Volume Label
ZOPT.fExtra = zExtra ' 1 If Including Extra Attributes
ZOPT.fNoDirEntries = zNoDirEntries ' 1 If Ignoring Directory Entries
ZOPT.fExcludeDate = zExcludeDate ' 1 If Excluding Files Earlier Than A Specified Date
ZOPT.fIncludeDate = zIncludeDate ' 1 If Including Files Earlier Than A Specified Date
ZOPT.fVerbose = zVerbose ' 1 If Full Messages Wanted
ZOPT.fQuiet = zQuiet ' 1 If Minimum Messages Wanted
ZOPT.fCRLF_LF = zCRLF_LF ' 1 If Translate CR/LF To LF
ZOPT.fLF_CRLF = zLF_CRLF ' 1 If Translate LF To CR/LF
ZOPT.fJunkDir = zJunkDir ' 1 If Junking Directory Names
ZOPT.fGrow = zGrow ' 1 If Allow Appending To Zip File
ZOPT.fForce = zForce ' 1 If Making Entries Using DOS Names
ZOPT.fMove = zMove ' 1 If Deleting Files Added Or Updated
ZOPT.fDeleteEntries = zDelEntries ' 1 If Files Passed Have To Be Deleted
ZOPT.fUpdate = zUpdate ' 1 If Updating Zip File-Overwrite Only If Newer
ZOPT.fFreshen = zFreshen ' 1 If Freshening Zip File-Overwrite Only
ZOPT.fJunkSFX = zJunkSFX ' 1 If Junking SFX Prefix
ZOPT.fLatestTime = zLatestTime ' 1 If Setting Zip File Time To Time Of Latest File In Archive
ZOPT.fComment = zComment ' 1 If Putting Comment In Zip File
ZOPT.fOffsets = zOffsets ' 1 If Updating Archive Offsets For SFX Files
ZOPT.fPrivilege = zPrivilege ' 1 If Not Saving Privelages
ZOPT.fEncryption = zEncryption ' Read Only Property!
ZOPT.fRecurse = zRecurse ' 1 or 2 If Recursing Into Subdirectories
ZOPT.fRepair = zRepair ' 1 = Fix Archive, 2 = Try Harder To Fix
ZOPT.flevel = zLevel ' Compression Level - (0 To 9) Should Be 0!!!
'-- Set ZIP32.DLL Options
RetCode = ZpSetOptions(ZOPT)
'-- Go Zip It Them Up!
RetCode = ZpArchive(zArgc, zZipFileName, zZipFileNames)
'-- Return The Function Code
VBZip32 = RetCode
End Function
'-- Callback For UNZIP32.DLL - Receive Message Function
Public Sub UZReceiveDLLMessage(ByVal ucsize As Long, _
ByVal csiz As Long, _
ByVal cfactor As Integer, _
ByVal mo As Integer, _
ByVal dy As Integer, _
ByVal yr As Integer, _
ByVal hh As Integer, _
ByVal mm As Integer, _
ByVal c As Byte, ByRef fname As UNZIPCBCh, _
ByRef meth As UNZIPCBCh, ByVal crc As Long, _
ByVal fCrypt As Byte)
Dim s0 As String
Dim xx As Long
Dim strout As String * 80
'-- Always Put This In Callback Routines!
On Error Resume Next
'------------------------------------------------
'-- This Is Where The Received Messages Are
'-- Printed Out And Displayed.
'-- You Can Modify Below!
'------------------------------------------------
strout = Space(80)
'-- For Zip Message Printing
If uZipNumber = 0 Then
Mid(strout, 1, 50) = "Filename:"
Mid(strout, 53, 4) = "Size"
Mid(strout, 62, 4) = "Date"
Mid(strout, 71, 4) = "Time"
uZipMessage = strout & vbNewLine
strout = Space(80)
End If
s0 = ""
'-- Do Not Change This For Next!!!
For xx = 0 To 255
If fname.ch(xx) = 0 Then Exit For
s0 = s0 & Chr(fname.ch(xx))
Next
'-- Assign Zip Information For Printing
Mid(strout, 1, 50) = Mid(s0, 1, 50)
Mid(strout, 51, 7) = Right(" " & Str(ucsize), 7)
Mid(strout, 60, 3) = Right("0" & Trim(Str(mo)), 2) & "/"
Mid(strout, 63, 3) = Right("0" & Trim(Str(dy)), 2) & "/"
Mid(strout, 66, 2) = Right("0" & Trim(Str(yr)), 2)
Mid(strout, 70, 3) = Right(Str(hh), 2) & ":"
Mid(strout, 73, 2) = Right("0" & Trim(Str(mm)), 2)
'-- Do Not Modify Below!!!
uZipMessage = uZipMessage & strout & vbNewLine
uZipNumber = uZipNumber + 1
End Sub
'-- Callback For UNZIP32.DLL - Print Message Function
Public Function UZDLLPrnt(ByRef fname As UNZIPCBChar, ByVal x As Long) As Long
Dim s0 As String
Dim xx As Long
'-- Always Put This In Callback Routines!
On Error Resume Next
s0 = ""
'-- Gets The UNZIP32.DLL Message For Displaying.
For xx = 0 To x - 1
If fname.ch(xx) = 0 Then Exit For
s0 = s0 & Chr(fname.ch(xx))
Next
'-- Assign Zip Information
If Mid$(s0, 1, 1) = vbLf Then s0 = vbNewLine ' Damn UNIX :-)
uZipInfo = uZipInfo & s0
UZDLLPrnt = 0
End Function
'-- Callback For UNZIP32.DLL - DLL Service Function
Public Function UZDLLServ(ByRef mname As UNZIPCBChar, ByVal x As Long) As Long
Dim s0 As String
Dim xx As Long
'-- Always Put This In Callback Routines!
On Error Resume Next
s0 = ""
'-- Get Zip32.DLL Message For processing
For xx = 0 To x - 1
If mname.ch(xx) = 0 Then Exit For
s0 = s0 + Chr(mname.ch(xx))
Next
' At this point, s0 contains the message passed from the DLL
' It is up to the developer to code something useful here :)
UZDLLServ = 0 ' Setting this to 1 will abort the zip!
End Function
'-- Callback For UNZIP32.DLL - Password Function
Public Function UZDLLPass(ByRef p As UNZIPCBCh, _
ByVal n As Long, ByRef m As UNZIPCBCh, _
ByRef Name As UNZIPCBCh) As Integer
Dim prompt As String
Dim xx As Integer
Dim szpassword As String
'-- Always Put This In Callback Routines!
On Error Resume Next
UZDLLPass = 1
If uVbSkip = 1 Then Exit Function
'-- Get The Zip File Password
szpassword = InputBox("Please Enter The Password!")
'-- No Password So Exit The Function
If szpassword = "" Then
uVbSkip = 1
Exit Function
End If
'-- Zip File Password So Process It
For xx = 0 To 255
If m.ch(xx) = 0 Then
Exit For
Else
prompt = prompt & Chr(m.ch(xx))
End If
Next
For xx = 0 To n - 1
p.ch(xx) = 0
Next
For xx = 0 To Len(szpassword) - 1
p.ch(xx) = Asc(Mid(szpassword, xx + 1, 1))
Next
p.ch(xx) = Chr(0) ' Put Null Terminator For C
UZDLLPass = 0
End Function
'-- Callback For UNZIP32.DLL - Report Function To Overwrite Files.
'-- This Function Will Display A MsgBox Asking The User
'-- If They Would Like To Overwrite The Files.
Public Function UZDLLRep(ByRef fname As UNZIPCBChar) As Long
Dim s0 As String
Dim xx As Long
'-- Always Put This In Callback Routines!
On Error Resume Next
UZDLLRep = 100 ' 100 = Do Not Overwrite - Keep Asking User
s0 = ""
For xx = 0 To 255
If fname.ch(xx) = 0 Then xx = 99999 Else s0 = s0 & Chr(fname.ch(xx))
Next
'-- This Is The MsgBox Code
xx = MsgBox("Overwrite " & s0 & "?", vbExclamation & vbYesNoCancel, _
"VBUnZip32 - File Already Exists!")
If xx = vbNo Then Exit Function
If xx = vbCancel Then
UZDLLRep = 104 ' 104 = Overwrite None
Exit Function
End If
UZDLLRep = 102 ' 102 = Overwrite 103 = Overwrite All
End Function
'-- ASCIIZ To String Function
Public Function szTrim(szString As String) As String
Dim pos As Integer
Dim ln As Integer
pos = InStr(szString, Chr(0))
ln = Len(szString)
Select Case pos
Case Is > 1
szTrim = Trim(Left(szString, pos - 1))
Case 1
szTrim = ""
Case Else
szTrim = Trim(szString)
End Select
End Function
'-- Main UNZIP32.DLL UnZip32 Subroutine
'-- (WARNING!) Do Not Change!
Public Sub VBUnZip32()
Dim MsgStr As String
'-- Set The UNZIP32.DLL Options
'-- (WARNING!) Do Not Change
UZDCL.ExtractOnlyNewer = uExtractNewer ' 1 = Extract Only Newer
UZDCL.SpaceToUnderscore = uSpaceUnderScore ' 1 = Convert Space To Underscore
UZDCL.PromptToOverwrite = uPromptOverWrite ' 1 = Prompt To Overwrite Required
UZDCL.fQuiet = uQuiet ' 2 = No Messages 1 = Less 0 = All
UZDCL.ncflag = uWriteStdOut ' 1 = Write To Stdout
UZDCL.ntflag = uTestZip ' 1 = Test Zip File
UZDCL.nvflag = uExtractList ' 0 = Extract 1 = List Contents
UZDCL.nUflag = uExtractOnlyNewer ' 1 = Extract Only Newer
UZDCL.nzflag = uDisplayComment ' 1 = Display Zip File Comment
UZDCL.ndflag = uHonorDirectories ' 1 = Honour Directories
UZDCL.noflag = uOverWriteFiles ' 1 = Overwrite Files
UZDCL.naflag = uConvertCR_CRLF ' 1 = Convert CR To CRLF
UZDCL.nZIflag = uVerbose ' 1 = Zip Info Verbose
UZDCL.C_flag = uCaseSensitivity ' 1 = Case insensitivity, 0 = Case Sensitivity
UZDCL.fPrivilege = uPrivilege ' 1 = ACL 2 = Priv
UZDCL.Zip = uZipFileName ' ZIP Filename
UZDCL.ExtractDir = uExtractDir ' Extraction Directory, NULL If Extracting
' To Current Directory
'-- Set Callback Addresses
'-- (WARNING!!!) Do Not Change
UZUSER.UZDLLPrnt = FnPtr(AddressOf UZDLLPrnt)
UZUSER.UZDLLSND = 0& '-- Not Supported
UZUSER.UZDLLREPLACE = FnPtr(AddressOf UZDLLRep)
UZUSER.UZDLLPASSWORD = FnPtr(AddressOf UZDLLPass)
UZUSER.UZDLLMESSAGE = FnPtr(AddressOf UZReceiveDLLMessage)
UZUSER.UZDLLSERVICE = FnPtr(AddressOf UZDLLServ)
'-- Set UNZIP32.DLL Version Space
'-- (WARNING!!!) Do Not Change
With UZVER
.structlen = Len(UZVER)
.beta = Space(9) & vbNullChar
.date = Space(19) & vbNullChar
.zlib = Space(9) & vbNullChar
End With
'-- Get Version
Call UzpVersion2(UZVER)
'-- Go UnZip The Files! (Do Not Change Below!!!)
'-- This Is The Actual UnZip Routine
RetCode = Wiz_SingleEntryUnzip(uNumberFiles, uZipNames, uNumberXFiles, _
uExcludeNames, UZDCL, UZUSER)
'---------------------------------------------------------------
Select Case RetCode
Case 9
Exit Sub
End Select
End Sub
por favor eh soh o codigo de compactacao
Não entendi a tua dúvida?
Você que explica a codificação linha por linha?
Você que explica a codificação linha por linha?
Ele usa a DLL zip32.dll
'-- This Assumes ZIP32.DLL Is In Your \Windows\System Directory!
'-- (alternatively, a copy of ZIP32.DLL needs to be located in the program
'-- directory or in some other directory listed in the PATH.)
Private Declare Function ZpInit Lib "zip32.dll" _
(ByRef Zipfun As ZIPUSERFUNCTIONS) As Long '-- Set Zip Callbacks
Private Declare Function ZpSetOptions Lib "zip32.dll" _
(ByRef Opts As ZPOPT) As Long '-- Set Zip Options
Private Declare Function ZpGetOptions Lib "zip32.dll" _
() As ZPOPT '-- Used To Check Encryption Flag Only
Private Declare Function ZpArchive Lib "zip32.dll" _
(ByVal argc As Long, ByVal funame As String, _
ByRef argv As ZIPnames) As Long '-- Real Zipping Action
'-- This Assumes ZIP32.DLL Is In Your \Windows\System Directory!
'-- (alternatively, a copy of ZIP32.DLL needs to be located in the program
'-- directory or in some other directory listed in the PATH.)
Private Declare Function ZpInit Lib "zip32.dll" _
(ByRef Zipfun As ZIPUSERFUNCTIONS) As Long '-- Set Zip Callbacks
Private Declare Function ZpSetOptions Lib "zip32.dll" _
(ByRef Opts As ZPOPT) As Long '-- Set Zip Options
Private Declare Function ZpGetOptions Lib "zip32.dll" _
() As ZPOPT '-- Used To Check Encryption Flag Only
Private Declare Function ZpArchive Lib "zip32.dll" _
(ByVal argc As Long, ByVal funame As String, _
ByRef argv As ZIPnames) As Long '-- Real Zipping Action
Tópico encerrado , respostas não são mais permitidas