Visual Basic 6: come estrarre tutti i file compressi presenti in una cartella

Buon codice!

Private Sub Form_Load()
Dim FirstPath As String
Dim contatore As Long
sDirectory as string
sDirectoryNew as string

contatore = 1

sDirectory = "E:\MOVIMENTI_CC\2014\"
sDirectoryNew = "E:\MOVIMENTI_CC\da caricare\"
ReDim Files(0)
stemp = Dir$(sDirectory)
Do Until stemp = ""
If stemp <> "." And stemp <> ".." And GetAttr(sDirectory & stemp) <> vbDirectory Then
ReDim Preserve Files(UBound(Files) + 1)
Files(UBound(Files)) = stemp

DefPath = sDirectory
If Right(Trim(stemp), 4) = ".zip" Or Right(Trim(stemp), 4) = ".ZIP" Then
'fai estrazione dei file

Fname = sDirectory & stemp

'Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", MultiSelect:=False)
'
If Fname = False Then
'Do nothing
Else
'Root folder for the new folder.
'You can also use DefPath = "C:\Users\Ron\test\"
'DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If

'Create the folder name
' strDate = Format(Now, " dd-mm-yy h-mm-ss")
'FileNameFolder = DefPath & "MyUnzipFolder " & strDate & "\"
FileNameFolder = DefPath

'Make the normal folder in DefPath
'MkDir FileNameFolder

'Extract the files into the newly created folder
Set oApp = CreateObject("Shell.Application")

'Change this "*.txt" to extract the files you want
For Each fileNameInZip In oApp.Namespace(Fname).items

If LCase(fileNameInZip) Like LCase("*.txt") Then

FirstPath = sDirectoryNew & stemp & ".txt"

If ExistFile(FirstPath) = False Then

oApp.Namespace(FileNameFolder).CopyHere _
oApp.Namespace(Fname).items.Item(CStr(fileNameInZip))

'inserisci pausa
'Application.Wait Now + TimeValue("00:00:05")

'If InStr(fileNameInZip, "giornaliero") > 0 Then

'controllo se già esiste
'if Fname

Name sDirectory & fileNameInZip As sDirectoryNew & stemp & ".txt"
contatore = contatore + 1
End If
'End If



End If


Next

'MsgBox "You find the files here: " & FileNameFolder

On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
End If

Else
'Exit Do
End If

End If
stemp = Dir()

Loop
Elencafile = Files

FSO.Close
oApp.Close

Set FSO = Nothing
Set oApp = Nothing
End Sub


Function ExistFile(NomeFile As String) As Boolean
On Error Resume Next
ExistFile = (GetAttr(NomeFile) And vbDirectory) = 0
End Function

Se volete seguire i post di www.informarea.it potete iscrivervi al suo feed RSS.