ファイル一括コピー

ファイルを一括コピーするツールです。
例えば毎日、ファイル名が今日の日付をコピーする、
なんて処理があるときに使ってください。

参照設定

ツール＞参照設定＞
Microsoft Scripting Runtime

Option Explicit

'---------------------------------------------------------------------------------------------------
' 定義
'---------------------------------------------------------------------------------------------------
Private Const SH_NAME As String = "ツール"   'シート名
Private Const DATA_START_ROW As Long = 10    'データ開始行

'列インデックス
Private Enum eCOL
    NO = 1
    SRC_DIR
    SRC_FILE_NAME
    DST_DIR
    DST_FILE_NAME
    RESULT
    
    TRAILER
End Enum

'---------------------------------------------------------------------------------------------------
' 変数
'---------------------------------------------------------------------------------------------------
Private sh As Worksheet            'ワークシートオブジェクト
Private arrInfo As Variant         'ワークシート情報
Private fileUtil As ClsFileUtil    'ファイル操作クラス
Private oFso As FileSystemObject   'ファイルシステムオブジェクト

'---------------------------------------------------------------------------------------------------
'【処 理 名】初期化
'【処理概要】初期化を行う
'【引    数】なし
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
    Set sh = ThisWorkbook.Worksheets(SH_NAME)
    Set fileUtil = New ClsFileUtil
    Set oFso = New FileSystemObject
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】終期化
'【処理概要】終期化を行う
'【引    数】なし
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Private Sub Class_Terminate()
    Set sh = Nothing
    Set fileUtil = Nothing
    Set oFso = Nothing
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】ファイルコピーメイン処理
'【処理概要】ファイルをコピーする
'【引    数】なし
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Public Sub CopyFilesMain()
    Dim index As Long           '行カウンタ
    Dim src As String
    
    'ワークシート情報読込
    Call LoadSheet
    
    'ファイルコピー
    For index = 1 To UBound(arrInfo)
        'ファイルコピー処理
        Call CopyFiles(index)
LBL_NEXT:
    Next index
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】ファイルコピー処理
'【処理概要】ファイルをコピーする
'【引    数】[I]ByVal index As Long
'【返 却 値】
'---------------------------------------------------------------------------------------------------
Private Sub CopyFiles(ByVal index As Long)
    Dim src As String    'コピー元ファイル名
    Dim dst As String
    
    On Err GoTo LBL_ERR
    src = arrInfo(index, eCOL.SRC_DIR) & arrInfo(index, eCOL.SRC_FILE_NAME)
    dst = arrInfo(index, eCOL.DST_DIR) & arrInfo(index, eCOL.DST_FILE_NAME)
    
    'コピー元ファイルが存在しない場合スキップ
    If Dir(src) = "" Then
        GoTo LBL_ERR
    End If
    'コピー先ディレクトリ作成
    Call fileUtil.makeDirectory(arrInfo(index, eCOL.DST_DIR))
    
    If arrInfo(index, eCOL.DST_FILE_NAME) <> "" Then
        'リネームする場合
        FileCopy src, dst
    Else
        'コピーの場合
        oFso.copyFile src, dst
    End If
    
    Exit Sub
LBL_ERR:
    sh.Cells(DATA_START_ROW + index - 1, eCOL.RESULT).value = "ERR"
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】ワークシート読込
'【処理概要】ワークシートの情報を読み込む'【引    数】なし
'【引    数】なし
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Public Sub LoadSheet()
    Dim endRowIndex As Long    '行インデックス
    Dim index As Long          'カウンタ
    
    endRowIndex = sh.Cells(Rows.Count, eCOL.SRC_DIR).End(xlUp).Row
    arrInfo = sh.Range(sh.Cells(DATA_START_ROW, eCOL.NO), _
        sh.Cells(endRowIndex, eCOL.TRAILER - 1))
        
    For index = 1 To UBound(arrInfo)
        '--------------------------------
        'ディレクトリパス付与
        '--------------------------------
        'コピー元ファイル格納場所
        arrInfo(index, eCOL.SRC_DIR) = _
            fileUtil.AddPathSeparator(arrInfo(index, eCOL.SRC_DIR))
        'コピー先
        arrInfo(index, eCOL.DST_DIR) = _
            fileUtil.AddPathSeparator(arrInfo(index, eCOL.DST_DIR))
    Next index
End Sub

Option Explicit

Private Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" ( _
                                ByVal hwnd As Long, _
                                ByVal pszPath As String, _
                                ByVal psa As Long) As Long
                                
'ツール ＞ 参照設定 ＞ Microsoft Scripting Runtime
Dim oFso As FileSystemObject

'---------------------------------------------------------------------------------------------------
'【処 理 名】初期化
'【処理概要】初期化を行う
'【引    数】なし
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
    Set oFso = New FileSystemObject
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】終期化
'【処理概要】終期化を行う
'【引    数】なし
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Private Sub Class_Terminate()
    Set oFso = Nothing
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】ディレクトリパスへのセパレータ付与
'【処理概要】ディレクトリパスの末尾にセパレータがなければ付与する
'【引    数】[I]ByVal path As String ディレクトリパス
'【返 却 値】 なし
'---------------------------------------------------------------------------------------------------
Public Function AddPathSeparator(ByVal path As String) As String
    If Right(path, 1) <> ChrW(92) Then
        path = path & ChrW(92)
    End If
    AddPathSeparator = path
End Function

'---------------------------------------------------------------------------------------------------
'【処 理 名】ディレクトリ作成
'【処理概要】ディレクトリを作成する
'【引    数】[I]ByVal path As String ディレクトリパス
'【返 却 値】 SHCreateDirectoryEx()返却値。0 ＝ ディレクトリ作成成功
'---------------------------------------------------------------------------------------------------
Function makeDirectory(ByVal path As String) As Long
    If oFso.FolderExists(path) <> True Then
        makeDirectory = SHCreateDirectoryEx(0&, path, 0&)
    End If
End Function

ファイル一括コピー

1 ファイル 33.15 KB

ダウンロード

ファイル一括コピー

コメントを残す コメントをキャンセル

コメントを残すコメントをキャンセル