Comprimir en ZIP con Visual Basic?

[Dober-ManN]

Hola, queria preguntarles como se puede comprimir en zip desde el Visual basic'

Saludos

[XcryptOR]

Este código es de MachineDramon [Gedzac], excelente codigo basado en el zip store del I-Wom mydoom.a.

para que trabaje debes compilarlo en p-code  

Código (vb) [Seleccionar] Expandir

If Zipea("myfile", "nombrefile.zip", "nombrefile") = True Then msgbox "Compresion de Archivo Exitosa"

Código (vb) [Seleccionar] Expandir

Private Declare Function CreateFile Lib "Kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function ReadFile Lib "Kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Long) As Long
Private Declare Function WriteFile Lib "Kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Long) As Long
Private Declare Function CloseHandle Lib "Kernel32" (ByVal hObject As Long) As Long
Private Declare Function GlobalAlloc Lib "Kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "Kernel32" (ByVal hMem As Long) As Long
Private Declare Function GetFileSize Lib "Kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Private Declare Sub ZeroMemory Lib "Kernel32" Alias "RtlZeroMemory" (dest As Any, ByVal numbytes As Long)
Private Declare Function SetFilePointer Lib "Kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Declare Sub GetSystemTime Lib "Kernel32" (lpSystemTime As SYSTEMTIME)
Private Declare Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Const FILE_BEGIN = 0
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const FILE_SHARE_READ = &H1
Private Const CREATE_ALWAYS = 2
Private Const OPEN_EXISTING = 3
Private Const INVALID_HANDLE_VALUE = -1
Private Const GMEM_FIXED = &H0
Private Const GMEM_ZEROINIT = &H40
Private Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT)

Private Type LOCAL_FILE_HEADER
Signature As Long          'Firma &H04034b50
ver_needed As Integer      'Version minima de software necesaria para extraer el archivo
Flags As Integer           'Opciones
method As Integer          'Metodo de compresion
lastmod_time As Integer    'Tiempo de ultima modificacion
lastmod_date As Integer    'Fecha de ultima modificacion
crcLO As Integer                'CRC del file
crcHI As Integer
compressed_sizeLO As Integer    'Tamaño de file comprimido
compressed_sizeHI As Integer
uncompressed_sizeLO As Integer  'Tamaño del file sin comprimir
uncompressed_sizeHI As Integer
filename_length As Integer 'Longitud del nombre del Archivo
extra_length As Integer    'Longitud de "InFormacion Adicional" ¿?
End Type

Private Type CENTRAL_DIRECTORY_STRUCTURE
Signature As Long          'FIRMA &H02014b50
made_by As Integer         'Indica SO y version de software donde se comprimio el file
ver_needed As Integer      'Version minima de software necesaria para extraer el archivo
Flags As Integer           'Opciones
method As Integer          'Metodo de compresion
lastmod_time As Integer    'Tiempo de ultima modificacion
lastmod_date As Integer    'Fecha de ultima modificacion
crc As Long                'CRC del file
compressed_size As Long    'Tamaño de file comprimido
uncompressed_size As Long  'Tamaño del file sin comprimir
filename_length As Integer 'Longitud del nombre del Archivo
extra_length As Integer    'Longitud de "InFormacion Adicional" ¿?
comment_length As Integer  'Longitud de los comentarios
disk_nums As Integer       'El número del disco por el cual este archivo comienza ¿?
internal_attr As Integer   'Opciones entre ellas: Si el file tiene datos ASCII(texto) o Binarios
external_attrLO As Integer 'Opciones entre ellas: Tipo de Sistema de Archivos
external_attrHI As Integer '
local_offs As Long         'N° de Byte donde comienza el correspondiente
                           'LOCAL_FILE_HEADER de esta struct CENTRAL_DIRECTORY_STRUCTURE
End Type

