如何用Excel VBA修改其他文件的创建日期？已实现修改日期但创建日期无法修改

我正在用Excel VBA批量修改文件的日期属性，目前已经能成功修改修改日期，但无法修改创建日期。当前使用的代码如下：

Sub update_file_dates()

Dim oFSO    As Object
Dim oShell  As Object
Dim oFile   As Object
Dim oFolder As Object
Dim sFile   As String
Dim rw, erw As Integer

rw = 2
erw = sh01.Cells(sh01.Rows.Count, 1).End(xlUp).Row

Do Until rw > erw

    sFile = sh01.Cells(rw, 2) & "\" & sh01.Cells(rw, 1)
    
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oShell = CreateObject("Shell.Application")
    Set oFile = oFSO.GetFile(sFile)
    Set oFolder = oShell.Namespace(oFile.ParentFolder.Path)
    
    oFolder.Items.Item(oFile.Name).ModifyDate = DateSerial(2000, 1, 12) + TimeSerial(5, 35, 17)
    
    Set oFolder = Nothing
    Set oFile = Nothing
    Set oShell = Nothing
    Set oFSO = Nothing

    rw = rw + 1

Loop

End Sub

问题原因 #

Shell.Application的文件对象中，CreateDate属性是只读的，无法直接赋值修改。需要使用专门的方法来修改创建日期。

解决方案1：基于Shell.Application的SetDateTime方法 #

直接修改现有代码，使用SetDateTime方法来设置创建日期（该方法支持修改三种日期属性）：

Sub update_file_dates()
    Dim oFSO    As Object
    Dim oShell  As Object
    Dim oFile   As Object
    Dim oFolder As Object
    Dim sFile   As String
    Dim rw, erw As Integer
    Dim targetDateTime As Date
    
    ' 定义目标日期时间
    targetDateTime = DateSerial(2000, 1, 12) + TimeSerial(5, 35, 17)
    
    rw = 2
    erw = sh01.Cells(sh01.Rows.Count, 1).End(xlUp).Row

    Do Until rw > erw
        sFile = sh01.Cells(rw, 2) & "\" & sh01.Cells(rw, 1)
        
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        Set oShell = CreateObject("Shell.Application")
        Set oFile = oFSO.GetFile(sFile)
        Set oFolder = oShell.Namespace(oFile.ParentFolder.Path)
        
        ' 修改创建日期（参数0对应创建日期）
        oFolder.Items.Item(oFile.Name).SetDateTime 0, targetDateTime
        ' 可选：修改修改日期（参数1对应修改日期）
        oFolder.Items.Item(oFile.Name).SetDateTime 1, targetDateTime
        ' 可选：修改访问日期（参数2对应访问日期）
        ' oFolder.Items.Item(oFile.Name).SetDateTime 2, targetDateTime
        
        Set oFolder = Nothing
        Set oFile = Nothing
        Set oShell = Nothing
        Set oFSO = Nothing

        rw = rw + 1
    Loop
End Sub

参数说明 #

SetDateTime方法的第一个参数对应日期类型：

• 0：创建日期
• 1：修改日期
• 2：访问日期

解决方案2：使用Windows API（更稳定的底层方法） #

如果需要更好的兼容性，可使用Windows API直接修改文件属性，这种方法不依赖Shell组件：

首先在模块顶部声明API函数和类型：

Private Declare PtrSafe Function SetFileTime Lib "kernel32.dll" (ByVal hFile As LongPtr, lpCreationTime As FILETIME, lpLastAccessTime As FILETIME, lpLastWriteTime As FILETIME) As Boolean
Private Declare PtrSafe Function CreateFile Lib "kernel32.dll" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As LongPtr) As LongPtr
Private Declare PtrSafe Function CloseHandle Lib "kernel32.dll" (ByVal hObject As LongPtr) As Boolean
Private Declare PtrSafe Function SystemTimeToFileTime Lib "kernel32.dll" (lpSystemTime As SYSTEMTIME, lpFileTime As FILETIME) As Boolean
Private Declare PtrSafe Function GetFileTime Lib "kernel32.dll" (ByVal hFile As LongPtr, lpCreationTime As FILETIME, lpLastAccessTime As FILETIME, lpLastWriteTime As FILETIME) As Boolean

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type

然后编写设置创建日期的函数：

Sub SetFileCreationDate(ByVal filePath As String, ByVal newDate As Date)
    Dim hFile As LongPtr
    Dim ftCreate As FILETIME
    Dim ftAccess As FILETIME
    Dim ftWrite As FILETIME
    Dim st As SYSTEMTIME
    
    ' 以读写权限打开文件
    hFile = CreateFile(filePath, &H10000000, 3, ByVal 0&, 3, &H80, 0)
    If hFile = -1 Then Exit Sub
    
    ' 获取文件当前的三个时间属性（保持访问和修改时间不变）
    GetFileTime hFile, ftCreate, ftAccess, ftWrite
    
    ' 将目标日期转换为API需要的格式
    st.wYear = Year(newDate)
    st.wMonth = Month(newDate)
    st.wDay = Day(newDate)
    st.wHour = Hour(newDate)
    st.wMinute = Minute(newDate)
    st.wSecond = Second(newDate)
    SystemTimeToFileTime st, ftCreate
    
    ' 设置新的文件创建日期
    SetFileTime hFile, ftCreate, ftAccess, ftWrite
    
    ' 关闭文件句柄
    CloseHandle hFile
End Sub

最后修改主调用代码：

Sub update_file_dates()
    Dim sFile   As String
    Dim rw, erw As Integer
    Dim targetDate As Date
    
    targetDate = DateSerial(2000, 1, 12) + TimeSerial(5, 35, 17)
    rw = 2
    erw = sh01.Cells(sh01.Rows.Count, 1).End(xlUp).Row

    Do Until rw > erw
        sFile = sh01.Cells(rw, 2) & "\" & sh01.Cells(rw, 1)
        ' 设置创建日期
        SetFileCreationDate sFile, targetDate
        ' 可选：修改修改日期（用FSO即可）
        ' CreateObject("Scripting.FileSystemObject").GetFile(sFile).DateLastModified = targetDate
        rw = rw + 1
    Loop
End Sub

内容的提问来源于stack exchange，提问作者Ian