Sub Parse(ByVal ThisFolder As String)
        FSO = New Scripting.FileSystemObject
        Dim soFolder As Folder
        Dim soFile As File
        Dim soFolders As Folders
 
 
        soFolder = FSO.GetFolder(ThisFolder)
 
        ' Files in this directory
 
        For Each soFile In soFolder.Files
            ' TestdbDataSet.Table1.Rows.Add(CStr(ThisFolder), CStr(soFile.Name), CStr(soFile.Type), CStr(soFile.Size))
            Table1TableAdapter.Insert(CStr(ThisFolder), CStr(soFile.Name), CStr(soFile.Type), CStr(soFile.Size))
        Next soFile
 
        ' Recurse Subdirectories
        soFolders = soFolder.SubFolders ' parses subfolders
 
        For Each soFolder In soFolders
            Parse(soFolder.Path)
        Next soFolder
 
        soFolders = Nothing
        soFolder = Nothing
        soFile = Nothing
 
 
    End Sub

Option Explicit
 
    Const strStartPath = "C:\"
    Const strDestFile = "c:\output.txt"
    Const strDestTargetFile = "c:\outputTarget.txt"
 
    Dim dicList
        dicList = CreateObject("Scripting.Dictionary")
        dicList.Add(LCase("mp3"), "")
        dicList.Add(LCase("avi"), "")
        dicList.Add(LCase("wav"), "")
 
 
 
    Dim objFSO, strTempFolder, objDestFile, objDestTargetFile
        objFSO = CreateObject("Scripting.FileSystemObject")
        strTempFolder = CreateTempFolder()
 
    Dim strDest, strDestTarget
        strDest = ""
        strDestTarget = ""
 
        If objFSO.FileExists(strDestFile) Then objFSO.DeleteFile(strDestFile)
        If objFSO.FileExists(strDestTargetFile) Then objFSO.DeleteFile(strDestTargetFile)
 
        Call TraverseFolder(strStartPath)
 
        If objFSO.FolderExists(strTempFolder) Then objFSO.DeleteFolder(strTempFolder)
 
 
 
    Sub TraverseFolder(ByVal strFolderPath)
        Dim objCurrentFolder, objFile, objFolder
        objCurrentFolder = objFSO.GetFolder(strFolderPath)
 
        On Error Resume Next
 
        For Each objFile In objCurrentFolder.Files
            If Not Err() Then
                If LCase(objFSO.GetExtensionName(objFile)) = "zip" Then
                    Call UnZipAndCheckExtension(objFile, strTempFolder)
                End If
            Else
                Err.Clear()
            End If
        Next
 
        For Each objFolder In objCurrentFolder.subFolders
            If Not Err() Then
                Call TraverseFolder(objFolder.ParentFolder & "\" & objFolder.name)
            Else
                Err.Clear()
            End If
        Next
 
        On Error GoTo 0
    End Sub
 
 
    Function UnZipAndCheckExtension(ByVal strZipFile, ByVal strTempFolder)
        Const strUNZIPSource = "WZUNZIP.EXE"
 
        Dim objFSO, objShell, intRet
        objFSO = CreateObject("Scripting.FileSystemObject")
        If Not objFSO.FolderExists(strTempFolder) Then objFSO.CreateFolder(strTempFolder)
        objShell = CreateObject("WScript.shell")
 
        On Error Resume Next
        intRet = objShell.Run("""" & strUNZIPSource & """ -o """ & strZipFile & """ """ & strTempFolder & """", _
           0, True)
        If Err() Then
            On Error GoTo 0
            MsgBox(strZipFile & vbLf & Err.Description)
            Exit Function
        End If
        On Error GoTo 0
 
        Dim objFolder, objFile
        objFolder = objFSO.GetFolder(strTempFolder)
 
        strDest = "The following files are found in '" & strZipFile & "':" & vbLf
        strDestTarget = "The following special files are found in '" & strZipFile & "':" & vbLf
 
        For Each objFile In objFolder.Files
            strDest = strDest & "->" & objFSO.GetFileName(objFile) & vbLf
 
            If dicList.Exists(LCase(objFSO.GetExtensionName(objFile))) Then
                strDestTarget = strDestTarget & "->" & objFSO.GetFileName(objFile) & vbLf
            End If
 
            objFSO.DeleteFile(objFile)
        Next
 
        objDestFile = objFSO.OpenTextFile(strDestFile, 8, True)
        objDestFile.Write(strDest)
        objDestFile.Close()
 
        objDestTargetFile = objFSO.OpenTextFile(strDestTargetFile, 8, True)
        objDestTargetFile.Write(strDestTarget)
        objDestTargetFile.Close()
    End Function
 
 
    Function CreateTempFolder()
        Dim objFSO, strTempFile
        objFSO = CreateObject("Scripting.FileSystemObject")
        strTempFile = objFSO.GetTempName
        strTempFile = Replace(strTempFile, "." & objFSO.GetExtensionName(strTempFile), "")
 
        Dim objShell
        objShell = CreateObject("WScript.Shell")
        CreateTempFolder = Replace(objShell.SpecialFolders("Desktop"), "Desktop", "Local Settings\Temp") & _
            "\" & strTempFile
    End Function
    End Sub

objFolder = objFSO.GetFolder(strTempFolder)
strDest = "The following files are found in '" & strZipFile & "':" & vbLf
strDestTarget = "The following special files are found in '" & strZipFile & "':" & vbLf