照片也属于文件。
在VBA中通过访问文件对象File的DateLastModified、DateCreated、DateLastAccessed等属性可以获取文件的最后一次修改日期、文件的创建日期、以及文件的最后一次打开日期。
然后用Name语句可以将文件重命名,如果需要对文件夹中的所有照片都重命名,还需要添加遍历文件夹代码。
基于以上的知识,可以使用如下的代码将文件夹内的所有JPG照片按照修改日期重命名:
Sub QQ1722187970()
Dim sPath As String
'选择要遍历的文件夹
sPath = GetPath
If Len(sPath) Then
'开始遍历
Call EnuAllFiles(sPath, False)
MsgBox "执行完毕!!!"
End If
End Sub
Function GetPath() As String
'声明一个FileDialog对象变量
Dim oFD As FileDialog
Dim oFDFilter As FileDialogFilters
' '创建一个选择文件对话框
' Set oFD = Application.FileDialog(msoFileDialogFilePicker)
'创建一个选择文件夹对话框
Set oFD = Application.FileDialog(msoFileDialogFolderPicker)
'声明一个变量用来存储选择的文件名
Dim vrtSelectedItem As Variant
With oFD
' .Filters.Clear
' .Filters.Add "Excel文件", "*.xls*", 1
' .Filters.Add "Word文件", "*.doc*", 2
'允许选择多个文件
.AllowMultiSelect = True
'使用Show方法显示对话框,如果单击了确定按钮则返回-1。
If .Show = -1 Then
'遍历所有选择的文件
For Each vrtSelectedItem In .SelectedItems
'获取所有选择的文件的完整路径,用于各种操作
GetPath = vrtSelectedItem
Next
'如果单击了取消按钮则返回0
Else
End If
End With
'释放对象变量
Set oFD = Nothing
End Function
'遍历文件夹及其子文件夹的通用过程,
'sPath参数表示要获取的文件夹的路径,bEnuSub可选参数表示是否遍历子文件夹,不提供表示不遍历子文件夹
'作者:Excel技术服务
'QQ:1722187970
'邮箱:1722187970@qq.com
Sub EnuAllFiles(ByVal sPath As String, Optional bEnuSub As Boolean = False)
'定义文件系统对象
Dim oFso As Object
Set oFso = CreateObject("Scripting.FileSystemObject")
'定义文件夹对象
Dim oFolder As Object
Set oFolder = oFso.GetFolder(sPath)
'定义文件对象
Dim oFile As Object
'如果指定的文件夹含有文件
If oFolder.Files.Count Then
For Each oFile In oFolder.Files
With oFile
'输出文件所在的盘符
Dim sDrive As String
sDrive = .Drive
'输出文件的类型
Dim sType As String
sType = .Type
'输出含后缀名的文件名称
Dim sName As String
sName = .Name
'输出含文件名的完整路径
Dim sFilePath As String
sFilePath = .Path
'输出文件的上次修改时间
Dim dDLM
dDLM = .DateLastModified
'输出文件的上次访问时间
Dim dDLA
dDLA = .DateLastAccessed
'输出文件的创建时间
Dim dDC
dDC = .DateCreated
'输出文件的属性
Dim sATT
sATT = .Attributes
'如果文件是Word文件
If sName Like "*JPG*" Then
'将文件的修改时间转换为文本
sDLM = VBA.Format(dDLM, "yyyymmdd hhmmss")
'修改文件的名称
sName = VBA.Replace(sName, Mid(sName, 1, InStr(1, sName, ".") - 1), sDLM)
'重命名文件的全名称
Name sFilePath As oFolder.Path & "\" & sName
Else
End If
End With
Next
'如果指定的文件夹不含有文件
Else
End If
'如果要遍历子文件夹
If bEnuSub = True Then
'定义子文件夹集合对象
Dim oSubFolders As Object
Set oSubFolders = oFolder.SubFolders
If oSubFolders.Count > 0 Then
For Each oTempFolder In oSubFolders
sTempPath = oTempFolder.Path
Call EnuAllFiles(sTempPath, True)
Next
End If
Set oSubFolders = Nothing
End If
Set oFile = Nothing
Set oFolder = Nothing
Set oFso = Nothing
End Sub


发表评论