- 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
- Private Sub TreeLoadFile(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
- DoCmd.TransferSpreadsheet acImport, acExportDelim, "TableData", sDir, True
- 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
- TreeLoadFile sSubDirs(Index), sFileSpec
- Next Index
- End Sub
- 'Microsoft Scripting Runtime
- 'Microsoft Shell Controls And Automation
- Private Sub BrowseCmd_Click()
- Dim getdir As String
- getdir = BrowseForFolder(Me, "Select A Directory", Text1.Text)
- If Len(getdir) = 0 Then
- Exit Sub 'user selected cancel
- End If
- FilePathTxt.SetFocus
- FilePathTxt.Locked = False
- FilePathTxt.Text = getdir
- FilePathTxt.Locked = True
- End Sub
- Private Sub UploadCmd_Click()
- FilePathTxt.SetFocus
- If FilePathTxt.Text <> "" Then
- 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"
- TreeLoadFile getdir, "*.csv"
- FilePathTxt.Locked = False
- FilePathTxt.Text = ""
- FilePathTxt.Locked = True
- End If
- End Sub
来源: http://www.phpxs.com/code/1008802/