UMU WSH Git：http://git.oschina.net/umu618/umu-wsh
' 47_RenameFileByLastModifiedTime.VBS
' UMU @ 0:21 2014/12/4
' [UMU WSH 教程](47) FSO 应用实例 - 按文件最后修改时间批量重命名
' Test code:
' MsgBox WScript.ScriptFullName, , GetFileModifiedTime(WScript.ScriptFullName)
Option Explicit
Const APP_TITLE = "UMU.Script.Tools.RenameFileByLastModifiedTime"
Const APP_DESCRIPTION = "本程序用来把文件按最后修改时间批量重命名。"
Const APP_USAGE = "请把要处理的文件或文件夹拖放到本程序的图标上！"
Dim args, fso, wi
Set args = WScript.Arguments
Set fso = CreateObject("Scripting.FileSystemObject")
Set wi = CreateObject("WindowsInstaller.Installer")
If args.Count = 0 Then
Usage()
Else
Dim is_move
Dim target_directory
Dim is_logging
Dim log_file
Dim succeeded_count, failed_count, exists_count
Main()
End If
Set args = Nothing
Set fso = Nothing
Set wi = Nothing
Private Sub Usage()
Dim wsh
Dim send_to, copy_to
MsgBox APP_DESCRIPTION & vbCrLf & APP_USAGE, vbInformation, APP_TITLE
Set wsh = CreateObject("WScript.Shell")
send_to = wsh.SpecialFolders("SendTo")
copy_to = send_to & "\" & APP_TITLE & ".VBE"
Dim copy_to_sendto
If Not fso.FileExists(copy_to) Then
copy_to_sendto = True
ElseIf Not IsFileTheSame(copy_to, WScript.ScriptFullName) Then
copy_to_sendto = True
Else
copy_to_sendto = False
End If
If copy_to_sendto Then
If vbOK = MsgBox(APP_DESCRIPTION & vbCrLf & APP_USAGE & vbCrLf & vbCrLf & _
"提示：您可以把此文件放在 Sendto 目录里，然后使用右键菜单的“发送到”。" & vbCrLf & _
"您的 Sendto 目录是 " & send_to & vbCrLf & "按“确定”执行复制操作。", _
vbOKCancel + vbInformation, APP_TITLE) Then
fso.CopyFile WScript.ScriptFullName, copy_to
If vbYes = MsgBox("是否查看 Sendto 目录？", vbQuestion + vbYesNo, APP_TITLE) Then
wsh.Run "%SystemRoot%\explorer.exe /n, /select," & copy_to
End If
End If
End If
Set wsh = Nothing
End Sub
Private Sub Main()
is_move = MsgBox("重命名文件？按“否”复制文件，按“取消”退出！", vbYesNoCancel + vbQuestion, "询问")
If vbCancel = is_move Then
Exit Sub
End If
is_logging = MsgBox("产生日志？按“取消”退出！", vbYesNoCancel + vbQuestion, "询问")
If vbCancel = is_logging Then
Exit Sub
End If
If is_logging = vbYes Then
Set log_file = fso.CreateTextFile(fso.GetSpecialFolder(2) & "\" & APP_TITLE & ".log")
End If
target_directory = InputBox("请输入存放目录：", "存放目录")
If Len(target_directory) = 0 Then
Exit Sub
End If
If Not fso.FolderExists(target_directory) Then
MsgBox target_directory, vbError, "存放目录不存在"
Exit Sub
End If
If Right(target_directory, 1) <> "\" Then
target_directory = target_directory & "\"
End If
succeeded_count = 0
failed_count = 0
exists_count = 0
Dim ar
For Each ar In args
If fso.FolderExists(ar) Then
Call RenameFileByLastModifiedTime_s(ar)
ElseIf fso.FileExists(ar) Then
Call RenameFileByLastModifiedTime(ar)
End If
Next
If is_logging = vbYes Then
log_file.Close
Set log_file = Nothing
End If
MsgBox "重命名 " & succeeded_count & " 个，失败 " & failed_count & _
" 个，文件已经存在 " & exists_count & " 个！", 4160, "整个世界清净了！"
End Sub
Private Sub RenameFileByLastModifiedTime_s(ByVal folder_path)
'On Error Resume Next
Dim rfd, fs, f, fds, fd
Set rfd = fso.GetFolder(folder_path)
Set fs = rfd.Files
For Each f In fs
Call RenameFileByLastModifiedTime(f.Path)
Next
Set fds = rfd.SubFolders
For Each fd In fds
Call RenameFileByLastModifiedTime_s(fd.Path)
Next
End Sub
Private Sub RenameFileByLastModifiedTime(ByRef file_path)
'On Error Resume Next
Dim dt
dt = GetFileModifiedTime(file_path)
If Len(dt) > 0 Then
Dim y, m
Dim path
y = Left(dt, 4)
m = Mid(dt, 6, 2)
path = target_directory & y
If Not fso.FolderExists(path) Then
Call fso.CreateFolder(path)
End If
path = path & "\" & y & "-" & m
If Not fso.FolderExists(path) Then
Call fso.CreateFolder(path)
End If
If Err.Number <> 0 Then
failed_count = failed_count + 1
Err.Clear
Exit Sub
End If
Dim ext
ext = Mid(file_path, InStrRev(file_path, "."))
path = path & "\" & dt & ext
If fso.FileExists(path) Then
exists_count = exists_count + 1
If IsFileTheSame(file_path, path) Then
fso.DeleteFile file_path
If is_logging = vbYes Then
log_file.WriteLine "~" & file_path
log_file.WriteLine "@" & path
log_file.WriteLine "----------------"
End If
Else
If is_logging = vbYes Then
log_file.WriteLine file_path
log_file.WriteLine "@" & path
log_file.WriteLine "----------------"
End If
End If
ElseIf vbYes = is_move Then
fso.MoveFile file_path, path
If Err.Number <> 0 Then
failed_count = failed_count + 1
Err.Clear
If is_logging = vbYes Then
log_file.WriteLine "~" & file_path
log_file.WriteLine "-" & path
log_file.WriteLine "----------------"
End If
Else
succeeded_count = succeeded_count + 1
If is_logging = vbYes Then
log_file.WriteLine "~" & file_path
log_file.WriteLine "+" & path
log_file.WriteLine "----------------"
End If
End If
Else
fso.CopyFile file_path, path
If Err.Number <> 0 Then
failed_count = failed_count + 1
Err.Clear
If is_logging = vbYes Then
log_file.WriteLine "&" & file_path
log_file.WriteLine "-" & path
log_file.WriteLine "----------------"
End If
Else
succeeded_count = succeeded_count + 1
If is_logging = vbYes Then
log_file.WriteLine "&" & file_path
log_file.WriteLine "+" & path
log_file.WriteLine "----------------"
End If
End If
End If
Else
' 没有拍照日期
If is_logging = vbYes Then
log_file.WriteLine file_path
log_file.WriteLine "!"
log_file.WriteLine "----------------"
End If
End If
End Sub
Private Function TimeValue(num)
TimeValue = Right("0" & num, 2)
End Function
Private Function MyFormatDateTime(ByRef dt)
MyFormatDateTime = Year(dt) & "-" & TimeValue(Month(dt)) & "-" & TimeValue(Day(dt)) & "_" & TimeValue(Hour(dt)) & "-" & TimeValue(Minute(dt)) & "-" & TimeValue(Second(dt))
End Function
Private Function GetFileModifiedTime(ByRef file_path)
On Error Resume Next
GetFileModifiedTime = ""
Dim file
Set file = fso.GetFile(file_path)
GetFileModifiedTime = MyFormatDateTime(file.DateLastModified)
Set file = Nothing
End Function
Private Function BigEndianHex(int)
Dim result
Dim b1, b2, b3, b4
result = Right("0000000" & Hex(int), 8)
b1 = Mid(result, 7, 2)
b2 = Mid(result, 5, 2)
b3 = Mid(result, 3, 2)
b4 = Mid(result, 1, 2)
BigEndianHex = b1 & b2 & b3 & b4
End Function
Private Function GetFileHash(file_name)
Dim file_hash
Dim hash_value
Dim i
Set file_hash = wi.FileHash(file_name, 0)
hash_value = ""
For i = 1 To file_hash.FieldCount
hash_value = hash_value & BigEndianHex(file_hash.IntegerData(i))
Next
Set file_hash = Nothing
GetFileHash = hash_value
End Function
Private Function IsFileTheSame(ByRef file1, ByRef file2)
If 0 = StrComp(file1, file2, vbTextCompare) Then
IsFileTheSame = True
Else
Dim hash1, hash2
hash1 = GetFileHash(file1)
hash2 = GetFileHash(file2)
If hash1 = hash2 And Len(hash1) > 0 Then
IsFileTheSame = True
Else
IsFileTheSame = False
End If
End If
End Function