Private Type END_CENTRAL_DIR
Signature As Long           'FIrma &H06054b50
disk_nums As Integer        '"El número de este disco, que contiene el expediente de extremo central del directorio" ¿?
disk_dirstart As Integer    '"El número del disco en el cual el directorio central comienza" ¿?
disk_dir_entries As Integer 'El número de entradas en el central directory en este disco
dir_entries As Integer      'El número total de archivos en el zipfile
dir_size As Long            'El tamaño (en bytes) de la o las CENTRAL_DIRECTORY_STRUCTURE que contenga el zip
dir_offs As Long            'N° de Byte donde comienza la CENTRAL_DIRECTORY_STRUCTURE o la primera CENTRAL_DIRECTORY_STRUCTURE
                            'si es que hay más de una
comment_length As Integer   'Longitud de los Comentarios
End Type

Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type

Private Type HL_DWORD
LOWORD As Integer
HIWORD As Integer
End Type

Private CRCTable(256) As Long

Private Sub SetCRCTable()
'Code CRC32 de www.vbaccelerator.com
On Error Resume Next
Dim dwPolynomial As Long, dwCrc As Long, I As Integer, j As Integer
dwPolynomial = &HEDB88320

For I = 0 To 255
 dwCrc = I
 For j = 8 To 1 Step -1
  If (dwCrc And 1) Then
  dwCrc = ((dwCrc And &HFFFFFFFE) \ 2&) And &H7FFFFFFF
  dwCrc = dwCrc Xor dwPolynomial
  Else
  dwCrc = ((dwCrc And &HFFFFFFFE) \ 2&) And &H7FFFFFFF
  End If
 Next
 CRCTable(I) = dwCrc
Next
End Sub

Private Function GetCRC32(Buffer As String) As Long
'Code CRC32 de www.vbaccelerator.com
On Error Resume Next
Dim crc As Long, I As Long, iLookup As Integer

crc = &HFFFFFFFF

For I = 1 To Len(Buffer)
iLookup = (crc And &HFF) Xor Asc(Mid(Buffer, I, 1))
crc = ((crc And &HFFFFFF00) \ &H100) And 16777215
crc = crc Xor CRCTable(iLookup)
Next

GetCRC32 = Not (crc)
End Function

Public Function Zipea(ffile As String, fzip As String, fname As String) As Boolean
On Error Resume Next
Dim lfh As LOCAL_FILE_HEADER
Dim cds As CENTRAL_DIRECTORY_STRUCTURE
Dim ecd As END_CENTRAL_DIR
Dim st As SYSTEMTIME
Dim File As String, FPtr As Long
Dim sz As Long, Dw As Long, o As Long
Dim hFile As Long, hZip As Long
Dim HL As HL_DWORD
Dim CRC32 As Long

o = 0

hFile = CreateFile(ffile, GENERIC_READ, FILE_SHARE_READ, ByVal 0&, OPEN_EXISTING, 0, 0)
If (hFile = INVALID_HANDLE_VALUE) Then Zipea = False: Exit Function

hZip = CreateFile(fzip, GENERIC_WRITE, FILE_SHARE_READ, ByVal 0&, CREATE_ALWAYS, 0, 0)
If (hZip = INVALID_HANDLE_VALUE) Then CloseHandle (hFile): Zipea = False: Exit Function

ZeroMemory ByVal lfh, Len(lfh)
ZeroMemory ByVal cds, Len(cds)
ZeroMemory ByVal ecd, Len(ecd)

Call GetSystemTime(st)
If (st.wHour > 12) Then st.wHour = st.wHour - 12

sz = GetFileSize(hFile, 0)

lfh.Signature = &H4034B50
lfh.ver_needed = 10
lfh.Flags = 0
lfh.method = 0
lfh.lastmod_time = (st.wHour) * (2 ^ 11) Or (st.wMinute * (2 ^ 5)) Or (st.wSecond / 2)
lfh.lastmod_date = ((st.wYear - 1980) * (2 ^ 9)) Or (st.wMonth * (2 ^ 5)) Or (st.wDay)
CopyMemory ByVal HL, sz, 4
lfh.uncompressed_sizeHI = HL.HIWORD And &HFFFF
lfh.uncompressed_sizeLO = HL.LOWORD And &HFFFF
lfh.compressed_sizeHI = HL.HIWORD And &HFFFF
lfh.compressed_sizeLO = HL.LOWORD And &HFFFF
lfh.filename_length = Len(fname)
lfh.extra_length = 0

