|
发表于 2013-5-25 11:27
|
显示全部楼层
本楼为最佳答案
- Sub 入口()
- Call ListDirs([d2].Value, "*.bmp")
- End Sub
- Sub ListDirs(ByVal strPath As String, ByVal strMatch As String)
- Dim strFileName$, strDstFolder$
- Dim arrPath()
- Dim sPath$
- Dim i&, j&
- If Len(strPath) <= 1 Then Exit Sub
- i = 1: j = 1
- If Right(strPath, 1) Like "[/\]" Then strPath = Left(strPath, Len(strPath) - 1)
- On Error Resume Next
- strDstFolder = strPath & Application.PathSeparator & "图片" & Application.PathSeparator
- MkDir strDstFolder
- On Error GoTo ErrorHandler
- ReDim arrPath(1 To 1)
- arrPath(i) = strPath & Application.PathSeparator
- sPath = arrPath(j)
- Debug.Print sPath
- Do While Len(sPath)
- strFileName = Dir(sPath & "*.*", vbDirectory + vbNormal)
- Do While Len(strFileName)
- If Not (strFileName = "." Or strFileName = "..") Then
- If (GetAttr(sPath & "" & strFileName) And vbDirectory) = 16 Then
- '避免读取错误
- If Err.Number <> 0 Then Err.Clear: GoTo End1If
- If strFileName <> strDstFolder Then
- i = i + 1
- ReDim Preserve arrPath(1 To i)
- arrPath(i) = sPath & strFileName & Application.PathSeparator
- End If
- Else
- If UCase(strFileName) Like UCase(strMatch) Then
- Name sPath & strFileName As strDstFolder & strFileName
- End If
- End If
- End If
- End1If:
- strFileName = Dir
- Loop
- j = j + 1
- If j > i Then Exit Do
- sPath = arrPath(j)
- Loop
- ErrorHandler:
- MsgBox Err.Number & vbCrLf & _
- Err.Description
- Resume Next
- End Sub
复制代码 测试交你了,我这没测。 |
评分
-
查看全部评分
|