投稿者: yuuya

前回の内容のファイル名を変更して貼り付けの処理の説明を行います。

ファイル名の変更処理を行っている内容

フォルダを指定してファイルをコピーして、ファイル名を変更して出力先のフォルダに貼り付けを行っています。

処理の説明

メイン処理

Sub サブフォルダ含むファイル名取得()

    Dim maisu As Integer
    Dim strFolderpass As String
    
    '枚数の初期設定をします。
    maisu = 1
    
    '対象フォルダのパスを設定
    strFolderpass = Range("B1").Value
    
    'ファイルのパスの判定
    If strFolderpass = "" Or Range("B2").Value = "" Then
        MsgBox "対象フォルダのパスがありません。パスを入力してください。"
    Else
        'ファイル名変更のメソッドを呼び出します。
        Call ファイル名変更(strFolderpass, maisu)
    End If

End Sub

メイン処理ではB1とB2にパスが指定されているか判定を行い。入力がされていた場合はファイル名変更のメソッドを呼び出します。

ここでのメソッドは自分で作成した関数みたいものです。

ファイル名変更の処理内容

Sub ファイル名変更(strFolderpass As String, maisu As Integer)

    Dim objfFSO As Object
    Dim objFiles As Object
    Dim objFile As Object
    Dim objSubFolders As Object
    Dim objSubFolder As Object
    Dim fileName, file, filePath As String
    Dim kakucho, seko As String
    Dim i As Integer
    Dim syuturyokuPath As String
    
    
    'ファイルやフォルダを操作するオブジェクトの生成
    Set objfFSO = CreateObject("Scripting.FileSystemObject")

    '対象フォルダのファイルオブジェクトをセット
    Set objFiles = objfFSO.GetFolder(strFolderpass).Files
    
    i = 1
    'ファイルをコピーして出力先のフォルダにファイル名を変更して貼り付け
    For Each objFile In objFiles
        file = objFile.Name
        filePath = objFile.Path
        fileName = Mid(filePath, Len(Range("B1")) + 1, Len(filePath) - Len(Range("B1")) - Len(file))
        fileName = Replace(fileName, "\", "_")
        kakucho = Mid(file, InStr(file, "."))
        syuturyokuPath = Range("B2").Value + "\"
        Select Case i Mod 3
            Case 1
                seko = "施工前"
            Case 2
                seko = "施工中"
            Case Else
                seko = "施工後"
        End Select
        FileCopy filePath, syuturyokuPath & maisu & fileName & seko & kakucho
        
        maisu = maisu + 1
        i = i + 1
    Next objFile
    

    '対象フォルダのサブフォルダファイルオブジェクトをセット
    Set objSubFolders = objfFSO.GetFolder(strFolderpass).SubFolders

    'サブフォルダを含むファイル名取得
    For Each objSubFolder In objSubFolders
     
        If objSubFolder.Name <> "" Then
            
            'サブフォルダのパスをメソッドへ渡して再帰的に処理を行う
            Call ファイル名変更(objSubFolder.Path, maisu)
            
        End If
         
    Next objSubFolder

    '使用したオブジェクトの解放
    Set objfFSO = Nothing
    Set objFiles = Nothing
    Set objFile = Nothing
    Set objSubFolders = Nothing
    Set objSubFolder = Nothing

End Sub

上記で行っている処理の内容

受け取ったパス内にファイルが存在する分だけ処理を繰り返す。

ファイルをコピーして出力先のフォルダにファイル名を変更して貼り付け。

受け取ったパス内にフォルダが存在する分だけ処理を繰り返す。

サブフォルダのパスをファイル名変更メソッドに渡す。

    'サブフォルダを含むファイル名取得
    For Each objSubFolder In objSubFolders
     
        If objSubFolder.Name <> "" Then
            
            'サブフォルダのパスをメソッドへ渡して再帰的に処理を行う
            Call ファイル名変更(objSubFolder.Path, maisu)
            
        End If
         
    Next objSubFolder

ファイル名変更()の処理を行っている最中にさらにファイル名変更()を呼び出す処理を再帰処理といいます。要は同じ処理を呼び出しているだけです。

再帰処理のイメージ

ファイルのコピーの内容

    i = 1
    'ファイルをコピーして出力先のフォルダにファイル名を変更して貼り付け
    For Each objFile In objFiles
        file = objFile.Name
        filePath = objFile.Path
        fileName = Mid(filePath, Len(Range("B1")) + 1, Len(filePath) - Len(Range("B1")) - Len(file))
        fileName = Replace(fileName, "\", "_")
        kakucho = Mid(file, InStr(file, "."))
        syuturyokuPath = Range("B2").Value + "\"
        Select Case i Mod 3
            Case 1
                seko = "施工前"
            Case 2
                seko = "施工中"
            Case Else
                seko = "施工後"
        End Select
        FileCopy filePath, syuturyokuPath & maisu & fileName & seko & kakucho
        
        maisu = maisu + 1
        i = i + 1
    Next objFile

フォルダの指定した位置からサブフォルダに含まれるファイルのパスを取得して、フォルダの指定した場所からファイルの間のサブフォルダ名をファイル名に設定しています。

例　

フォルダの指定　C:\Users\nekon\Desktop\仕事\ファイル一覧

ファイルの位置　C:\Users\nekon\Desktop\仕事\ファイル一覧\場所(1)\工事(1)\IMG00012.jpg

ファイル名を取得

file = objFile.Name

file = IMG00012.jpg

ファイルのパスを取得

filePath = objFile.Path

filePath = C:\Users\nekon\Desktop\仕事\ファイル一覧\場所(1)\工事(1)\IMG00012.jpg

コピーしたいファイルのサブフォルダ名の抜き出し

fileName = Mid(filePath, Len(Range(“B1”)) + 1, Len(filePath) – Len(Range(“B1”)) – Len(file))

fileName = \場所(1)\工事(1)\

\を_に変換

fileName = Replace(fileName, “\”, “_”)

fileName = _場所(1)_工事(1)_

拡張子の取得

kakucho = Mid(file, InStr(file, “.”))

kakucho = .jpg

出力先のパスを設定

syuturyokuPath = Range(“B2”).Value + “\”

syuturyokuPath = C:\Users\nekon\Desktop\仕事\Excel一覧\出力先\

施工状況の設定

        Select Case i Mod 3
            Case 1
                seko = "施工前"
            Case 2
                seko = "施工中"
            Case Else
                seko = "施工後"
        End Select

iを3で割った余りで施工前中後を設定している。

ファイル名を変更して貼り付け

FileCopy コピー元のファイルパス , コピー先のファイルパス

FileCopy filePath, syuturyokuPath & maisu & fileName & seko & kakucho

コピー元 = C:\Users\nekon\Desktop\仕事\ファイル一覧\場所(1)\工事(1)\IMG00012.jpg

コピー先 = C:\Users\nekon\Desktop\仕事\Excel一覧\出力先\&1&_場所(1)_工事(1)_&施工前&.jpg

maisuはファイルをコピーした数です。

処理全体の内容

Sub サブフォルダ含むファイル名取得()

    Dim maisu As Integer
    Dim strFolderpass As String
    
    'ファイル名一覧を出力する行番号を指定します。
    maisu = 1
    
    '対象フォルダのパスを設定
    strFolderpass = Range("B1").Value
    
    'ファイルのパスの判定
    If strFolderpass = "" Or Range("B2").Value = "" Then
        MsgBox "対象フォルダのパスがありません。パスを入力してください。"
    Else
        'ファイル名変更のメソッドを呼び出します。
        Call ファイル名変更(strFolderpass, maisu)
    End If

End Sub




Sub ファイル名変更(strFolderpass As String, maisu As Integer)

    Dim objfFSO As Object
    Dim objFiles As Object
    Dim objFile As Object
    Dim objSubFolders As Object
    Dim objSubFolder As Object
    Dim fileName, file, filePath As String
    Dim kakucho, seko As String
    Dim i As Integer
    Dim syuturyokuPath As String
    
    
    'ファイルやフォルダを操作するオブジェクトの生成
    Set objfFSO = CreateObject("Scripting.FileSystemObject")

    '対象フォルダのファイルオブジェクトをセット
    Set objFiles = objfFSO.GetFolder(strFolderpass).Files
    
    i = 1
    'ファイルをコピーして出力先のフォルダにファイル名を変更して貼り付け
    For Each objFile In objFiles
        file = objFile.Name
        filePath = objFile.Path
        fileName = Mid(filePath, Len(Range("B1")) + 1, Len(filePath) - Len(Range("B1")) - Len(file))
        fileName = Replace(fileName, "\", "_")
        kakucho = Mid(file, InStr(file, "."))
        syuturyokuPath = Range("B2").Value + "\"
        Select Case i Mod 3
            Case 1
                seko = "施工前"
            Case 2
                seko = "施工中"
            Case Else
                seko = "施工後"
        End Select
        FileCopy filePath, syuturyokuPath & maisu & fileName & seko & kakucho
        
        maisu = maisu + 1
        i = i + 1
    Next objFile
    

    '対象フォルダのサブフォルダファイルオブジェクトをセット
    Set objSubFolders = objfFSO.GetFolder(strFolderpass).SubFolders

    'サブフォルダを含むファイル名取得
    For Each objSubFolder In objSubFolders
     
        If objSubFolder.Name <> "" Then
            
            'サブフォルダのパスをメソッドへ渡して再帰的に処理を行う
            Call ファイル名変更(objSubFolder.Path, maisu)
            
        End If
         
    Next objSubFolder

    '使用したオブジェクトの解放
    Set objfFSO = Nothing
    Set objFiles = Nothing
    Set objFile = Nothing
    Set objSubFolders = Nothing
    Set objSubFolder = Nothing

End Sub

ファイル名を変更して貼り付け処理の説明を終わります。

今回の内容で写真一括貼り付けの自動化を完了とします。また、処理を思いついたら追加していきます。

次回は文字列を取得してどの様な処理を行えるか記載していきたいと思います。