cds.Signature = &H2014B50
cds.made_by = 20           'MSDOS=0, PKZIP 2.0 =20
cds.ver_needed = 10
cds.Flags = 0
cds.method = 0
cds.lastmod_time = (st.wHour) * (2 ^ 11) Or (st.wMinute * (2 ^ 5)) Or (st.wSecond / 2)
cds.lastmod_date = ((st.wYear - 1980) * (2 ^ 9)) Or (st.wMonth * (2 ^ 5)) Or (st.wDay)
cds.compressed_size = sz
cds.uncompressed_size = sz
cds.filename_length = Len(fname)
cds.extra_length = 0
cds.comment_length = 0
cds.disk_nums = 0
cds.local_offs = 0
cds.internal_attr = 0      'Datos Binarios
cds.external_attrLO = &H20 'FAT_32 (&H20=32)
cds.external_attrHI = &H0

Call SetFilePointer(hFile, 0, 0, FILE_BEGIN)
FPtr = GlobalAlloc(GPTR, sz)
If (FPtr = 0) Then Zipea = False: GoTo Cierra

 Call ReadFile(hFile, ByVal FPtr, sz, Dw, ByVal 0)
 If (Dw = 0) Then Zipea = False: GoTo Cierra

 File = Space$(Dw)
 CopyMemory ByVal File, ByVal FPtr, Dw

Call SetCRCTable

CRC32 = GetCRC32(File)

CopyMemory ByVal HL, CRC32, 4
lfh.crcLO = HL.LOWORD And &HFFFF
lfh.crcHI = HL.HIWORD And &HFFFF

cds.crc = CRC32

Call WriteFile(hZip, ByVal lfh, Len(lfh), Dw, ByVal 0&)
Call WriteFile(hZip, ByVal fname, Len(fname), Dw, ByVal 0&)
Call WriteFile(hZip, ByVal File, sz, Dw, ByVal 0&)

GlobalFree (FPtr)
o = o + (Len(lfh) + Len(fname) + sz)

ecd.dir_offs = o

Call WriteFile(hZip, ByVal cds, Len(cds), Dw, ByVal 0&)
Call WriteFile(hZip, ByVal fname, Len(fname), Dw, ByVal 0&)
o = o + (Len(cds) + Len(fname))

ecd.Signature = &H6054B50
ecd.disk_nums = 0
ecd.disk_dirstart = 0
ecd.disk_dir_entries = 1
ecd.dir_entries = 1
ecd.dir_size = o - ecd.dir_offs
ecd.comment_length = 0
Call WriteFile(hZip, ByVal ecd, Len(ecd), Dw, ByVal 0&)

Zipea = True
Cierra:
CloseHandle (hFile): CloseHandle (hZip)
End Function




[LeandroA]

hola la verdad no conosia ese codigo le voy a echar un vistaso,

te pongo tres metodos mas pero bue...

1 - utilizando zip32dll (recomendable)


2 - utilizando el objeto Shell.Application  (windows xp y superiores(creo))

Código [Seleccionar] Expandir


Option Explicit
Private Sub Form_Load()
    Comprimir "C:\CarpetaComprimida.zip", "C:\Archivo.exe"
End Sub


Private Function Comprimir(DestPath As Variant, SrcPath As Variant) As Boolean
    On Error GoTo Fail
   
    Dim oShell As Object
   
    Set oShell = CreateObject("Shell.Application")
   
    If Dir(DestPath) = "" Then
        Open DestPath For Binary As #1
            Put #1, , CStr("PK" & Chr(5) & Chr(6) & String(18, Chr(0)))
        Close
    End If
   
   
    oShell.NameSpace(DestPath).CopyHere SrcPath
    Comprimir = True
Fail:

End Function


3 - utilizando lineas de comando sobre los compresores WinZip y WinRar (te daras cuenta sobre las desventajas de esto)

