清华大佬耗费三个月吐血整理的几百G的资源，免费分享！....>>>

Option Explicit

Private Const BIF_STATUSTEXT = &H4&
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260

Private Const WM_USER = &H400
Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SELCHANGED = 2
Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
Private Const BFFM_SETSELECTION = (WM_USER + 102)

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Declare Function SHBrowseForFolder Lib "Shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "Shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Type BrowseInfo
  hWndOwner      As Long
  pIDLRoot       As Long
  pszDisplayName As Long
  lpszTitle      As Long
  ulFlags        As Long
  lpfnCallback   As Long
  lParam         As Long
  iImage         As Long
End Type

Private m_CurrentDirectory As String   'The current directory
Dim fso As New Scripting.FileSystemObject
Dim objShell As New Shell
Dim objFolderItem As FolderItems
Dim temppath As String ' receives name of temporary file path

Private Function BrowseForFolder(owner As Form, Title As String, StartDir As String) As String
  'Opens a Treeview control that displays the directories in a computer

  Dim lpIDList As Long
  Dim szTitle As String
  Dim sBuffer As String
  Dim tBrowseInfo As BrowseInfo
  m_CurrentDirectory = StartDir & vbNullChar

  szTitle = Title
  With tBrowseInfo
    .hWndOwner = owner.hWnd
    .lpszTitle = lstrcat(szTitle, "")
    .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + BIF_STATUSTEXT
    .lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc)  'get address of function.
  End With

  lpIDList = SHBrowseForFolder(tBrowseInfo)
  If (lpIDList) Then
    sBuffer = Space(MAX_PATH)
    SHGetPathFromIDList lpIDList, sBuffer
    sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
    BrowseForFolder = sBuffer
  Else
    BrowseForFolder = ""
  End If
  
End Function
 
Private Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
  
  Dim lpIDList As Long
  Dim ret As Long
  Dim sBuffer As String
  
  On Error Resume Next  'Sugested by MS to prevent an error from
                        'propagating back into the calling process.
     
  Select Case uMsg
  
    Case BFFM_INITIALIZED
      Call SendMessage(hWnd, BFFM_SETSELECTION, 1, m_CurrentDirectory)
      
    Case BFFM_SELCHANGED
      sBuffer = Space(MAX_PATH)
      
      ret = SHGetPathFromIDList(lp, sBuffer)
      If ret = 1 Then
        Call SendMessage(hWnd, BFFM_SETSTATUSTEXT, 0, sBuffer)
      End If
      
  End Select
  
  BrowseCallbackProc = 0
  
End Function

' This function allows you to assign a function pointer to a vaiable.
Private Function GetAddressofFunction(add As Long) As Long
  GetAddressofFunction = add
End Function

Private Sub UnZip(ByVal myZipFile, ByVal myTargetDir)
    Set objFolderItem = objShell.NameSpace(myZipFile).Items()
    objShell.NameSpace(myTargetDir).CopyHere objFolderItem, 256
End Sub

Private Sub TreeUnzip(ByVal sPath As String, ByVal sFileSpec As String)
Dim sDir         As String
Dim sSubDirs()     As String
Dim Index As Integer

      If Right(sPath, 1) <> "\" Then
           sPath = sPath & "\"
      End If
      sDir = Dir(sPath & sFileSpec)
     
      Do While Len(sDir)
            sDir = Dir
            UnZip sDir, temppath
      Loop
     
      Index = 0
      sDir = Dir(sPath & "*.*", 16)
      Do While Len(sDir)
            If Left(sDir, 1) <> "." Then
                  If GetAttr(sPath & sDir) And vbDirectory Then
                        Index = Index + 1
                        ReDim Preserve sSubDirs(1 To Index)
                        sSubDirs(Index) = sPath & sDir & "\"
                  End If
            End If
      sDir = Dir
      Loop

      For Index = 1 To Index
            TreeSearch sSubDirs(Index), sFileSpec
      Next Index

End Sub
'Microsoft Scripting Runtime
'Microsoft Shell Controls And Automation
Sub test()
Dim getdir As String
getdir = BrowseForFolder(Me, "Select A Directory", Text1.Text)
If Len(getdir) = 0 Then
    Exit Sub  'user selected cancel
End If
Dim slength As Long ' receives length of string returned for the path
Dim lastfour As Long ' receives hex value of the randomly assigned ????

' Get Windows's temporary file path
temppath = Space(255) ' initialize the buffer to receive the path
slength = GetTempPath(255, temppath) ' read the path name
temppath = Left(temppath, slength) ' extract data from the variable
temppath = temppath & "\choise"
If Not fso.FolderExists(temppath) Then
fso.CreateFolder (temppath)
End If
TreeUnzip getdir, "*.zip"
End Sub