ExcelVBAで動画を「メディアの作成日時」にリネームする

iPhoneで撮った動画のファイル名 IMG_0000.MOV を、「メディアの作成日時」から取得した YYYYMMDD_hh_nn.MOV に変更したいなって思って作ったコードです。探せばそういうツールはありますし、Excelでやる必要はありませんが、自分の慣れている言語でやったらどうなるのかなっていう好奇心のメモです。

動画をリサイズしたいので先にファイル名を変えておきたい

我が家も小さい子がおりますので、日々写真を撮ったり動画を録ったりするものですが、ま～～～、今の時代、容量がエグいですよね。全部高画質で残しておいたらストレージがいくらあっても足りないので、年末に1年分のデータを整理して、そこそこ見れる画質にリサイズするのですが。それでも、「いつ撮られたものか」だけはわかるようにしておきたい。

写真だったらexif情報残したままリサイズできるツールもそこそこあるものの、動画だと別ファイルに書き出しになってしまうので（私の知識が足りないだけかもしれないけど）、一番手間がかからずに大量に処理するには、ファイル名を撮影日時にしておいて、それからリサイズしちゃうのが理想だなぁと思って。

「更新日時」だったらわりとかんたんに取り出せるものの、ちょっとズレがある…、「メディアの作成日時」をひっぱってきたいな、という趣旨です。

目当てのヘッダ番号を調べる

いつもお世話になっている田中先生のサイトで、ExcelのGetOpenFilenameメソッドでファイル情報を取得できるコードが紹介されていました。いつもありがとうございます！

• Office TANAKA – その他のテクニック[MP3の「曲の長さ」を調べる]

上の記事の最後の方にある「すべてのヘッダ番号を調べる」コードで、私のさわれる範囲内のWin10とWin11では、どちらも「メディアの作成日時」はID:208でした。一応お使いの環境で調べてもらったほうが良いと思います！

動画の入っているフォルダと一覧を書き出す用のシートを用意

適当に、こんな感じで。フォルダのパスをB3セルに書いておきます。

取得して一覧にする

以下のコードを実行します。

Sub getDateCreated()
  Dim path As String: path = Range("B3") 'パス
  
  Dim fileName As String, ex As String
  Dim row As Long: row = 6
  
  With CreateObject("Scripting.FileSystemObject")
    Dim files As Object: Set files = .GetFolder(path).files
    Dim file As Object, i As Long
    For Each file In files
      fileName = Replace(file, path & "\", "")
      ex = Right(fileName, Len(fileName) - InStrRev(fileName, ".") + 1)
      fileName = Replace(fileName, ex, "")
      
      Cells(row, 2).Value = fileName 'ファイル名
      Cells(row, 4).Value = ex '拡張子
      
      '変数準備
      Dim shell: Set shell = CreateObject("Shell.Application")
      Dim fol: Set fol = shell.Namespace(.GetFile(file).ParentFolder.path)
      
      'メディアの作成日時を取得
      Cells(row, 3).Value = fol.GetDetailsOf(fol.ParseName(.GetFile(file).name), 208)
      
      '片付け
      Set fol = Nothing
      Set shell = Nothing
      
      row = row + 1
    Next file
  End With
End Sub

以下のように、今あるファイル名と「メディアの作成日時」、拡張子を分離して一覧取得します。

取得できました。

読めない部分を取り除いて整形

一見、きれいに日付型で取れてると思いきや、読み込めない文字コードが含まれているようで、このままFormatで整形がうまくできませんでした。

「？」部分の文字コードを調べて取り除く工程を加えます。

Sub getDateCreated()
  Dim path As String: path = Range("B3") 'パス
  
  Dim fileName As String, ex As String
  Dim row As Long: row = 6
  
  With CreateObject("Scripting.FileSystemObject")
    Dim files As Object: Set files = .GetFolder(path).files
    Dim file As Object, i As Long
    For Each file In files
      fileName = Replace(file, path & "\", "")
      ex = Right(fileName, Len(fileName) - InStrRev(fileName, ".") + 1)
      fileName = Replace(fileName, ex, "")
      
      Cells(row, 2).Value = fileName 'ファイル名
      Cells(row, 4).Value = ex '拡張子
      
      '変数準備
      Dim shell: Set shell = CreateObject("Shell.Application")
      Dim fol: Set fol = shell.Namespace(.GetFile(file).ParentFolder.path)
      
      'メディアの作成日時を取得
      Dim baff As String
      baff = fol.GetDetailsOf(fol.ParseName(.GetFile(file).name), 208)

      '読み込めない部分を文字コードで判別して取り除く
      i = 1
      Do While Len(baff) > i
        If AscW(Mid(baff, i, 1)) = 8206 Or AscW(Mid(baff, i, 1)) = 8207 Then
          baff = Left(baff, i - 1) & Right(baff, Len(baff) - i)
          i = i - 1
        End If
        i = i + 1
      Loop

      '整形して書き出し
      Cells(row, 3).Value = Format(baff, "yyyymmdd_hh_nn")
      
      '片付け
      Set fol = Nothing
      Set shell = Nothing
      
      row = row + 1
    Next file
  End With
End Sub

私の環境では、含まれてた「？」は2種類で文字コードが8206と8207だったので29行目のように書きましたが、もし環境によって違うようでしたらここを直してみてください。

実行するとこうなります。

ファイル名変更

ここまでできたら、あとは上からループしてリネームするコードを走らせます。書き換えたくないものは一覧から削除しちゃえばOK。

ファイルに手を加えるので、実行の際はバックアップしっかり&自己責任でお願いします、念のため。

Sub ReName()
  Dim path As String: path = Range("B3") & "\" 'パス
  
  Dim row As Long
  For row = 6 To Cells(Rows.Count, 2).End(xlUp).row
    Name path & Cells(row, 2).Value & Cells(row, 4).Value As path & Cells(row, 3).Value & Cells(row, 4).Value 'リネーム
  Next row
End Sub

これで大量の動画のファイル名を書き換えることができました！