Access 2007/2010解压一个目录下的zip文件为csv文件并上传

2015/05/27 41529

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

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
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