[UMU WSH 教程](45) WIA 应用实例 - 按图片拍摄时间批量重命名

UMU WSH 教程代码下载：http://sdrv.ms/ZpPPaS

UMU WSH Git：http://git.oschina.net/umu618/umu-wsh

    有些图片不是按照时间命名的，这让 UMU 觉得很蛋疼，因为 UMU 喜欢拍照，从 2006 年有 Nokia 6300 就开始经常拍，然后都按照年份，年份-月份归类了，这样比较好查看。所以这个脚本就诞生了。

' 45_RenameImageToDateTime.VBS
' UMU @ 8:18 2013/10/5
' [UMU WSH 教程](45) WIA 应用实例 - 按图片拍摄时间批量重命名
Option Explicit

Const APP_TITLE = "UMU.Script.Tools.RenameImageToDateTime"
Const APP_DESCRIPTION = "本程序用来把带 EXIF 信息的图片按拍摄时间批量重命名。"
Const APP_USAGE = "请把要处理的文件或文件夹拖放到本程序的图标上！"

Dim args, fso

Set args = WScript.Arguments
Set fso = CreateObject("Scripting.FileSystemObject")

If args.Count = 0 Then
    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 & "\bmp2png.VBE"

    If Not fso.FileExists(copy_to) 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 fso = Nothing
    Set wsh = Nothing
    Set args = Nothing
    WScript.Quit
End If

Dim is_move

is_move = MsgBox("重命名文件？按“否”复制文件，按“取消”退出！", vbYesNoCancel + vbQuestion, "询问")
If vbCancel = is_move Then
    Set args = Nothing
	Set fso = Nothing
    WScript.Quit
End If

Dim target_directory

target_directory = InputBox("请输入存放目录：", "存放目录")
If Len(target_directory) = 0 Then
	Set args = Nothing
	Set fso = Nothing
    WScript.Quit
End If

If Not fso.FolderExists(target_directory) Then
	Set args = Nothing
	Set fso = Nothing
	MsgBox target_directory, vbError, "存放目录不存在"
    WScript.Quit
End If

If Right(target_directory, 1) <> "\" Then
	target_directory = target_directory & "\"
End If

Dim ar, succeeded_count, failed_count, exists_count

succeeded_count = 0
failed_count = 0
exists_count = 0

For Each ar In args
    If fso.FolderExists(ar) Then
        Call RenameImageToDateTime_s(ar)
    ElseIf fso.FileExists(ar) Then
        Call RenameImageToDateTime(ar)
    End If
Next

Set args = Nothing
Set fso = Nothing

MsgBox "重命名 " & succeeded_count & " 个，失败 " & failed_count & _
    " 个，文件已经存在 " & exists_count & " 个！", 4160, "整个世界清净了！"

Private Sub RenameImageToDateTime_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 RenameImageToDateTime(f.Path)
    Next

    Set fds = rfd.SubFolders
    For Each fd In fds
        Call RenameImageToDateTime_s(fd.Path)
    Next
End Sub

Private Sub RenameImageToDateTime(ByRef file_path)
    On Error Resume Next

	Dim dt

	dt = GetImageDateTime(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
		ElseIf vbYes = is_move Then
			fso.MoveFile file_path, path
			If Err.Number <> 0 Then
				failed_count = failed_count + 1
				Err.Clear
			Else
				succeeded_count = succeeded_count + 1
			End If
		Else
			fso.CopyFile file_path, path
			If Err.Number <> 0 Then
				failed_count = failed_count + 1
				Err.Clear
			Else
				succeeded_count = succeeded_count + 1
			End If
		End If
	End If
End Sub

Private Function GetImageDateTime(ByRef file_path)
    On Error Resume Next

    GetImageDateTime = ""

    Dim image_file

    Set image_file = CreateObject("WIA.ImageFile")
    image_file.LoadFile file_path
    If Err.Number <> 0 Then
	' 可能不是图像，或者图像格式无法识别
        Exit Function
    End If

	Dim dt
	Dim prop_names
	Dim name

	prop_names = Array("DateTime", "ExifDTOrig", "ExifDTDigitized")
	For Each name In prop_names
		If image_file.Properties.Exists(name) Then
			Dim prop

			Set prop = image_file.Properties(name)
			dt = prop.Value
			Set prop = Nothing
			Exit For
		End If
	Next
	Set image_file = Nothing

	If Len(dt) > 0 Then
		dt = Replace(dt, "/", "-")
		dt = Replace(dt, ":", "-")
		dt = Replace(dt, " ", "_")
		GetImageDateTime = dt
	End If
End Function

 

转载于:https://my.oschina.net/umu618/blog/167024