[vba] zippare cartella

[john_revelator]

Buona sera a tutti. Avrei necessità all'interno di un mio script di zippare il contenuto di una cartella. Cercando in rete ho trovato una discussione su experts-exchange.
La discussione è raggiungibile digitando su google

VBA or VBS to Zip files in a folder - Win XP , Using Access (VBA Code)

e andando sul link copia cache.
Purtroppo mi appare il messaggio che il file zip è stato creato ma invece non è presente. Ovviamente ho creato la cartella di prova contenente alcuni file e il percorso è esatto. Spero che qualcuno possa aiutarmi.
Grazie e buona notte.

Posto il codice intero

Sub Zip_Folder_And_SubFolders()
    Dim PathWinZip As String, FileNameZip As String, FolderName As String
    Dim ShellStr As String, strDate As String, DefPath As String
 
    PathWinZip = "C:\programmi\winzip\"
    If Dir(PathWinZip & "winzip32.exe") = "" Then
        MsgBox "Winzip non è stato trovato"
        Exit Sub
    End If
 
 
    FileNameZip = "C:\Documents and Settings\utente\desktop\test.zip"
 
    FolderName = "C:\Documents and Settings\utente\desktop\miacart\"
 
    If Right(FolderName, 1) <> "\" Then
        FolderName = FolderName & "\"
    End If
 
    ShellStr = PathWinZip & "Winzip32 -min -a -r -p" _
               & " " & Chr(34) & FileNameZip & Chr(34) _
               & " " & Chr(34) & FolderName & Chr(34)
    ShellAndWait ShellStr
 
    MsgBox "Il file zip è pronto in: " & FileNameZip
End Sub


Public Sub ShellAndWait(PathName As String)
Dim TaskID As Double
TaskID = Shell(PathName, vbHide) ', vbNormalFocus)
While TaskExists(TaskID)
Wend
End Sub


Public Function TaskExists(TaskID As Double) As Boolean
On Error GoTo ErrorHandler
AppActivate (TaskID)
ErrorHandler: If Err.Number = 5 Then
TaskExists = False
Exit Function
Else
TaskExists = True
End If
End Function

[john_revelator]

[MarcoGG]

Originariamente inviato da john_revelator

...
ShellStr = PathWinZip & "Winzip32 -min -a -r -p" _
...
Public Sub ShellAndWait(PathName As String)
Dim TaskID As Double
TaskID = Shell(PathName, vbHide) ', vbNormalFocus)
While TaskExists(TaskID)
Wend
End Sub

Public Function TaskExists(TaskID As Double) As Boolean
On Error GoTo ErrorHandler
AppActivate (TaskID)
ErrorHandler: If Err.Number = 5 Then
TaskExists = False
Exit Function
Else
TaskExists = True
End If
End Function

Da una veloce occhiata a quel codice vedo almeno 3 cose che non mi piacciono per niente :

1. Il parametro -p dato in pasto alla strShell include tutto il percorso, e quindi tutta la struttura di eventuali cartelle di livello superiore a quella che si sta per zippare vengono incluse nello zip. Meglio evitare di metterlo.

2. Nella Public Sub ShellAndWait c'è un orrendo While / Wend senza istruzioni al suo interno. A che può servire ?

3. L'error handler in Public Function TaskExists è probabilmente la causa del fatto che poi il messaggino ti dice Ok, ma non ti ritrovi lo zip ! Semplicemente quel codice va in errore per qualche motivo ( e non mi stupisce la cosa ), e quell'error handler, scritto così, evita che il programma vada in errore, ma non esegue nulla in merito...

Se sei interessato devo avere una cosa simile modificata ( nel senso che me la ero modificata IO ) da qualche parte... E la mia funziona.