[编程交流] 打开、宏、关闭，然后是Lo

Option Explicit
Private Const vbDot = 46
Private Const MAX_PATH As Long = 260
Private Const INVALID_HANDLE_VALUE = -1
Private Const vbBackslash = ""
Private Const ALL_FILES = "*.*"
Private Type FILETIME
   dwLowDateTime As Long
   dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
   dwFileAttributes As Long
   ftCreationTime As FILETIME
   ftLastAccessTime As FILETIME
   ftLastWriteTime As FILETIME
   nFileSizeHigh As Long
   nFileSizeLow As Long
   dwReserved0 As Long
   dwReserved1 As Long
   cFileName As String * MAX_PATH
   cAlternate As String * 14
End Type
Private Declare Function FindClose Lib "kernel32" _
   (ByVal hFindFile As Long) As Long
Private Declare Function FindFirstFile Lib "kernel32" _
   Alias "FindFirstFileA" (ByVal lpFileName As String, _
   lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" _
   Alias "FindNextFileA" (ByVal hFindFile As Long, _
   lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Function lstrlen Lib "kernel32" _
   Alias "lstrlenW" (ByVal lpString As Long) As Long
Private Declare Function PathMatchSpec Lib "shlwapi" _
   Alias "PathMatchSpecW" (ByVal pszFileParam As Long, _
   ByVal pszSpec As Long) As Long
Dim sFileExt As String
Dim sFileRoot As String
Public Sub FindAllFiles(FileType As String, StartPath As String)
   ' recursively searches a passed path for files of a given type
   ' FileType: a wildcard string of the file extension, ie; "*.dwg" or "*.xls"
   sFileRoot = QualifyPath(StartPath) 'start path
   sFileExt = FileType 'file type of interest
   Call SearchForFiles(sFileRoot)
End Sub
Private Sub SearchForFiles(sRoot As String)
   Dim WFD As WIN32_FIND_DATA
   Dim hFile As Long
   hFile = FindFirstFile(sRoot & ALL_FILES, WFD)
   If hFile <> INVALID_HANDLE_VALUE Then
       Do
       'if a folder, and recurse specified, call method again
       If (WFD.dwFileAttributes And vbDirectory) Then
           If Asc(WFD.cFileName) <> vbDot Then
               SearchForFiles sRoot & TrimNull(WFD.cFileName) & vbBackslash
           End If
       Else
           'must be a file..
           If MatchSpec(WFD.cFileName, sFileExt) Then
               DoSomethingWithFile sRoot & TrimNull(WFD.cFileName)
           End If 'If MatchSpec
       End If 'If WFD.dwFileAttributes
       Loop While FindNextFile(hFile, WFD)
   End If 'If hFile
   Call FindClose(hFile)
End Sub
Private Function QualifyPath(sPath As String) As String
   ' formats passed path string to be used in recursive API search
   If Right$(sPath, 1) <> vbBackslash Then
       QualifyPath = sPath & vbBackslash
   Else
       QualifyPath = sPath
   End If
End Function
Private Function TrimNull(startstr As String) As String
   ' trims NULL char (ascii 0) from strings returned by API calls
   TrimNull = Left$(startstr, lstrlen(StrPtr(startstr)))
End Function
Private Function MatchSpec(sFile As String, sSpec As String) As Boolean
   ' uses API version of the "LIKE" command
   MatchSpec = PathMatchSpec(StrPtr(sFile), StrPtr(sSpec))
End Function
Private Sub DoSomethingWithFile(FoundFileName As String)
   ' use this routine to do something with each file found
   ' we'll do nothing but print out the filename found
   Dim FoundName As String: FoundName = FoundFileName
   Debug.Print FoundName
End Sub