VBA修改文件属性时间

opel-wong

用以下代码能获取文件属性时间，但不知道如何修改，请教一下，谢谢！

Sub test()
   FilePath = "C:\test\123.xls"
   Dim fs, f, s
   Set fs = CreateObject("Scripting.FileSystemObject")
   Set f = fs.GetFile(FilePath)
   s = UCase(FilePath) & vbCrLf
   s = s & "建立时间: " & f.DateCreated & vbCrLf
   s = s & "最后使用日期与时间: " & f.DateLastAccessed & vbCrLf
   s = s & "最后修改日期与时间: " & f.DateLastModified
   MsgBox s, 0, "File Access Info"
End Sub

‘

tonychris

提供个api方法：



Option Explicit


Private Const OF_READWRITE = &H2
Private Const OFS_MAXPATHNAME = 128


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

Private Type OFSTRUCT
    cBytes As Byte
    fFixedDisk As Byte
    nErrCode As Integer
    Reserved1 As Integer
    Reserved2 As Integer
    szPathName(OFS_MAXPATHNAME) As Byte
End Type


Private Declare Function SystemTimeToFileTime Lib "kernel32" ( _
    lpSystemTime As SYSTEMTIME, _
    lpFileTime As FILETIME) As Long

Private Declare Function LocalFileTimeToFileTime Lib "kernel32" ( _
    lpLocalFileTime As FILETIME, _
    lpFileTime As FILETIME) As Long

Private Declare Function SetFileTime Lib "kernel32" ( _
    ByVal hFile As Long, _
    lpCreationTime As FILETIME, _
    lpLastAccessTime As FILETIME, _
    lpLastWriteTime As FILETIME) As Long

Private Declare Function OpenFile Lib "kernel32" ( _
    ByVal lpFileName As String, _
    lpReOpenBuff As OFSTRUCT, _
    ByVal wStyle As Long) As Long

Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long



Function apiSetFileTime(ByVal PathName As String, ByVal LastWriteTime As String, Optional ByVal CreationTime As String, Optional ByVal LastAccessTime As String) As Boolean

    Dim rtn As Long
    Dim hFile As Long

    Dim ofs As OFSTRUCT

    Dim lpCreationTime As FILETIME
    Dim lpLastWriteTime As FILETIME
    Dim lpLastAccessTime As FILETIME


    If CreationTime = "" Then CreationTime = LastWriteTime
    If LastAccessTime = "" Then LastAccessTime = LastWriteTime

    lpCreationTime = TransformTime(CreationTime)
    lpLastWriteTime = TransformTime(LastWriteTime)
    lpLastAccessTime = TransformTime(LastAccessTime)

    hFile = OpenFile(PathName, ofs, OF_READWRITE)

    rtn = SetFileTime(hFile, lpCreationTime, lpLastAccessTime, lpLastWriteTime)
    If rtn = 1 Then apiSetFileTime = True
    CloseHandle hFile

End Function


Private Function TransformTime(ByVal NewDate As String) As FILETIME

    Dim fTime As FILETIME
    Dim fLTime As FILETIME
    Dim fSysTime As SYSTEMTIME


    With fSysTime '参数 NewDate 的格式 : "yyyy/mm/dd HH:mm:ss"
        .wYear = Year(NewDate)
        .wMonth = Month(NewDate)
        .wDay = Day(NewDate)
        .wHour = Hour(NewDate)
        .wMinute = Minute(NewDate)
        .wSecond = Second(NewDate)
        .wMilliseconds = 0
    End With

    SystemTimeToFileTime fSysTime, fLTime
    LocalFileTimeToFileTime fLTime, fTime

    TransformTime = fTime

End Function

opel-wong

感谢指点，测试下先。

baomaboy

http://club.excelhome.net/thread-781976-1-1.html

taller

请参考拙作 http://club.excelhome.net/thread-232334-1-1.html

opel-wong

非常感谢：taller 版主 与 baomaboy 仁兄 的指点与分享。
下载了连接的中的附件，都是精品。佩服，好好学习。

byhyxb

学习学习......

wwwruc

使用Scripting.FileSystemObject应该不能做到修改时间吧？

游乐缘

tonychris 发表于 2011-10-27 22:33
提供个api方法：

高手风范！在工作表中也可以修改文件属性。

morpheus126

tonychris 发表于 2011-10-27 22:33
提供个api方法：

请教一下，为什么EXCEL和WORD文档访问时间修改不了呢？谢谢！

1. Sub testSetTime()
   
2.     Dim t As Date
   
3.     Dim i As String
   
4.     t = DateSerial(2021, 1, 1) + TimeSerial(1, 1, 1)
   
5.     i = "D:\测试.xlsx"
   
6.     MsgBox apiSetFileTime(i, t, t, t)
   
7. End Sub

复制代码

测试.zip (15.15 KB, 下载次数: 9)

2022-9-7 12:29 上传

点击文件名下载附件