Functions
Option Explicit Function getFileArray(strFolderPath As String) As String() '---------------------------------------------------------- '機能 ：指定したフォルダパスのフォルダ内のファイルを取得する '引数1 ：対象フォルダパス '戻り値 :取得したファイルのパスを配列で返す '---------------------------------------------------------- Dim FSO As Object Dim tmpFile As Object Dim objFiles As Object Dim intFilesCount Dim arrayFiles() As String Dim i As Integer Set FSO = CreateObject("Scripting.FileSystemObject") Set objFiles = FSO.GetFolder(strFolderPath).Files intFilesCount = objFiles.Count i = 0 ReDim arrayFiles(intFilesCount - 1) With FSO.GetFolder(strFolderPath) For Each tmpFile In .Files arrayFiles(i) = tmpFile.Name i = i + 1 Next End With getFileArray = arrayFiles() End Function Function getSubFolderArray(strFolderPath As String) As String() '---------------------------------------------------------- '機能 ：指定したフォルダパスのフォルダ内のサブフォルダを取得する '引数1 ：対象フォルダパス '戻り値 :取得したサブフォルダのパスを配列で返す '---------------------------------------------------------- Dim FSO As Object Dim subFolders As Object Dim tmpFolder As Object Dim intFolderCount As Integer Dim arrayFolders() As String Dim i As Integer Set FSO = CreateObject("Scripting.FileSystemObject") Set subFolders = FSO.GetFolder(strFolderPath).subFolders intFolderCount = subFolders.Count i = 0 ReDim arrayFolders(intFolderCount - 1) With FSO.GetFolder(strFolderPath) For Each tmpFolder In .subFolders arrayFolders(i) = tmpFolder.Name i = i + 1 ' ReDim Preserve arrayFolders(i) Next End With getSubFolderArray = arrayFolders() End Function Function getExtension(strPath As String) As String '----------------------------------------------- '機能：指定したファイルパスより拡張子を取得する '引数1：拡張子を取得したい対象のファイルパス '----------------------------------------------- Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") getExtension = FSO.getExtensionName(strPath) End Function Function getBaseFileName(strPath As String) As String '------------------------------------------------------------- '機能：指定したファイルパスより拡張子なしのファイル名を取得する '引数1：拡張子なしのファイル名を取得したい対象のファイルパス '------------------------------------------------------------- Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") getBaseFileName = FSO.GetBaseName(strPath) End Function Function gefFileName(strPath As String) As String '------------------------------------------------------------- '機能：指定したファイルパスより拡張子ありのファイル名を取得する '引数1：拡張子ありのファイル名を取得したい対象のファイルパス '------------------------------------------------------------- Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") gefFileName = FSO.GetFileName(strPath) End Function Function getParentFolderPath(strPath As String) As String '------------------------------------------------------------- '機能：指定したパスより親フォルダパスを取得する '引数1：親フォルダパスを取得したい対象のパス '------------------------------------------------------------- Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") getParentFolderPath = FSO.getParentFolderName(strPath) End Function Function getSubFolderCount(strParentFolderPath As String) As Integer '------------------------------------------------------------- '機能：指定したパスのフォルダに存在するサブフォルダの総数を返す '引数1：サブフォルダ数を確認したい対象の親フォルダのパス '------------------------------------------------------------- Dim FSO As Object Dim subFolders As Object Set FSO = CreateObject("Scripting.FileSystemObject") Set subFolders = FSO.GetFolder(strParentFolderPath).subFolders getSubFolderCount = subFolders.Count End Function Function getFileCount(strParentFolderPath As String) As Integer '------------------------------------------------------------- '機能：指定したパスのフォルダに存在するファイルの総数を返す '引数1：ファイル数を確認したい対象の親フォルダのパス '------------------------------------------------------------- Dim FSO As Object Dim objFiles As Object Set FSO = CreateObject("Scripting.FileSystemObject") Set objFiles = FSO.GetFolder(strParentFolderPath).Files getFileCount = objFiles.Count End Function Sub prcFileCopy(strSourcePath As String, strDestPath As String) '----------------------------------------------------------- '機能：第1引数で指定されたパスのファイルを第2引数のパスにコピーする '引数1：コピー元ファイルパス '引数2：コピー先ファイルパス '----------------------------------------------------------- End Sub
Main
Option Explicit Sub Excution() Const intZipCoumn As Integer = 2 Const intSubFolderColumn As Integer = 3 Const intBeforFileNameColumn As Integer = 4 Const intAfterFileNameColumn As Integer = 5 Const intResultColumn As Integer = 6 Const intStartRow As Integer = 5 Dim strParentFolderPath As String Dim strOutputFolderPath As String Dim arrayFiles() As String Dim collZipFiles As Collection Dim intFileCount As Integer Dim i As Integer Dim strExtention As String Dim blResult As Boolean Dim beforZipPath As String Dim afterZipPath As String '親フォルダパスを取得 strParentFolderPath = Sheets("Sheet1").Range("C2") strOutputFolderPath = Sheets("Sheet1").Range("C3") 'フォルダ内のファイルを取得 intFileCount = getFileCount(strParentFolderPath) If intFileCount > 0 Then arrayFiles = getFileArray(strParentFolderPath) Set collZipFiles = New Collection For i = 0 To UBound(arrayFiles) strExtention = getExtension(arrayFiles(i)) If strExtention = "zip" Then collZipFiles.Add arrayFiles(i) End If Next MsgBox collZipFiles.Count MsgBox collZipFiles.Item(1) Dim f As Variant ' For Each f In collZipFiles Debug.Print f beforZipPath = strParentFolderPath & "\" & f afterZipPath = strOutputFolderPath & "\" & f afterZipPath = Replace(afterZipPath, ".zip", "") blResult = unzipman(beforZipPath, afterZipPath) Debug.Print blResult Next End If End Sub
フォルダ内用確認
Option Explicit Sub comfirmFolders() Const strSheetName As String = "Sheet1" Const intZipCoumn As Integer = 2 Const intSubFolderColumn As Integer = 3 Const intBeforFileNameColumn As Integer = 4 Const intAfterFileNameColumn As Integer = 5 Const intResultColumn As Integer = 6 Const intStartRow As Integer = 6 Dim strParentFolderPath As String Dim strOutputFolderPath As String Dim arrayFiles() As String Dim arrayFolders() As String Dim arraySubFolders() As String Dim intFileCount As Integer Dim intFolderCount As Integer Dim intSubFolderCount As Integer Dim i As Integer Dim strFolderName As String Dim strSubFolderName As String Dim strFileName As String Dim strExtention As String Dim blResult As Boolean Dim beforZipPath As String Dim afterZipPath As String Dim strTargetFolderPath As String Dim strTargetSubFolderPath As String Dim intExcelRow As Integer Dim j As Integer intExcelRow = intStartRow '確認対象フォルダパスを取得 strOutputFolderPath = Sheets(strSheetName).Range("C3") 'フォルダ内のサブフォルダの総数を取得 intFolderCount = getSubFolderCount(strOutputFolderPath) '①IF文はじめ If intFolderCount = 0 Then MsgBox "確認対象フォルダは存在しません" Else 'フォルダ内のサブフォルダを取得 arrayFolders = getSubFolderArray(strOutputFolderPath) '②FOR文 サブフォルダ(1階層目)数繰り返し処理 For i = 0 To UBound(arrayFolders) 'サブフォルダ名取得してExcel書込み strFolderName = arrayFolders(i) Sheets(strSheetName).Cells(intExcelRow, intZipCoumn) = strFolderName '解凍後フォルダなので一つ下の階層に同じフォルダ名があるので一つ下の階層のフォルダパスを取得 strTargetFolderPath = strOutputFolderPath & "\" & strFolderName & "\" & strFolderName '★サブフォルダ(１階層目)のファイル数を確認 intFileCount = getFileCount(strTargetFolderPath) If intFileCount > 0 Then arrayFiles = getFileArray(strTargetFolderPath) For j = 0 To UBound(arrayFiles) strFileName = arrayFiles(j) Sheets(strSheetName).Cells(intExcelRow, intBeforFileNameColumn) = strFileName intExcelRow = intExcelRow + 1 Next j Erase arrayFiles End If '---------------------------------------------------------------------------------------- 'サブフォルダ内のサブフォルダを取得 intSubFolderCount = getSubFolderCount(strTargetFolderPath) ' ③サブフォルダ内のサブフォルダ（2階層目）ありの場合 If intSubFolderCount > 0 Then 'サブフォルダ内のサブフォルダ有の場合 arraySubFolders = getSubFolderArray(strTargetFolderPath) Dim k As Integer For k = 0 To UBound(arraySubFolders) strSubFolderName = arraySubFolders(k) Sheets(strSheetName).Cells(intExcelRow, intSubFolderColumn) = strSubFolderName strTargetSubFolderPath = strTargetFolderPath & "\" & strSubFolderName 'ファイル有無確認 intFileCount = getFileCount(strTargetSubFolderPath) If intFileCount > 0 Then 'ファイル有の場合 arrayFiles = getFileArray(strTargetSubFolderPath) For j = 0 To UBound(arrayFiles) strFileName = arrayFiles(j) Sheets(strSheetName).Cells(intExcelRow, intBeforFileNameColumn) = strFileName intExcelRow = intExcelRow + 1 Next j Erase arrayFiles Else intExcelRow = intExcelRow + 1 End If Next k End If '-------------------------------------------------------------------------------------------------- '②FOR文 Next i '① End If End Sub
ボタン操作
Option Explicit Function fncGetFolderPath() As String '---------------------------------------------------------------- '機能：フォルダ選択ダイアログを表示し、選択したフォルダパスを返す '戻り値：フォルダパス '---------------------------------------------------------------- Dim objDialog As Object 'FileDialogオブジェクト格納用 'FileDialogオブジェクトをインスタンス化 Set objDialog = Application.FileDialog(msoFileDialogFolderPicker) 'ダイアログを開いて選択したフォルダを親フォルダパスに指定 If objDialog.Show Then fncGetFolderPath = objDialog.SelectedItems(1) Else fncGetFolderPath = "" End If End Function
圧縮解凍
Option Explicit Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As Long) 'ここから圧縮ルーチン Public Function makezip(ByVal ZipPath, ByRef FileArray) As Boolean '------------------------------------------------------------------ '機能：配列で受け取ったファイルを圧縮して指定したファイルパスで ' zipファイルを生成する '引数1：Zipファイルのパス '引数2：圧縮対象のファイルパスを格納した配列 '------------------------------------------------------------------ On Error GoTo Err_Handler '変数の宣言 Dim FSO, sh, file, num, zipFolder '処理で使用するオブジェクトの初期化 Set FSO = CreateObject("Scripting.FileSystemObject") Set sh = CreateObject("Shell.application") '古い同名圧縮ファイルがあったら削除する。 If FSO.FileExists(ZipPath) = True Then FSO.DeleteFile ZipPath End If '空のzipファイルを生成 With FSO.CreateTextFile(ZipPath, True) 'Chr(5)は「ENQ」照会、Chr(6)は「ACK」肯定応答 .Write "PK" & Chr(5) & Chr(6) & String(18, 0) .Close End With '新規作成したzipファイルへ圧縮対象をコピーする num = 0 'zipファイルのパスを格納する Set zipFolder = sh.Namespace(FSO.GetAbsolutePathName(ZipPath)) 'ループで配列内のフォルダを圧縮フォルダに足していく For Each file In FileArray If CStr(file) <> "" Then file = FSO.GetAbsolutePathName(file) 'Zipフォルダに圧縮対象のファイルをコピーする zipFolder.CopyHere (file) 'ファイル数をカウントアップ num = num + 1 End If Next 'すべての圧縮ファイルのコピーが終わるまで待つ。 Do Until zipFolder.Items().Count = num Sleep 100 Loop '値を返す makezip = True '終了処理 Set FSO = Nothing Set sh = Nothing Exit_makezip: makezip = False Exit Function Err_Handler: MsgBox Err.Description Resume Exit_makezip End Function '圧縮呼び出しテスト Public Function testZip() '変数の宣言 Dim ret As Boolean Dim filepath As Variant '圧縮対象フォルダ用配列 Dim Files(0) '配列に圧縮元フォルダのパスを格納する Files(0) = "圧縮するフォルダのフルパスを入力" '圧縮ファイルのパスを指定する（拡張子まで含める） filepath = "作成するZIPファイルのフルパスを拡張子まで含めて入力" 'ZIP圧縮を実行 ret = makezip(filepath, Files) End Function 'OS標準機能でzipファイルを解凍する関数 Public Function unzipman(ByVal filepath As Variant, ByVal meltpath As Variant) As Boolean On Error GoTo Err_Handler '指定のフォルダが存在するかチェック Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") If FSO.FolderExists(meltpath) Then Else MkDir meltpath End If Set FSO = Nothing 'シェルを呼び出し With CreateObject("Shell.Application") .Namespace(meltpath).CopyHere .Namespace(filepath).Items End With '結果を返す unzipman = True Exit Function Exit_unzipman: unzipman = False Exit Function Err_Handler: MsgBox Err.Description Resume Exit_unzipman End Function '解凍呼び出しテスト Function testmelting() '変数の宣言 Dim filepath As Variant Dim meltpath As Variant Dim ret As Boolean 'ファイルのパスを格納 filepath = "ここにZIPファイルのパスを入れる" meltpath = "ここに解凍先フォルダを入れる" 'ZIP解凍を実行 ret = unzipman(filepath, meltpath) End Function
Sheet1
Option Explicit Sub SelecParentFolder() Dim strPath As String strPath = fncGetFolderPath() Sheets("Sheet1").Range("C2") = strPath End Sub Sub SelectOutputFolder() Dim strPath As String strPath = fncGetFolderPath() Sheets("Sheet1").Range("C3") = strPath End Sub