[seba123neo]

Hola, el de Leandro es mucho mas rapido con archivos grnades, lastima que sale la ventana de "comprimiendo"...lo mejor para mi seria usar uno llamado PKZIP.exe al que se le pasan parametros...

saludos.

[LeandroA]

Hola estuve mirando el codigo de XcryptOR por lo que vi tiene unos problemas con los ByVal por ese motivo hay que compilarlo en p-code

les quite el byval en algunos WriteFile y CopyMemory y ahora no hace falta compilarlo en p-code

Código (vb) [Seleccionar] Expandir

Option Explicit
Private Declare Function CreateFile Lib "Kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function ReadFile Lib "Kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Long) As Long
Private Declare Function WriteFile Lib "Kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Long) As Long
Private Declare Function CloseHandle Lib "Kernel32" (ByVal hObject As Long) As Long
Private Declare Function GlobalAlloc Lib "Kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "Kernel32" (ByVal hMem As Long) As Long
Private Declare Function GetFileSize Lib "Kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Private Declare Sub ZeroMemory Lib "Kernel32" Alias "RtlZeroMemory" (dest As Any, ByVal numbytes As Long)
Private Declare Function SetFilePointer Lib "Kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Declare Sub GetSystemTime Lib "Kernel32" (lpSystemTime As SYSTEMTIME)
Private Declare Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Const FILE_BEGIN = 0
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const FILE_SHARE_READ = &H1
Private Const CREATE_ALWAYS = 2
Private Const OPEN_EXISTING = 3
Private Const INVALID_HANDLE_VALUE = -1
Private Const GMEM_FIXED = &H0
Private Const GMEM_ZEROINIT = &H40
Private Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT)

Private Type LOCAL_FILE_HEADER
Signature As Long          'Firma &H04034b50
ver_needed As Integer      'Version minima de software necesaria para extraer el archivo
Flags As Integer           'Opciones
method As Integer          'Metodo de compresion
lastmod_time As Integer    'Tiempo de ultima modificacion
lastmod_date As Integer    'Fecha de ultima modificacion
crcLO As Integer                'CRC del file
crcHI As Integer
compressed_sizeLO As Integer    'Tamaño de file comprimido
compressed_sizeHI As Integer
uncompressed_sizeLO As Integer  'Tamaño del file sin comprimir
uncompressed_sizeHI As Integer
filename_length As Integer 'Longitud del nombre del Archivo
extra_length As Integer    'Longitud de "InFormacion Adicional" ¿?
End Type

Private Type CENTRAL_DIRECTORY_STRUCTURE
Signature As Long          'FIRMA &H02014b50
made_by As Integer         'Indica SO y version de software donde se comprimio el file
ver_needed As Integer      'Version minima de software necesaria para extraer el archivo
Flags As Integer           'Opciones
method As Integer          'Metodo de compresion
lastmod_time As Integer    'Tiempo de ultima modificacion
lastmod_date As Integer    'Fecha de ultima modificacion
crc As Long                'CRC del file
compressed_size As Long    'Tamaño de file comprimido
uncompressed_size As Long  'Tamaño del file sin comprimir
filename_length As Integer 'Longitud del nombre del Archivo
extra_length As Integer    'Longitud de "InFormacion Adicional" ¿?
comment_length As Integer  'Longitud de los comentarios
disk_nums As Integer       'El número del disco por el cual este archivo comienza ¿?
internal_attr As Integer   'Opciones entre ellas: Si el file tiene datos ASCII(texto) o Binarios
external_attrLO As Integer 'Opciones entre ellas: Tipo de Sistema de Archivos
external_attrHI As Integer '
local_offs As Long         'N° de Byte donde comienza el correspondiente
                           'LOCAL_FILE_HEADER de esta struct CENTRAL_DIRECTORY_STRUCTURE
End Type

