[UMU WSH 教程](46) 按图片拍摄时间批量重命名改进版

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

+文件内容对比，内容一样的删除其中一个。

+输出日志

' 46_RenameImageToDateTime.VBS
' UMU @ 16:33 2014/12/5
' [UMU WSH 教程](46) WIA 和 WindowsInstaller 应用实例 - 按图片拍摄时间批量重命名并去重
Option Explicit

Const APP_TITLE = "UMU.Script.Tools.RenameImageToDateTime+"
Const APP_DESCRIPTION = "本程序用来把带 EXIF 信息的图片按拍摄时间批量重命名。"
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("重命名文件？按“否”复制文件，按“取消”退出！" & vbCrLf & "如果选择“是”则文件重复时，会删除多余文件。", 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 RenameImageToDateTime_s(ar)
        ElseIf fso.FileExists(ar) Then
            Call RenameImageToDateTime(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 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 0 = StrComp(file_path, path, vbTextCompare) Then
            ' 路径一样，不做处理
            exists_count = exists_count + 1
            If is_logging = vbYes Then
                log_file.WriteLine "=" & file_path
                log_file.WriteLine "="
                log_file.WriteLine "----------------"
            End If
        ElseIf 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 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("ExifDTOrig", "ExifDTDigitized", "DateTime")
    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

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(ByRef 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

 

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