[已解决]求大神给个代码

sayounala · 发表于 2013-11-17 14:27

有很多个文件夹，需要把每个文件夹的图片的名字改成对应的文件夹名字，图片名字没有规律
比如A文件夹里的图片名字改为A.jpg
B文件夹里的图片名字改为B.jpg
感谢大神

最佳答案

hwc2ycy

2013-11-17 15:25

只有一个就用这个。

复制代码

hwc2ycy · 发表于 2013-11-17 14:47

如果文件夹里有很多文件呢？

sayounala · 发表于 2013-11-17 14:50

每个文件夹只有一个图片，没有其他文件

hwc2ycy · 发表于 2013-11-17 15:23

本帖最后由 hwc2ycy 于 2013-11-17 15:26 编辑

一个文件夹中有多个jpg文件就按目录名-序号.jpg 方式命名

Sub Main()
Call ListDirs(ThisWorkbook.Path)
End Sub
Sub ListDirs(ByVal Path As String)
Dim StrFileName$
Dim arrPath(1 To 1000)
Dim sPath$
Dim i&, j&, k As Integer
i = 1: j = 1: k = 0
If Not Path Like "*" Then Path = Path & Application.PathSeparator
arrPath(i) = Path
On Error Resume Next
sPath = arrPath(j)
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
i = i + 1
arrPath(i) = sPath & StrFileName & Application.PathSeparator
Else
If LCase(StrFileName) Like "*.jpg" Then
k = k + 1
Debug.Print sPath, StrFileName, k
Call Rename(sPath, StrFileName, k)
End If
End If
End If
End1If:
StrFileName = Dir
Loop
j = j + 1
k = 0
If j > i Then Exit Do
sPath = arrPath(j)
Loop
End Sub
Sub Rename(strpath As String, StrFileName As String, k As Integer)
Dim strFolder$
Dim arr
Dim strNewName$
arr = Split(strpath, "")
strFolder = arr(UBound(arr) - 1)
strNewName = strpath & strFolder & "-" & k & Mid(StrFileName, InStrRev(StrFileName, "."))
Name strpath & StrFileName As strNewName
End Sub

复制代码

hwc2ycy · 发表于 2013-11-17 15:25

只有一个就用这个。

复制代码

sayounala · 发表于 2013-11-17 15:31

hwc2ycy 发表于 2013-11-17 15:25
只有一个就用这个。

太感谢了

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