No title
VBA
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
英語サイトを自動翻訳した状態を、そのまま共有する時のURL
Excelファイル一括オープン