複数のパスワード付きzipに一括で色々なファイルを格納するVBAコード

スポンサーリンク

同僚からの依頼でzipファイル格納のVBA検討

最近社内でメールのシステムが変更になり、これまで外部への添付ファイルは自動で「①zipに格納→②パスワード生成→③別メールでパスワードを送付」ができていたのですが、手作業でzipを作成することになりました。

元々パスワード付きzipファイルをメールで送るフロー自体が色々と問題を引き起こす可能性も指摘されているので、その運用自体止めてしまえばよい気もするのですが、セキュリティ対策の主観部署がこれまで行っていたzip格納を止める判断をしなかったらしく上記のように手作業の負担が増えていました。

今回はパスワード付きzipファイルに必要なファイルを連続で圧縮するExcelVBAコードを考えてみました。

zip格納に「LhaPlus」を使用する

以前こちらの記事で紹介していますが、zip格納を安定して実行するためにLhaPlusというフリーソフトを使用します。

Windows標準の機能を呼び出してzip格納をする方法もあるのですが、公式なサポート外らしくエラーが起こるし動作が不安定でした。
LhaPlusはコマンドプロンプトから操作ができるようになっていて、それを利用することでVBAからも自動操作が可能になります。

スポンサーリンク

今回考えた自動zip格納VBAツールの仕組み

今回私が考えたツールの動作と業務のフローは以下の通りです。

事前準備

①zipファイルに格納したいファイルをフォルダごとにまとめてあるフォルダに格納

②zip変換用フォルダをまとめて格納しているフォルダにツールファイルも一緒に格納(vba162_zip一括返還211219.xlsm)

詳細は以下の画像のような状態です。

ツールファイルの画面

ツールファイルは以下のような画面で作成しています。
まずzipを作成するためのフォルダ一覧を取得して、パスワードを手入力したあと、zipを作成するフローを想定しています。

ツール操作実行手順

①フォルダ取得ツールでzipに格納したいフォルダ一覧を取得
「フォルダ取得」ボタンをクリックするとツールフォルダが格納されているフォルダをB1セルに表示し、その中のサブフォルダを一覧にしてA列に取得して入力

②作成するzipファイルのパスワードを入力(B列)
パスワードが規則性のあるものにするならVBAで自動化することもできますが、今回は手入力するフローにしています。

③zip格納ボタンをクリック
サブフォルダの中のファイルが同じ名前のzipに格納され、作成されたサブフォルダ「zip格納」の中にzipファイルが作成される

今回作成したVBAコード

①フォルダ取得

Sub フォルダ取得()
    
    Dim FSO As Object, WSH As Object
    
    Dim FoldPath As String
    Dim FolderName As String
    Dim ArrFolderName() As String
    
    Dim i As Long, k As Long
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    FoldPath = ThisWorkbook.Path

    Cells(1, 2) = FoldPath
    i = 0
    FolderName = Dir(FoldPath & "\*", vbDirectory)
    Do While FolderName <> ""
        If InStr(FolderName, ".") = 0 And FolderName <> "zip格納" Then
            ReDim Preserve ArrFolderName(i)
            ArrFolderName(i) = FolderName
            Cells(i + 4, 1) = FolderName
            'Cells(i + 4, 2) = Left(Cells(i + 4, 1), 4)
            i = i + 1
        End If
    FolderName = Dir()
    Loop
    
End Sub

②zip格納

Sub サブフォルダzip格納()

    Dim Cmd As String
    Dim ArrFileName, FileName
    Dim FSO, WSH
    Dim 前FoldPath, 後FoldPath

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set WSH = CreateObject("Wscript.Shell")

    WSH.CurrentDirectory = "C:\Program Files (x86)\Lhaplus"

    '前FoldPathに格納されているサブフォルダをzip格納して後FoldPathに格納
    前FoldPath = Cells(1, 2)
    後FoldPath = Cells(1, 2) & "\zip格納"

    'zip格納用のフォルダ作成
    If FSO.FolderExists(後FoldPath) = False Then
        FSO.CreateFolder 後FoldPath 'フォルダ作成
    End If

    '後で使用する対象ファイル一覧表が残っていたら削除
    If FSO.FileExists(前FoldPath & "\圧縮リスト.txt") = True Then
        FSO.DeleteFile 前FoldPath & "\圧縮リスト.txt"
    End If

    Dim i
    i = 4
    Do Until Cells(i, 1) = ""
        ArrFileName = ""
        FileName = Dir(前FoldPath & "\" & Cells(i, 1) & "\*.*", vbNormal)
        Do While FileName <> ""
            If ArrFileName <> "" Then
                ArrFileName = ArrFileName & vbCrLf & 前FoldPath & "\" & Cells(i, 1) & "\" & FileName
            Else
                ArrFileName = 前FoldPath & "\" & Cells(i, 1) & "\" & FileName
            End If
        FileName = Dir()
        Loop

        'コマンドプロンプトは文字数の上限があるので、対象ファイル一覧を「圧縮リスト.txt」に入力
        With FSO.CreateTextFile(Cells(1, 2) & "\圧縮リスト.txt")
            .WriteLine ArrFileName
            .Close
        End With

        'cells(i,2)がPassword 空欄ならパスワード設定なしでzip格納
        Cmd = "Lhaplus.exe /c:zip /n:" & 後FoldPath & "\" & Cells(i, 1) & ".zip" & " /p:" & Cells(i, 2).Text & " /l:" & Cells(1, 2) & "\圧縮リスト.txt"

        WSH.Run "%ComSpec% /c " & Cmd, 7, True

        FSO.DeleteFile Cells(1, 2) & "\圧縮リスト.txt"

    i = i + 1
    Loop

    Set FSO = Nothing
    Set WSH = Nothing

End Sub

動作確認の動画とあとがき

今回作成したコードを実行した動画は以下の通りです。

パスワード付きzipファイルをメールで送る文化には賛否両論ありますが、私の会社含めまだまだ根強く残ると思います。
自動サービスがなくなっていってしまう中手作業でこの処理を続けるのは結構つらいと思うので自動処理を考えてみました。

今回ご紹介したコードはコマンドプロンプトを起動している時間PCを使えない(キャンセルしてしまう可能性がある)ので、大量のファイルをzipに格納する場合、別のPCを使うか休憩時間前などに実行だけして休憩時間中に作成することをおすすめします。

おすすめ書籍 amazonicon Amazon rakutenicon 楽天 Yahooicon Yahoo検索

コメント