anonymous No title
No License VBA
2021年04月11日
Copy Clone
Option Explicit

Sub タイムスタンプ修正(targetFile_FullPath As String)

    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    Dim FO As Object
    
    'ファイルの存在確認
    If Not FSO.FileExists(targetFile_FullPath) Then
        MsgBox targetFile_FullPath & "が存在しません。", vbCritical + vbOKOnly
        GoTo finally
    End If
    
    Set FO = FSO.GetFile(targetFile_FullPath)
    
    'ファイルタイプチェック ※言語設定やOSバージョンによってどうなる??
    If Not FO.Type = "JPG ファイル" Then
        MsgBox "ファイルタイプが処理対象(JPG ファイル)とは異なります。", vbCritical + vbOKOnly
        GoTo finally
    End If
    '拡張子チェック ※文字列だけなのでざる
    'If Not StrConv(targetFile_FullPath, vbNarrow + vbUpperCase) Like "*JPG" Then
    '    MsgBox "拡張子が処理対象(*.jpg)とは異なります。", vbCritical + vbOKOnly
    '    GoTo finally
    'End If
    
    Dim dateModify As Date
    dateModify = getExifDTOrig(targetFile_FullPath)
    
    If dateModify = 0 Then
        MsgBox "画像ファイルから撮影日時を取得できませんでした。" & vbCrLf & "処理を中断します。", vbCritical + vbOKOnly
        Exit Sub
    End If
    
    If MsgBox("指定ファイル[" & targetFile_FullPath & "]の" & vbCrLf _
            & "タイムスタンプを変更しますがよろしいでしょうか?" & vbCrLf _
            & vbCrLf _
            & "現作成日:" & Format(FO.DateCreated, "yyyy/mm/dd hh:mm:ss") & vbCrLf _
            & "現更新日:" & Format(FO.DateLastModified, "yyyy/mm/dd hh:mm:ss") & vbCrLf _
            & "変 更 値:" & Format(dateModify, "yyyy/mm/dd hh:mm:ss"), vbQuestion + vbYesNo) = vbNo Then
            
            GoTo finally
    End If
    
    Dim pCmd As String
    
    '作成日時変更
    pCmd = "Set-ItemProperty '" & targetFile_FullPath & "' -Name CreationTime -Value '" & Format(dateModify, "yyyy/mm/dd hh:mm:ss") & "'"
    Call runPowerShell(pCmd)
    
    '更新日時変更
    pCmd = "Set-ItemProperty '" & targetFile_FullPath & "' -Name LastWriteTime -Value '" & Format(dateModify, "yyyy/mm/dd hh:mm:ss") & "'"
    Call runPowerShell(pCmd)
    
    MsgBox "更新完了", vbInformation + vbOKOnly


'共通終了処理
finally:
    
    Set FO = Nothing
    Set FSO = Nothing

End Sub