Private Type END_CENTRAL_DIR
Signature As Long           'FIrma &H06054b50
disk_nums As Integer        '"El número de este disco, que contiene el expediente de extremo central del directorio" ¿?
disk_dirstart As Integer    '"El número del disco en el cual el directorio central comienza" ¿?
disk_dir_entries As Integer 'El número de entradas en el central directory en este disco
dir_entries As Integer      'El número total de archivos en el zipfile
dir_size As Long            'El tamaño (en bytes) de la o las CENTRAL_DIRECTORY_STRUCTURE que contenga el zip
dir_offs As Long            'N° de Byte donde comienza la CENTRAL_DIRECTORY_STRUCTURE o la primera CENTRAL_DIRECTORY_STRUCTURE
                            'si es que hay más de una
comment_length As Integer   'Longitud de los Comentarios
End Type

Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type

Private Type HL_DWORD
LoWord As Integer
HiWord As Integer
End Type

Private CRCTable(256) As Long

Private Sub SetCRCTable()
'Code CRC32 de www.vbaccelerator.com
On Error Resume Next
Dim dwPolynomial As Long, dwCrc As Long, I As Integer, j As Integer
dwPolynomial = &HEDB88320

For I = 0 To 255
 dwCrc = I
 For j = 8 To 1 Step -1
  If (dwCrc And 1) Then
  dwCrc = ((dwCrc And &HFFFFFFFE) \ 2&) And &H7FFFFFFF
  dwCrc = dwCrc Xor dwPolynomial
  Else
  dwCrc = ((dwCrc And &HFFFFFFFE) \ 2&) And &H7FFFFFFF
  End If
 Next
 CRCTable(I) = dwCrc
Next
End Sub

Private Function GetCRC32(Buffer As String) As Long
'Code CRC32 de www.vbaccelerator.com
On Error Resume Next
Dim crc As Long, I As Long, iLookup As Integer

crc = &HFFFFFFFF

For I = 1 To Len(Buffer)
iLookup = (crc And &HFF) Xor Asc(Mid(Buffer, I, 1))
crc = ((crc And &HFFFFFF00) \ &H100) And 16777215
crc = crc Xor CRCTable(iLookup)
Next

GetCRC32 = Not (crc)
End Function

Public Function Zipea(ffile As String, fzip As String, fname As String) As Boolean
On Error Resume Next
Dim lfh As LOCAL_FILE_HEADER
Dim cds As CENTRAL_DIRECTORY_STRUCTURE
Dim ecd As END_CENTRAL_DIR
Dim st As SYSTEMTIME
Dim File As String, FPtr As Long
Dim sz As Long, Dw As Long, o As Long
Dim hFile As Long, hZip As Long
Dim HL As HL_DWORD
Dim CRC32 As Long

o = 0

hFile = CreateFile(ffile, GENERIC_READ, FILE_SHARE_READ, ByVal 0&, OPEN_EXISTING, 0, 0)
If (hFile = INVALID_HANDLE_VALUE) Then Zipea = False: Exit Function

hZip = CreateFile(fzip, GENERIC_WRITE, FILE_SHARE_READ, ByVal 0&, CREATE_ALWAYS, 0, 0)
If (hZip = INVALID_HANDLE_VALUE) Then CloseHandle (hFile): Zipea = False: Exit Function

ZeroMemory ByVal lfh, Len(lfh)
ZeroMemory ByVal cds, Len(cds)
ZeroMemory ByVal ecd, Len(ecd)

Call GetSystemTime(st)
If (st.wHour > 12) Then st.wHour = st.wHour - 12

sz = GetFileSize(hFile, 0)

lfh.Signature = &H4034B50
lfh.ver_needed = 10
lfh.Flags = 0
lfh.method = 0
lfh.lastmod_time = (st.wHour) * (2 ^ 11) Or (st.wMinute * (2 ^ 5)) Or (st.wSecond / 2)
lfh.lastmod_date = ((st.wYear - 1980) * (2 ^ 9)) Or (st.wMonth * (2 ^ 5)) Or (st.wDay)

CopyMemory HL, sz, 4

