【VBA】指定フォルダ配下の圧縮ファイルをすべて解凍

指定フォルダ配下の圧縮ファイルをすべて解凍します。
今のところ、ALZIPとLhaplusに対応しています。
ExcelのC3セルを、ご自分の環境の解凍ツールのパスに書き換えて使ってください。

よく知らないけど「ALZIP」は韓国製ソフトっぽいです。
このお題をくれた人の環境が「ALZIP」なので使っていますが、ご利用は自己責任でお願いいたします。

こういうツールは頑張りすぎない主義なので、入力チェックなどは最低限です。
あまりスタイリッシュなコードにはなっていなくて気に入らないので、どうでも良くならなかったらリファクタリングします。

コマンドで使える、他の解凍ツールへの対応にリクエストがあれば、追加修正するかもしれません。

ソースコード

Option Explicit

'---------------------------------------------------------------------------------------------------
' 変数
'---------------------------------------------------------------------------------------------------
' ツール > 参照設定 > Windows Script Host Object Model
Private wsh As IWshRuntimeLibrary.WshShell

Private oDir As Folder                  ' フォルダオブジェクト
Private oFile As File                   ' ファイルオブジェクト
Private ToolPath As String              ' 解凍ツールパス
Private UnzipSrc As String              ' 解凍元先頭パス
Private UnzipDst As String              ' 解凍先パス
Private UnzipCommandTemplate As String  ' 解凍コマンドテンプレート
Private commandList As Dictionary       ' 解凍ツールのコマンドのリスト

'---------------------------------------------------------------------------------------------------
'【処 理 名】初期処理
'---------------------------------------------------------------------------------------------------
Private Sub init()
    Set wsh = New IWshRuntimeLibrary.WshShell
    
    '解凍ツールパス
    ToolPath = ThisWorkbook.Worksheets("解凍ちゃん").Range("C3").Value
    '解凍元先頭パス
    UnzipSrc = ThisWorkbook.Worksheets("解凍ちゃん").Range("C4").Value
    '解答先パス
    UnzipDst = ThisWorkbook.Worksheets("解凍ちゃん").Range("C5").Value
    
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】終期処理
'---------------------------------------------------------------------------------------------------
Private Sub term()
    Set oDir = Nothing
    Set oFile = Nothing
    Set wsh = Nothing
    
    Set commandList = Nothing
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】解凍
'【処理概要】指定ディレクトリ配下のすべてのgzファイルを解凍する
'【引    数】なし
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Public Sub 解凍()
    
    '初期化
    Call init
    
    '入力チェック
    If Not validation() Then
        Exit Sub
    End If
    'ツールパスの補正
    Call createToolList
    Call editUnzipCommand
    
    'メイン処理
    Call サブフォルダまでくるくるして解凍(UnzipSrc)
    
    '終期化
    Call term
    
    MsgBox "おしまい"
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】サブフォルダまでくるくるして解凍
'【処理概要】指定ディレクトリ配下のすべてのgzファイルを解凍する
'【引    数】[I] ByVal sTopPath As String フォルダパス
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Private Sub サブフォルダまでくるくるして解凍(ByVal sTopPath As String)
    ' ツール > 参照設定 > Microsoft Scripting Runtime
    Dim oFso As New FileSystemObject    ' ファイルシステムオブジェクト
    Dim UnzipCommand As String          '解凍コマンド
    
    '指定フォルダ配下のサブフォルダすべてに対して処理する
    For Each oDir In oFso.GetFolder(sTopPath).SubFolders
        Call サブフォルダまでくるくるして解凍(oDir.Path)
    Next
    
    'フォルダ直下のすべてのファイル
    For Each oFile In oFso.GetFolder(sTopPath).Files
        UnzipCommand = Replace(UnzipCommandTemplate, "{src}", oFile.Path)
        ' コマンドを実行
        wsh.Run UnzipCommand
        DoEvents
    Next
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】入力チェック
'【処理概要】入力チェックを行う
'【引    数】なし
'【返 却 値】True    エラーなし
'          False   エラーあり
'---------------------------------------------------------------------------------------------------
Private Function validation() As Boolean
    If ToolPath = "" Then
        MsgBox ("解凍ツールパスを入力してください。")
        GoTo LBL_ERROR
    End If
    If Dir(ToolPath) = "" Then
        MsgBox "解凍ツールが存在しません。"
        GoTo LBL_ERROR
    End If
    
    If UnzipSrc = "" Then
        MsgBox ("解凍元パスを入力してください。")
        GoTo LBL_ERROR
    End If
    If Dir(UnzipSrc, vbDirectory) = "" Then
        MsgBox "解凍元ファイルが存在しません。"
        GoTo LBL_ERROR
    End If
    
    validation = True
    Exit Function

LBL_ERROR:
        validation = False
        Exit Function
End Function

'---------------------------------------------------------------------------------------------------
'【処 理 名】解凍ツール実行コマンド生成
'【処理概要】解凍ツールの実行コマンドを生成する
'【引    数】なし
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Private Sub editUnzipCommand()
    ' ツール > 参照設定 > Microsoft Scripting Runtime
    Dim oFso As New FileSystemObject    ' ファイルシステムオブジェクト
    Dim key As String
    
    key = oFso.GetBaseName(ToolPath)
    
    UnzipCommandTemplate = Replace(commandList(key), "{tool}", ToolPath)
    UnzipCommandTemplate = Replace(UnzipCommandTemplate, "{dst}", UnzipDst)
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】解凍コマンドリスト生成
'【処理概要】解凍コマンドのリストを生成する
'【引    数】なし
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Private Sub createToolList()
    Dim key As Variant
    
    Set commandList = New Dictionary
    
    'ALZIP
    commandList.Add "ALZipCon", """{tool}"" -x ""{src}"" ""{dst}"""
    'LHAPLUS
    commandList.Add "Lhaplus", """{tool}"" ""{src}"" ""/o:{dst}"""
End Sub

ダウンロード

コメントを残す

メールアドレスが公開されることはありません。