** NORMAS DEL FORO **
Inicio del foro Inicio del foro > Access y VBA > Access y VBA
  Mensajes nuevos Mensajes nuevos RSS - Comprimir varios archivos a un ZIP
  Preguntas frecuentes Preguntas frecuentes  Buscar en el foro   Eventos   Registro Registro  Iniciar sesion Iniciar sesion

Tema cerradoComprimir varios archivos a un ZIP

 Responder Responder
Autor
Mensaje
orafo1 Ver desplegable
Asiduo
Asiduo


Unido: 18/Junio/2010
Localización: Colombia
Estado: Sin conexión
Puntos: 304
Enlace directo a este mensaje Tema: Comprimir varios archivos a un ZIP
    Enviado: 24/Julio/2020 a las 01:49
Buenas noches compañeros tengo un software desarrollado en Access, con módulos, informes, formularios y tablas vinculadas, deseo Comprimir varios archivos a un ZIP desde código me podrian por favor ayudar con este tema
Siempre algo nuevo por aprender
Arriba
rokoko Ver desplegable
Colaborador
Colaborador
Avatar

Unido: 16/Febrero/2008
Localización: Pamplona
Estado: Sin conexión
Puntos: 3062
Enlace directo a este mensaje Enviado: 24/Julio/2020 a las 07:27
Arriba
rokoko Ver desplegable
Colaborador
Colaborador
Avatar

Unido: 16/Febrero/2008
Localización: Pamplona
Estado: Sin conexión
Puntos: 3062
Enlace directo a este mensaje Enviado: 25/Julio/2020 a las 17:19
Arriba
orafo1 Ver desplegable
Asiduo
Asiduo


Unido: 18/Junio/2010
Localización: Colombia
Estado: Sin conexión
Puntos: 304
Enlace directo a este mensaje Enviado: 23/Septiembre/2020 a las 01:01
Por favor podemos cerrar el hilo el codigo que funciona es el siguiente

La solucion para Access 2003 fue la siguiente:
Crear modulo de clase

Option Explicit
'
'
' Chris Eastwood July 1999 - adapted from code at the
' InfoZip homepage.
'
Public Enum ZTranslate
    CRLFtoLF = 1
    LFtoCRLF = 2
End Enum
'
' Collection of Files to Zip
'
Private mCollection As Collection
'
' Recurse Folders ?
'
Private miRecurseFolders As Integer
'
' Zip File Name
'
Private msZipFileName As String
'
' Encryption ?
'
Private miEncrypt As Integer
'
' System Files
'
Private miSystem As Integer
'
' Root Directory
'
Private msRootDirectory As String
'
' Quiet Zip
'
Private miQuiet As Integer
'
' Updating Existing Zip ?
'
Private miUpdateZip As Integer

Private Sub Class_Initialize()
'
' Initialise the collection
'
    Set mCollection = New Collection
'
' We have to add in a dummy file into the collection because
' the Zip routines fall over otherwise.
'
' I think this is a bug, but it's not documented anywhere
' on the InfoZip website.
'
' The Zip process *always* fails on the first file,
' regardless of whether it's a valid file or not!
'
    mCollection.Add "querty", "querty"
    miEncrypt = 0
    miSystem = 0
    msRootDirectory = "\"
    miQuiet = 0
    miUpdateZip = 0
    
End Sub

Private Sub Class_Terminate()
'
' Terminate the collection
'
    Set mCollection = Nothing
End Sub

Public Property Get RecurseFolders() As Boolean
    RecurseFolders = miRecurseFolders = 1
End Property

Public Property Let RecurseFolders(ByVal bRecurse As Boolean)
    miRecurseFolders = IIf(bRecurse, 1, 0)
End Property

Public Property Get ZipFileName() As String
    ZipFileName = msZipFileName
End Property

Public Property Let ZipFileName(ByVal sZipFileName As String)
    msZipFileName = sZipFileName '& vbNullChar
End Property

Public Property Get Encrypted() As Boolean
    Encrypted = miEncrypt = 1
End Property

Public Property Let Encrypted(ByVal bEncrypt As Boolean)
    miEncrypt = IIf(bEncrypt, 1, 0)
End Property

Public Property Get IncludeSystemFiles() As Boolean
    IncludeSystemFiles = miSystem = 1
End Property

Public Property Let IncludeSystemFiles(ByVal bInclude As Boolean)
    miSystem = IIf(bInclude, 1, 0)
End Property

Public Property Get ZipFileCount() As Long
    If mCollection Is Nothing Then
        ZipFileCount = 0
    Else
        ZipFileCount = mCollection.Count - 1
    End If
End Property


Public Property Get RootDirectory() As String
    RootDirectory = msRootDirectory
End Property

Public Property Let RootDirectory(ByVal sRootDir As String)
    msRootDirectory = sRootDir ' & vbNullChar
End Property

Public Property Get UpdatingZip() As Boolean
    UpdatingZip = miUpdateZip = 1
End Property

Public Property Let UpdatingZip(ByVal bUpdating As Boolean)
    miUpdateZip = IIf(bUpdating, 1, 0)
End Property

Public Function AddFile(ByVal sFileName As String)
    Dim sFile As String
    
    On Error Resume Next
    
    sFile = mCollection.Item(sFileName)
    
    If Len(sFile) = 0 Then
        Err.Clear
        On Error GoTo 0
        mCollection.Add sFileName, sFileName
    Else
        On Error GoTo 0
        Err.Raise vbObjectError + 2001, "CGZip::AddFile", "File is already in Zip List"
    End If
    
End Function

Public Function RemoveFile(ByVal sFileName As String)
    Dim sFile As String
    
    On Error Resume Next
    
    sFile = mCollection.Item(sFileName)
    
    If Len(sFile) = 0 Then
        Err.Raise vbObjectError + 2002, "CGZip::RemoveFile", "File is not in Zip List"
    Else
        mCollection.Remove sFileName
    End If
    
End Function

Public Function MakeZipFile() As Long
    Dim zFileArray As ZIPnames
    Dim sFileName As Variant
    Dim lFileCount As Long
    Dim iIgnorePath As Integer

On Error GoTo vbErrorHandler


    
    lFileCount = 0
    
    For Each sFileName In mCollection
        zFileArray.s(lFileCount) = sFileName
        lFileCount = lFileCount + 1
    Next

        
    MakeZipFile = VBZip(CInt(lFileCount), msZipFileName, _
        zFileArray, iIgnorePath, _
        miRecurseFolders, miUpdateZip, _
        0, msRootDirectory)
    

    Exit Function

vbErrorHandler:
    MakeZipFile = -99
    Err.Raise Err.Number, "CGZipFiles::MakeZipFile", Err.Description

End Function

Public Function GetLastMessage() As String
    GetLastMessage = msOutput
End Function


en el boton la secuencia seria 

Dim oZip As CGZipFiles, VarNomZIP As String

'Instanciamos la clase
        Set oZip = New CGZipFiles
        
         oZip.ZipFileName = "C:\FE\XMLFirmados\example.ZIP"
         oZip.UpdatingZip = False
                       
          oZip.AddFile "C:\FE\ejem.xml"
          oZip.AddFile "C:\FE\factiur.PDF"
                       
            If oZip.MakeZipFile <> 0 Then MsgBox "Error al intentar comprimir", vbCritical, "Error": End
            DoEvents
            Set oZip = Nothing



Siempre algo nuevo por aprender
Arriba
 Responder Responder
  Compartir tema   

Ir al foro Permisos de foro Ver desplegable