VB API 批量修改文件和文件夹的创建时间、最后修改时间、最后访问时间

cbtaja · 发表于 2013-10-5 07:40

Option Explicit
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" _
(ByVal lpFileName As String, ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, _
ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As Long) 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 SystemTimeToFileTime Lib "kernel32" _
(lpSystemTime As SYSTEMTIME, lpFileTime As FILETIME) As Long
'----------------------------------------------------------------------
Private Declare Function FileTimeToSystemTime Lib "kernel32" _
(lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32" _
(lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
'----------------------------------------------------------------------
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetTimeZoneInformation Lib "kernel32" (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
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 TIME_ZONE_INFORMATION
Bias As Long
StandardName(0 To ((32 * 2) - 1)) As Byte 'unicode
StandardDate As SYSTEMTIME
StandardBias As Long
DaylightName(0 To ((32 * 2) - 1)) As Byte 'unicode
DaylightDate As SYSTEMTIME
DaylightBias As Long
End Type
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const OPEN_EXISTING = 3
Private Const FILE_FLAG_BACKUP_SEMANTICS = &H2000000
Private Const INVALID_HANDLE_VALUE = -1
Public wjgs As Long, wjzgs As Long '文件个数,文件总数
Public wjjgs As Long, wjjzgs As Long '文件夹个数,文件夹总数
Public maxLevel As Long, curMaxLevel As Long '限制搜索包含的子文件夹最大层数,当前已经搜索达到的最大层数
Public Flg As Boolean '不限定搜索子文件夹的层数时，标记Flg为真
Private Function TimeZoneVal() As Integer
Dim lpTimeZoneInformation As TIME_ZONE_INFORMATION
' Dim tmp As String
' Dim pos As Integer
GetTimeZoneInformation lpTimeZoneInformation
' tmp = lpTimeZoneInformation.StandardName
' pos = InStr(tmp, Chr$(0))
' MsgBox Left$(tmp, Len(tmp) - pos)
TimeZoneVal = lpTimeZoneInformation.Bias / 60
End Function
Private Function SetFlTime(DirName As String, NewCreationTime As SYSTEMTIME, _
NewLastAccessTime As SYSTEMTIME, NewLastWriteTime As SYSTEMTIME) As Boolean '修改文件（夹）的创建时间、访问时间、最后修改时间
Dim hDir As Long
Dim lpCreationTime As FILETIME
Dim lpLastAccessTime As FILETIME
Dim lpLastWriteTime As FILETIME
Dim retval As Boolean
Dim sAttribute As SECURITY_ATTRIBUTES
hDir = CreateFile(DirName, GENERIC_WRITE, FILE_SHARE_READ, sAttribute, _
OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0) '获得文件句柄
If hDir = INVALID_HANDLE_VALUE Then SetFlTime = False: Exit Function
SystemTimeToFileTime NewCreationTime, lpCreationTime '转换系统时间为文件时间
SystemTimeToFileTime NewLastWriteTime, lpLastWriteTime
SystemTimeToFileTime NewLastAccessTime, lpLastAccessTime
'---------
retval = SetFileTime(hDir, lpCreationTime, lpLastAccessTime, lpLastWriteTime)
'本句为核心代码：使用“系统文件句柄”和给定的3项文件时间做参数，对文件（夹）进行“时间属性”的修改设置
CloseHandle (hDir)
SetFlTime = retval
End Function
Sub CommandButton1_Click()
Dim stm As String, flNm As String, fltChr As String
Dim i As Long
Dim dlgAnswer As Object, objSrc As Object
Dim fldName As String, flNames As String, flName As String
Dim tm1 As String, tm2 As String, tm3 As String
Dim blltnStr As String
Dim fltYesNo As Boolean, regExFltBool As Boolean, flYesNo As Boolean
Dim foldersYesNo As Boolean, filesYesNo As Boolean
Dim subfoldersYesNo As Boolean
Dim tm As String
Dim st1 As Date, st2 As Date, st3 As Date
Dim maxLevel As Long
'--------浏览并指定文件夹路径--------
Set objSrc = CreateObject("Shell.Application")
Set dlgAnswer = objSrc.BrowseForFolder(0, "请选择文件目录:", 0, "")
If dlgAnswer Is Nothing Then Exit Sub
fldName = dlgAnswer.self.Path
Set objSrc = Nothing
Set dlgAnswer = Nothing
'-------获得3个时间参数------------
tm = InputBox("请输入有效的日期时间", "提示：输入文件创建时间", Now): If tm <> "" Then st1 = CDate(tm)
tm = InputBox("请输入有效的日期时间", "提示：输入文件最后访问时间", Now): If tm <> "" Then st2 = CDate(tm)
tm = InputBox("请输入有效的日期时间", "提示：输入文件最后修改时间", Now): If tm <> "" Then st3 = CDate(tm)
'-------获得文件(夹)名称筛选条件特征字符参数-
fltYesNo = (MsgBox("是否需要对文件（夹）按名称筛选？", vbYesNo, "文件&文件夹名称筛选提示") = vbYes)
If fltYesNo Then
regExFltBool = MsgBox("是否以正则表达式进行筛选？", vbOKCancel, "筛选模式") = vbOK
fltChr = Application.InputBox("请输入文件（夹）名称筛选条件，例如：" _
& Chr(10) & "全部文件,*.*" & Chr(10) _
& "多种选择时请用英文冒号"":""分隔", _
"输入文件名称筛选条件", Type:=2)
If fltChr = "" Then fltChr = "*"
End If
'-------是否处理文件夹-------
foldersYesNo = (MsgBox("是否需要对文件夹进行处理？", vbYesNo, "请确认：是否包含文件夹？") = vbYes)
'-------是否处理文件-------
filesYesNo = (MsgBox("是否需要对文件进行处理？", vbYesNo, "请确认：是否包含文件？") = vbYes)
'-------是否对子文件夹进行搜索处理-------
subfoldersYesNo = (MsgBox("是否包含子文件夹？", vbYesNo, "请确认：是否包含所有子文件夹") = vbYes)
'-------限定多层子文件夹的搜索深度-------
maxLevel = Application.InputBox("限定最多搜索至第n层子文件夹，默认不限制（n=0），n=：", "限定多层子文件夹的搜索深度", 0, Type:=1)
Flg = maxLevel < 1
'-----计算其它几项参数--------------
curMaxLevel = UBound(Split(fldName, "")) + 1: maxLevel = maxLevel + curMaxLevel: wjjzgs = 0: wjzgs = 0
'-----代入参数运行--------------
digui fldName, st1, st2, st3, fltYesNo, fltChr, regExFltBool, foldersYesNo, filesYesNo, subfoldersYesNo, maxLevel, wjjzgs, wjzgs
'-----报告执行结果--------------
blltnStr = IIf(subfoldersYesNo, "共", "未") & "搜索子文件夹" & IIf(subfoldersYesNo, curMaxLevel - 1 - UBound(Split(fldName, "")) & "层", "")
MsgBox "报告：一、" & blltnStr & "；二、总共处理了：文件夹" & wjjzgs & "个，文件" & wjzgs & "个！"
End Sub
Function digui(fldName As String, crtTime As Date, lstAccTime As Date, lstWrtTime As Date, fltYesNo As Boolean, fltChr As String, _
regExFltBool, foldersYesNo As Boolean, filesYesNo As Boolean, subfoldersYesNo As Boolean, maxLevel As Long, _
wjjgs As Long, wjgs As Long)
'参数共包含：文件夹名称,创建时间,访问时间,修改时间,是否按名称筛选,筛选用特征字串,_
'是否用正则表达式作为筛选模式,是否处理文件夹,是否处理文件,是否搜索子文件夹,限定搜索子文件夹的最大层数,_
'已经处理的文件夹个数,已经处理的文件个数
Dim fs, f, f1, s, sf, sfld, mfld
Dim flName As String, sfn As String
Dim lpcrtTime As SYSTEMTIME, lplstAccTime As SYSTEMTIME, lplstWrtTime As SYSTEMTIME
Dim i As Long, j As Long
Dim retva As Boolean
'---使用自定义函数,计算出相应的时间--------------------------
lpcrtTime = 函数(crtTime)
lplstAccTime = 函数(lstAccTime)
lplstWrtTime = 函数(lstWrtTime)
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(fldName)
With Application
.DisplayStatusBar = True
If foldersYesNo Then '处理文件夹自身，先筛选再执行
curMaxLevel = Application.Max(UBound(Split(fldName, "")), curMaxLevel)
If fltYesNo Then
If fldName Like fltChr Then
'MsgBox fldName
retva = SetFlTime(fldName, lpcrtTime, lplstAccTime, lplstWrtTime)
If retva Then wjjgs = wjjgs + 1
If (wjjgs Mod 5) = 0 Then .StatusBar = "已经处理：文件夹" & wjjgs & "个，文件" & wjgs & "个"
End If
Else:
'MsgBox fldName
SetFlTime fldName, lpcrtTime, lplstAccTime, lplstWrtTime
retva = SetFlTime(fldName, lpcrtTime, lplstAccTime, lplstWrtTime)
If retva Then wjjgs = wjjgs + 1
End If
End If
If filesYesNo Then '处理文件
For Each f1 In f.Files
flName = f1.Path
If fltYesNo Then
If fltBool(flName, fltChr) Then
'MsgBox flName
retva = SetFlTime(flName, lpcrtTime, lplstAccTime, lplstWrtTime)
If retva Then wjgs = wjgs + 1
If (wjgs Mod 5) = 0 Then .StatusBar = "已经处理：文件夹" & wjjgs & "个，文件" & wjgs & "个"
End If
Else:
'MsgBox flName
retva = SetFlTime(flName, lpcrtTime, lplstAccTime, lplstWrtTime)
If retva Then wjgs = wjgs + 1
If (wjgs Mod 5) = 0 Then .StatusBar = "已经处理：文件夹" & wjjgs & "个，文件" & wjgs & "个"
End If
Next
End If
If subfoldersYesNo Then '搜索子文件夹
Set sfld = f.SubFolders
If sfld.Count > 0 Then
If Flg Or UBound(Split(f.Path, "")) + 1 < maxLevel Then
For Each sf In sfld
sfn = sf.Path
digui sfn, crtTime, lstAccTime, lstWrtTime, fltYesNo, fltChr, regExFltBool, foldersYesNo, filesYesNo, _
subfoldersYesNo, maxLevel, wjjzgs, wjzgs
Next
End If
End If
End If
.StatusBar = False
End With
End Function
Private Function 函数(lpTime As Date) As SYSTEMTIME '自定义函数，转换文件时间到当地系统时间
' If IsNumeric(lpTime) Then
With 函数
.wYear = Year(lpTime)
.wMonth = Month(lpTime)
.wDay = Day(lpTime)
.wDayOfWeek = Weekday(lpTime)
.wHour = Hour(lpTime) + TimeZoneVal()
'TimeZoneVal()为格林尼冶时间与当前系统时区时间的差值，_
'例如当前选择北京时间，则为“东八区”，即TimeZoneVal()=- 8
.wMinute = Minute(lpTime)
.wSecond = Second(lpTime)
End With
' End If
End Function
Private Function fltBool(fldName As String, fltChr As String, Optional RegExpUsed As Boolean = False) As Boolean
Dim fltChrs, subfltChr
Dim regEx, Match, Matches ' 建立变量。
If RegExpUsed Then
'用正则表达式进行匹配筛选
fltChr = Replace(fltChr, "*", ".*")
Set regEx = CreateObject("vbScript.regExp") ' 建立正则表达式。
regEx.Pattern = fltChr 'patrn ' 设置模式。
regEx.IgnoreCase = True ' 设置是否区分字符大小写。
regEx.Global = True ' 设置全局可用性。当执行Test方法时，RegExp.Global属性对结果没有影响。
' regEx.MultiLine = False '多行匹配模式，默认为不开启，因为其作用有限、且开启这个特性可能会导致某些问题
fltBool = regEx.Test(fldName) ' 执行匹配检测。
Else
'用like方法进行匹配筛选
fltChrs = Split(fltChr, ":")
If IsArray(fltChrs) Then
For Each subfltChr In fltChrs
If fldName Like ("*" & subfltChr & "*") Then
fltBool = True: Exit Function
End If
Next
Else
fltBool = fldName Like fltChr
End If
End If
End Function

复制代码

yf_home · 发表于 2013-10-5 14:44

非常不错，跟贴学习。

...

sunny_8848 · 发表于 2013-10-5 14:45

下载学习，多谢楼主

YZC51 · 发表于 2016-1-26 09:44

谢谢！非常不错，跟贴学习。

cbtaja · 发表于 2016-4-25 16:59

fanjy版主做的一个定位单元格在屏幕上的坐标的例子，用到了不少API。其中有SendMessage消息处理函数的用法，可供参考：
http://club.excelhome.net/forum. ... TEyfDMyOTc1Ng%3D%3D

cbtaja · 发表于 2016-5-14 05:57

一个批量转换工作薄中的公式为数值、批量清除工作薄中宏代码的模块：

清除公式和宏.rar (1.3 KB, 下载次数: 51)

18628007372 · 发表于 2017-12-26 13:39

具体操作步骤请详细讲解一下呢

18628007372 · 发表于 2017-12-26 13:41

具体步骤请详细讲解一下，谢谢

teigerhui · 发表于 2019-4-10 00:46

你好，发现在输入时间为2和0等其他小的小时的时候，程序似乎没有反应。为什么呢？

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

[分享] VB API 批量修改文件和文件夹的创建时间、最后修改时间、最后访问时间

评分