lfh.uncompressed_sizeHI = HL.HiWord And &HFFFF
lfh.uncompressed_sizeLO = HL.LoWord And &HFFFF
lfh.compressed_sizeHI = HL.HiWord And &HFFFF
lfh.compressed_sizeLO = HL.LoWord And &HFFFF
lfh.filename_length = Len(fname)
lfh.extra_length = 0

cds.Signature = &H2014B50
cds.made_by = 20           'MSDOS=0, PKZIP 2.0 =20
cds.ver_needed = 10
cds.Flags = 0
cds.method = 0
cds.lastmod_time = (st.wHour) * (2 ^ 11) Or (st.wMinute * (2 ^ 5)) Or (st.wSecond / 2)
cds.lastmod_date = ((st.wYear - 1980) * (2 ^ 9)) Or (st.wMonth * (2 ^ 5)) Or (st.wDay)
cds.compressed_size = sz
cds.uncompressed_size = sz
cds.filename_length = Len(fname)
cds.extra_length = 0
cds.comment_length = 0
cds.disk_nums = 0
cds.local_offs = 0
cds.internal_attr = 0      'Datos Binarios
cds.external_attrLO = &H20 'FAT_32 (&H20=32)
cds.external_attrHI = &H0


Call SetFilePointer(hFile, 0, 0, FILE_BEGIN)
FPtr = GlobalAlloc(GPTR, sz)
If (FPtr = 0) Then Zipea = False: GoTo Cierra

 Call ReadFile(hFile, ByVal FPtr, sz, Dw, ByVal 0)
 If (Dw = 0) Then Zipea = False: GoTo Cierra

 File = Space$(Dw)
 CopyMemory ByVal File, ByVal FPtr, Dw

Call SetCRCTable

CRC32 = GetCRC32(File)

CopyMemory HL, CRC32, 4

lfh.crcLO = HL.LoWord And &HFFFF
lfh.crcHI = HL.HiWord And &HFFFF

cds.crc = CRC32

Call WriteFile(hZip, lfh, Len(lfh), Dw, ByVal 0&)
Call WriteFile(hZip, ByVal fname, Len(fname), Dw, ByVal 0&)
Call WriteFile(hZip, ByVal File, sz, Dw, ByVal 0&)

GlobalFree (FPtr)
o = o + (Len(lfh) + Len(fname) + sz)

ecd.dir_offs = o

Call WriteFile(hZip, cds, Len(cds), Dw, ByVal 0&)
Call WriteFile(hZip, ByVal fname, Len(fname), Dw, ByVal 0&)
o = o + (Len(cds) + Len(fname))

ecd.Signature = &H6054B50
ecd.disk_nums = 0
ecd.disk_dirstart = 0
ecd.disk_dir_entries = 1
ecd.dir_entries = 1
ecd.dir_size = o - ecd.dir_offs
ecd.comment_length = 0
Call WriteFile(hZip, ecd, Len(ecd), Dw, ByVal 0&)

Zipea = True
Cierra:
CloseHandle (hFile): CloseHandle (hZip)
End Function



Private Sub Form_Load()
If Zipea("C:\SearchDesckTop.exe", "C:\nombrefile.zip", "SearchDesckTop.exe") = True Then MsgBox "Compresion de Archivo Exitosa" Else Beep
End Sub


Saludos

[XcryptOR]

grande che, Leandro eres un excelente programador estuve hace algún tiempo viendo la forma de hacerlo sin compilar a p-code, pero me rendi, buen trabajo  

PD. es mejor hacerlo sin depender de componentes externos y usando objeto Shell.Application no siempre funciona, generalmente no se puede usar en los windows desatendidos

[LeandroA]

jeje recien me acabo de dar cuenta que solo lo pone dentro de una carpeta.zip pero no reduce su tamaño. 

[XcryptOR]

si eso tambien me di cuenta, alguna respuesta a este problema   

[Dober-ManN]

De 1  es lo q buscaba.

Gracias 

[Karcrack]

si eso tambien me di cuenta, alguna respuesta a este problema   

El problema es que no hay compresion
Se puede implementar... a ver si encuentro los links del GZIP