iPhoneへ動画コピーする前にプレフィックスをつける

‘パブリック変数を設定します（モジュールの一番上に設定します）
Public Datai As Variant
Public myFolder As String
Public myFolderlen As Long

‘サブフォルダを含むフォルダ内のファイルデータを取得します
‘ファイル一覧に情報を書き出します
‘iphoneへコピーする前にファイル名を変更するためのファイル名をファイル名一覧に追加します

‘ファイル名一覧に追加したファイル名を使ってファイル名の書き換えを行います。

Sub iphone動画ファイルファイル名変換()

myFolder = “D:\■iPhone12同期”

myFolderlen = Len(myFolder)

‘先頭にシート「ファイル一覧」を追加
Worksheets.Add(Before:=Worksheets(1)).Name = “ファイル一覧”

‘ヘッダー行を入力
ActiveSheet.Cells(1, 1).Value = “フォルダパス”
ActiveSheet.Cells(1, 2).Value = “サブフォルダパス”
ActiveSheet.Cells(1, 3).Value = “ファイルパス”
ActiveSheet.Cells(1, 4).Value = “ファイル名”
ActiveSheet.Cells(1, 5).Value = “拡張子”
ActiveSheet.Cells(1, 6).Value = “ファイルサイズ（MB）”
ActiveSheet.Cells(1, 7).Value = “作成日時”
ActiveSheet.Cells(1, 8).Value = “最終更新日時”
ActiveSheet.Cells(1, 9).Value = “最終アクセス日時”
ActiveSheet.Cells(1, 10).Value = “変更後ファイル名プレフィックス”
ActiveSheet.Cells(1, 11).Value = “変更後ファイルパス”
ActiveSheet.Cells(1, 12).Value = “ファイル名変更進捗”
ActiveSheet.Cells(1, 13).Value = “SJIS判定用”
ActiveSheet.Cells(1, 14).Value = “ファイル名SJIS判定結果”

‘ヘッダーをボールドに設定
Range(“A1”, “N1”).Font.Bold = True

Datai = 1
Call sub_Test13(myFolder)

Call SJIS判定

‘列幅設定
Columns(“A”).ColumnWidth = 30
Columns(“B”).ColumnWidth = 30
Columns(“C”).ColumnWidth = 50
Columns(“D”).ColumnWidth = 50
Columns(“E:I”).AutoFit
Columns(“J”).ColumnWidth = 50
Columns(“K”).ColumnWidth = 50
Columns(“L:N”).AutoFit

Call sub_iPhoneファイルコピー準備_ファイル名変換


Call sub_ファイル一覧情報のファイル保存

MsgBox “処理が終了しました。”
End Sub

Sub sub_Test13(FolderPath As Variant)

'参照設定をします
Dim FSO As Object, Folder As Variant, File As Variant
Set FSO = CreateObject("Scripting.FileSystemObject")

'フォルダ内のサブフォルダを探します
For Each Folder In FSO.GetFolder(FolderPath).SubFolders
    Call sub_Test13(Folder)
Next

'フォルダ内のファイルを探索します
For Each File In FSO.GetFolder(FolderPath).Files
    Datai = Datai + 1
    ActiveSheet.Cells(Datai, 1) = FolderPath 'フォルダパス

    Dim myFolderPathCount As Long
    myFolderPathCunt = Len(FolderPath)

    Dim subFolderPath As String
    subFolderPath = Mid(FolderPath, myFolderlen + 2, myFolderPathCunt - Len(myFolderlen))

    ActiveSheet.Cells(Datai, 2) = subFolderPath 'サブフォルダパス
    ActiveSheet.Cells(Datai, 3) = File 'ファイルパス
    ActiveSheet.Cells(Datai, 4) = FSO.GetFileName(File) 'ファイル名
    ActiveSheet.Cells(Datai, 5) = FSO.GetExtensionName(File) '拡張子
    ActiveSheet.Cells(Datai, 6) = FSO.GetFile(File).Size / 1024 / 1024 'ファイルサイズ
    ActiveSheet.Cells(Datai, 6).NumberFormatLocal = "00.00"
    ActiveSheet.Cells(Datai, 7) = FSO.GetFile(File).DateCreated '作成日時
    ActiveSheet.Cells(Datai, 8) = FSO.GetFile(File).DateLastModified '最終更新日時
    ActiveSheet.Cells(Datai, 9) = FSO.GetFile(File).DateLastAccessed '最終アクセス日時

    Dim RepSubFolPath As String
    RepSubFolPath = Replace(Mid(FolderPath, myFolderlen + 2, myFolderPathCunt - Len(myFolderlen)), "\", "_")

    ActiveSheet.Cells(Datai, 10) = RepSubFolPath '変更後ファイル名プレフィックス
    ActiveSheet.Cells(Datai, 11) = FolderPath & "\" & RepSubFolPath & "_" & FSO.GetFileName(File) '変更後ファイルパス
    ActiveSheet.Cells(Datai, 12) = "未"
Next

End Sub

Sub sub_iPhoneファイルコピー準備_ファイル名変換() ‘ファイルを確認してエラー制御

Dim File_function As New Scripting.FileSystemObject

Dim ws01 As Worksheet
Dim lRow, i As Long

‘ Dim FolderName
Dim OldFile, NewFile As String

Set ws01 = Worksheets("ファイル一覧")

‘ FolderName = myFolder ‘保存されている保存先（フォルダー）

lRow = ws01.Cells(Rows.Count, "A").End(xlUp).Row  'A列の最終行を取得

On Error Resume Next

For i = 2 To lRow  'A列の最終行まで繰り返す


    OldFile = ws01.Cells(i, "C")  'A列から旧ファイル名を取得
    NewFile = ws01.Cells(i, "K") 'K列から新ファイル名を取得

    If File_function.FileExists(NewFile) = False Then
           'ファイル名の存在を確認します。既に新ファイル名があれば、変換不可

            Name OldFile As NewFile 'ファイル名を変更します。(旧ファイル⇒新ファイル)
            ws01.Cells(i, "L") = "完了"
        Else
            ws01.Cells(i, "L") = "変換不可"

    End If

Next i

End Sub

Sub sub_ファイル一覧情報のファイル保存()

Dim myFolder As String
myFolder = “D:\■iPhone12同期”

'「ファイル一覧」シートを新しいブックへコピーする
ThisWorkbook.Worksheets("ファイル一覧").Copy

myDate = Format(Now(), "yyyymmdd") '日付

'保存するブックの名前を作成
a = myFolder & "\iPhoneファイルコピー_" & myDate & ".xlsx"

'新しく作成したブックを名前を付けて保存
ActiveWorkbook.SaveAs FileName:=a

ActiveWorkbook.Close

End Sub

Sub SJIS判定()
Dim i As Long
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
Cells(i, 13).Value = Asc(Cells(i, 4).Value)
If isSJIS(Cells(i, 4).Value) Then
Cells(i, 14).Value = “Shift_JIS”
Else
Cells(i, 14).Value = “環境依存”
End If
Next
End Sub

Function isSJIS(ByVal argStr As String) As Boolean
Dim sQuestion As String
sQuestion = Chr(63) ‘?:文字リテラルでは誤解があるといけないので
Dim i As Long
For i = 1 To Len(argStr)
If Mid(argStr, i, 4) <> sQuestion And _
Asc(Mid(argStr, i, 4)) = Asc(sQuestion) Then
isSJIS = False
Exit Function
End If
Next
isSJIS = True
End Function