前回の内容のファイル名を変更して貼り付けの処理の説明を行います。
ファイル名の変更処理を行っている内容
フォルダを指定してファイルをコピーして、ファイル名を変更して出力先のフォルダに貼り付けを行っています。
処理の説明
メイン処理
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 Selectiを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
ファイル名を変更して貼り付け処理の説明を終わります。
今回の内容で写真一括貼り付けの自動化を完了とします。また、処理を思いついたら追加していきます。
次回は文字列を取得してどの様な処理を行えるか記載していきたいと思います。
EXCEL VBA 業務の自動化を目指す 