Funzione per comprimere una directory coi CompressedFolder di Window
by Luca Landi
Questo post, rivolto ai più esperti, deriva da una carteggio email fra me (G.G.) e un bravo visitatore di questo blog, Luca Landi (landiluc@gmail.it), che recentemente mi ha ringraziato come segue:
Dovevo realizzare una funzione per la compressione di una directory tramite VBA di Word utilizzando i "CompressedFolder" di Windows. Avevo già realizzato la funzione, ma non riuscivo a capire perchè si bloccava sull'istruzione:
.NameSpace(sArchiveFile).CopyHere .NameSpace(sSourceFolder).Items, FOF_CREATEPROGRESSDLG
poi ho letto due righe di codice dalla sua Sub:
Set OggShell = CreateObject("Shell.Application")
'Incredibile a dirsi: senza "" & nell'argomento di Namespace si aveva ERRORE!!!
e ho risolto tutto.
G.G. Ho subito pregato Luca di spedirmi il suo capodopera, pensando potesse interessare molta gente. Ed ecco la sua risposta (aggiungo solo che la mia routine elogiata dallo stesso la riporto in fondo a questo post):
Le invio il codice relativo al modulo che ho aggiunto al mio progetto VBA di Word.
Option Explicit
'invochiamo una API del sistema operativo per poter sfruttare la funzione Sleep
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Function Compress_Folder(ByVal pSourceFolder As String, ByVal pArchiveFile As String)
Const FOF_CREATEPROGRESSDLG = &H0&
Dim oFSO
Dim oFile
Dim iFiles
Dim oShell As Object
'creiamo un oggetto FileSystemObject
Set oFSO = CreateObject("Scripting.FileSystemObject")
'creiamo la CompressedFolder vuota di destinazione
Set oFile = oFSO.OpenTextFile(pArchiveFile, 2, True)
oFile.Write "PK" & Chr(5) & Chr(6) & String(18, Chr(0))
oFile.Close
'liberiamo gli oggetti che non ci servono più
Set oFile = Nothing
Set oFSO = Nothing
iFiles = 0
Set oShell = CreateObject("Shell.Application")
With oShell
'copia i file nella cartella compressa
.NameSpace("" & pArchiveFile).CopyHere .NameSpace("" & pSourceFolder).Items, FOF_CREATEPROGRESSDLG
'prelevo il numero di item presenti all'interno della directory sorgente
iFiles = iFiles + .NameSpace("" & pSourceFolder).Items.count
'attende finchè la compressione non è conclusa e non risultano compressi
‘tutti i file all'interno della CompressedFolder di destinazione
On Error Resume Next
Do Until .NameSpace("" & pArchiveFile).Items.count = iFiles
Sleep 1000
Loop
On Error GoTo 0
End With
'liberiamo l'oggetto Shell e il contatore di item
Set oShell = Nothing
Set iFiles = Nothing
End Function
Ipotetica chiamata:
Project.Compress_Folder origine, destinazione
La funzione purtroppo non è pensata per svuotare una CompressedFolder di destinazione già presente su disco e che possiede lo stesso nome. In realtà io possiedo all'interno del mio progetto un meccanismo esterno per fare in modo che il nome del file zip di destinazione sia sempre diverso.
Le mie specifiche richiedevano la compressione di una cartella con uno strumento che fosse sicuramente funzionante su Windows, indipendentemente dai software proprietari di compressione istallati sulla macchina ospite. Per questo motivo ho dovuto fare ricorso ad una soluzione non proprietaria.
Qui torno a parlare io (G. G.), riportando la mia sub (non aggiungo altro, contando sull'agile comprendonio dei buoni intenditori cui io e Luca ci rivolgiamo):
Sub CartellaOOXMLInNuovoFileOOXML(CartTarget As String, ZipDestin As String, Estens As String)
Dim OggShell As Object
If Not (Estens = "xlsx" Or Estens = "xlsm" _
Or Estens = "docx" Or Estens = "docm") Then
MsgBox "Formato non valido!", vbCritical, "OK solo file Excel o Word 2007"
Exit Sub
End If
'Creazione di un nuovo ZipDestin vuoto
Open ZipDestin For Output As #1
Print #1, Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, 0)
Close #1
Set OggShell = CreateObject("Shell.Application")
'Incredibile a dirsi: senza "" & nell'argomento di Namespace si aveva ERRORE!!!
For Each oF In OggShell.Namespace("" & CarTarget).Items
OggShell.Namespace("" & ZipDestin).Copyhere (oF)
Debug.Print oF
Pausa 0.5 '500 millisec.
Next oF
Set OggShell = Nothing
'Rinomina il file ZipDestin come file Excel o Word 2007
Application.DisplayAlerts = False 'Tacita proteste sul cambio estens.
Name DestinZip As Replace(DestinZip, "zip", Estens)
Set OggShell = Nothing
End Sub
Buon divertimento!
?>