[已解决]求一遍曆指定路徑下將指定後綴名文件移動到當前指定的路徑下的宏代碼，謝謝

yl.fu · 发表于 2013-5-25 10:47

比如我在a1 中輸入d:\a 執行就可將d:\a下所有資料夾及各子資料夾中的BMP圖片文件移動到 d:\a \圖片\ 下此“圖片” 資料夾可判斷沒有就自動創建。謝謝

最佳答案

月排行榜 / 总排行榜

hwc2ycy

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

复制代码

测试交你了，我这没测。

跳转到最佳答案楼层

hwc2ycy · 发表于 2013-5-25 11:05

遍历的代码你在论坛可以搜下，很多。

移动的话，就用NAME语句。

hwc2ycy · 发表于 2013-5-25 11:05

Name 语句
请参阅示例特性

重新命名一个文件、目录、或文件夹。

语法

Name oldpathname As newpathname

Name 语句的语法具有以下几个部分：

部分描述
oldpathname 必要参数。字符串表达式，指定已存在的文件名和位置，可以包含目录或文件夹、以及驱动器。
newpathname 必要参数。字符串表达式，指定新的文件名和位置，可以包含目录或文件夹、以及驱动器。而由 newpathname 所指定的文件名不能存在。

说明

Name 语句重新命名文件并将其移动到一个不同的目录或文件夹中。如有必要，Name 可跨驱动器移动文件。但当 newpathname 和 oldpathname 都在相同的驱动器中时，只能重新命名已经存在的目录或文件夹。 Name 不能创建新文件、目录或文件夹。

在一个已打开的文件上使用 Name，将会产生错误。必须在改变名称之前，先关闭打开的文件。Name 参数不能包括多字符 (*) 和单字符 (?) 的统配符。

yl.fu · 发表于 2013-5-25 11:08

hwc2ycy 发表于 2013-5-25 11:05
Name 语句
请参阅示例特性

可是我不懂代碼啊，

hwc2ycy · 发表于 2013-5-25 11:27

这个最佳答案由 hwc2ycy 给出，感谢 hwc2ycy 的回答。

单击隐藏图章

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

复制代码

测试交你了，我这没测。

yl.fu · 发表于 2013-5-25 12:01

hwc2ycy 发表于 2013-5-25 11:27
测试交你了，我这没测。

你就一牛人{:221:}

		自动登录	找回密码
密码			注册

[已解决]求一遍曆指定路徑下將指定後綴名文件移動到當前指定的路徑下的宏代碼，謝謝

评分

评分

评分