Sub runPowerShell(pCmd)

    Dim WSH, wExec, sCmd As String
    Set WSH = CreateObject("WScript.Shell")
    
    sCmd = "powershell -ExecutionPolicy RemoteSigned -Command """ & pCmd & """"
    WSH.Run sCmd, 0, True
    
    Set WSH = Nothing

End Sub

Function getExifDTOrig(jpgFile_FullPath As String) As Date

    Dim WIA As Object
    Set WIA = CreateObject("Wia.ImageFile")
    
    On Error GoTo catch
    
    WIA.LoadFile jpgFile_FullPath
    
    'Exif情報にExifDTOrigがあるか確認
    Dim prop
    For Each prop In WIA.Properties
        If prop.Name = "ExifDTOrig" Then
            GoTo hasExifDTOrig
        End If
    Next prop
    
    getExifDTOrig = 0
    
    GoTo finally
    
'hasExifDTOrigがあった場合の処理
hasExifDTOrig:
    
    On Error GoTo 0
    
    Dim StrDate As String
    StrDate = Replace(WIA.Properties("ExifDTOrig").Value, ":", "/", 1, 2, vbTextCompare)
    
    If IsDate(StrDate) Then
        getExifDTOrig = CDate(StrDate)
    Else
        getExifDTOrig = 0
    End If
    
    GoTo finally

'何かしらのエラーがあった場合(不正データによる参照エラーなど)
catch:

    'Debug.Print "[ERROR][getExifDTOrig] " & Err.Description
    getExifDTOrig = 0

'共通終了処理
finally:

    Set WIA = Nothing

End Function
Option Explicit

Sub タイムスタンプ修正(targetFile_FullPath As String)

    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    Dim FO As Object
    
    'ファイルの存在確認
    If Not FSO.FileExists(targetFile_FullPath) Then
        MsgBox targetFile_FullPath & "が存在しません。", vbCritical + vbOKOnly
        GoTo finally
    End If
    
    Set FO = FSO.GetFile(targetFile_FullPath)
    
    'ファイルタイプチェック ※言語設定やOSバージョンによってどうなる??
    If Not FO.Type = "JPG ファイル" Then
        MsgBox "ファイルタイプが処理対象(JPG ファイル)とは異なります。", vbCritical + vbOKOnly
        GoTo finally
    End If
    '拡張子チェック ※文字列だけなのでざる
    'If Not StrConv(targetFile_FullPath, vbNarrow + vbUpperCase) Like "*JPG" Then
    '    MsgBox "拡張子が処理対象(*.jpg)とは異なります。", vbCritical + vbOKOnly
    '    GoTo finally
    'End If
    
    Dim dateModify As Date
    dateModify = getExifDTOrig(targetFile_FullPath)
    
    If dateModify = 0 Then
        MsgBox "画像ファイルから撮影日時を取得できませんでした。" & vbCrLf & "処理を中断します。", vbCritical + vbOKOnly
        Exit Sub
    End If
    
    If MsgBox("指定ファイル[" & targetFile_FullPath & "]の" & vbCrLf _
            & "タイムスタンプを変更しますがよろしいでしょうか?" & vbCrLf _
            & vbCrLf _
            & "現作成日:" & Format(FO.DateCreated, "yyyy/mm/dd hh:mm:ss") & vbCrLf _
            & "現更新日:" & Format(FO.DateLastModified, "yyyy/mm/dd hh:mm:ss") & vbCrLf _
            & "変 更 値:" & Format(dateModify, "yyyy/mm/dd hh:mm:ss"), vbQuestion + vbYesNo) = vbNo Then
            
            GoTo finally
    End If
    
    Dim pCmd As String
    
    '作成日時変更
    pCmd = "Set-ItemProperty '" & targetFile_FullPath & "' -Name CreationTime -Value '" & Format(dateModify, "yyyy/mm/dd hh:mm:ss") & "'"
    Call runPowerShell(pCmd)
    
    '更新日時変更
    pCmd = "Set-ItemProperty '" & targetFile_FullPath & "' -Name LastWriteTime -Value '" & Format(dateModify, "yyyy/mm/dd hh:mm:ss") & "'"
    Call runPowerShell(pCmd)
    
    MsgBox "更新完了", vbInformation + vbOKOnly


'共通終了処理
finally:
    
    Set FO = Nothing
    Set FSO = Nothing

End Sub

Sub runPowerShell(pCmd)

    Dim WSH, wExec, sCmd As String
    Set WSH = CreateObject("WScript.Shell")
    
    sCmd = "powershell -ExecutionPolicy RemoteSigned -Command """ & pCmd & """"
    WSH.Run sCmd, 0, True
    
    Set WSH = Nothing

End Sub

Function getExifDTOrig(jpgFile_FullPath As String) As Date

    Dim WIA As Object
    Set WIA = CreateObject("Wia.ImageFile")
    
    On Error GoTo catch
    
    WIA.LoadFile jpgFile_FullPath
    
    'Exif情報にExifDTOrigがあるか確認
    Dim prop
    For Each prop In WIA.Properties
        If prop.Name = "ExifDTOrig" Then
            GoTo hasExifDTOrig
        End If
    Next prop
    
    getExifDTOrig = 0
    
    GoTo finally
    
'hasExifDTOrigがあった場合の処理
hasExifDTOrig:
    
    On Error GoTo 0
    
    Dim StrDate As String
    StrDate = Replace(WIA.Properties("ExifDTOrig").Value, ":", "/", 1, 2, vbTextCompare)
    
    If IsDate(StrDate) Then
        getExifDTOrig = CDate(StrDate)
    Else
        getExifDTOrig = 0
    End If
    
    GoTo finally

'何かしらのエラーがあった場合(不正データによる参照エラーなど)
catch:

    'Debug.Print "[ERROR][getExifDTOrig] " & Err.Description
    getExifDTOrig = 0

'共通終了処理
finally:

    Set WIA = Nothing

End Function
No one still commented. Please first comment.