本ページには広告が含まれています。

【ExcelVBA】ZIPファイルを7-zip32.dllで作成

VBA ZIPファイルを7-zip32.dllで作成

ZIPファイルの作成方法と活用法などを紹介したいと思います
今までの記事では、仕事で活用できるような内容でVBAの利用法を書いてきました。前回記事では、メールでExcelなどのファイルを添付して送信する方法を紹介しましたが、セキュリティを高めるために送付するファイルにパスワードをつけて送るケースが非常に多いと思います。

そこで、今回の記事ではVBAを使ってパスワード付きのZIPファイルを作成する方法について解説していきたいと思います。パスワードを設定していないファイルでもパスワード付きのZIPファイルに同梱してしまえば問題を一気に解決でるというわけです

VBAから7-zip32.dllを使ってパスワード付きZIPファイルを作成する方法を解説します
しかも、パスワードは個別ファイル毎に設定できるようにします

スポンサーリンク

ZIPファイルを作成する方法について

VBAを使わない場合

Windowsで(VBAを使わずに)作成するのは比較的簡単です。解説する必要は無いと思いますが簡単に説明すると、圧縮したいファイルをすべて選択した状態で、右クリックするとメニューが出てきますので、[送る(N)] ≫ [圧縮(zip形式)フォルダー] とクリックするだけで作成できてしまいます
エクスプローラーで見てもわかるとおり、ZIPファイルはフォルダーとして表示されていますよね(中のファイルもすべて見えている状態で、ダブルクリックすればそのまま開くことができます)
でも、残念ながら目的のパスワード付きのZIPファイルは作成できなんですよね。作る場合はWinzipなどのアプリで作成する必要があります

VBAからZIPファイルを作成する主な方法

PowerShellの圧縮・解凍コマンドを利用する方法

WshShellクラスのWshShell.Execメソッドで、PowerShellを呼び出してコマンドを渡して処理を行う方法です。「圧縮コマンド」=Compress-Archive、「解凍コマンド」=Expand-Archive

パスワードは付けることができません。2GBのサイズ制限があります
パスワードを設定しない単純なZIPファイルへの圧縮と解凍であればこれが一般的だと思います

OS標準機能でzipファイル作成する方法

WshShell.NameSpace.CopyHereメソッドでZipファイルへコピー処理を利用する方法です
ただし、MicrosoftWindowsサポートで(公式リンク)「CopyHere メソッドから Zip ファイルを処理することはできません」でサポート対象外とされています

7-Zipなどの外部ライブラリを利用する方法

統合アーカイバ・プロジェクト(Common Archivers Library)の個別ライブラリを見ると、ZIPファイルの作成利用できるDLLを見ることができます。その中で、Igor Pavlov 氏が開発した「7-zip32.dll」が他の zip 互換プログラムより少しだけ圧縮率の高い zip 書庫の圧縮・解凍できるライブラリとのことで、
数々のオプションを利用することが出来でパスワードの設定ももちろん可能となっています
さっそく、7-ZIP32.DLL for windows 32bitsからダウンロードして使うこととします
(今回使用するのは32bit版とします! 64bit版は今回は使用しません!)

※64ビット版Excelでも対応できるようにする方法の解説記事を掲載しました(2022/9/26)

7-zip32.dllを使ってZIPファイルを作成する方法

7-zip32.dllを使うための準備

前節でダウンロードしてきたファイル「7z922002.zip」を解凍します。複数(8個)のファイルが同梱されていますが、その中の「7-zip32.dll」をWindowsのシステムフォルダにコピーします
Windowsが32bitの場合は「C:\Windows\SysWOW64」、64bitの場合は「C:\Windows\System32」です
しかし、昨今のセキュリティー強化環境によってはSystem32ディレクトリに入れることが出来ない環境(管理者権限がない等)もあると思います。私の職場でもそのような環境でした

その場合の対処法として、DLLを実行するExcelファイルと同じディレクトリに入れておく事で利用する事が可能になります(ExcelのActiveWorkbook.Pathを使用します)

・DLL参照用の宣言(7-zip32APIを使うための宣言)部分がこれ!

Option Explicit
'7-zip32.DLLのAPI宣言
'[hwnd]ウィンドウハンドル,[szCmdLine]コマンド文字列
'[szOutput]結果を返すバッファ,[dwSize]バッファのサイズ
'戻り値   正常終了= 0   エラー時 <> 0
Private Declare Function SevenZip Lib "7-zip32.DLL" ( _
        ByVal hWnd As Long, ByVal szCmdLine As String, _
        ByVal szOutput As String, ByVal dwSize As Long) As Long

ZIPファイル作成(圧縮)に必要なコードの確認

'ZIPファイルを作成(圧縮コマンド作成)
'引数 szTgPath:圧縮するファイルまたはフォルダーのパス
'     szZIPName:ZIPファイルのパス
'     szPWord:パスワード 省略可
'返り値 成功したら True、失敗したらFalse
Public Function CompressZIP(szTgPath As String, szZIPName As String, _
                        Optional szPWord As String = "") As Boolean
    Dim szCmd As String
    szCmd = "a -tzip -mx9 -hide "
    If szPWord <> "" Then szCmd = szCmd & "-P" & szPWord & " "
    szCmd = szCmd & dq(szZIPName) & " " & dq(szTgPath)
    CompressZIP = DoSevenZIP(szCmd) = 0
End Function
 
'7-Zip.dllへ実行コマンドを渡す
Private Function DoSevenZIP(szCmd As String) As Long
    Dim szRet As String * 1024    
    DoSevenZIP = SevenZip(0, szCmd, szRet, 1024)
    If DoSevenZIP <> 0 Then MsgBox (Left(szRet, InStr(szRet, vbNullChar) - 1))
    'ログ用に実行したコマンドを保存
    strcmd = strcmd & vbCrLf & szCmd
End Function

'ダブルクォーテーション用
Public Function dq(ByVal Text As String) As String
    dq = """" & Replace(Text, """", """""") & """"
End Function

①「ZIPファイルを作成(圧縮コマンド作成)」関数で必要なパスやファイル名、
 パスワードなどの情報を受け取り、7-Zip.dllへ渡せるように整形し③に渡します
②「ダブルクォーテーション用」関数は①で整形の際に呼び出され補助します
③「7-Zip.dllへ実行コマンドを渡す」関数①から渡されたコマンドを7-Zip.dllへ渡し、
 ZIPファイルを作成させます。そして渡したコマンドをstrcmd変数に保存します
・strcmd変数についてはのちほど改めて説明します

ZIPファイルを作成するための準備

フローチャートでロジックの検討

ZIPファイルを作成するロジックのフローチャート

ZIP作成実行に用意するシートは1つ

・画像を用意しましたので確認してください

「ZIPファイル作成」シート

「ZIPファイル作成」シート

・VBAマクロを実行させるためのボタンを4つ配置します
・対象フォルダまたはファイルの抽出列(B~F)にとりあえず100行分
G列は個別パスワードの設定列です ・その他は上の画像を参照してください

シート作成が面倒ならば、サンプルファイルを用意していますので、ダウンロードページへのリンクからからDLしてください

ZIPファイル作成シートから実行するコード

「圧縮処理開始」ボタンから実行するコード

「フォルダ選択」と「添付ファイルの指定」や「メール件名」「メール本文」「送信先」等すべての事前設定完了後に「送信設定」シートの「スタート」ボタンで起動させます

Option Explicit
Public strcmd As String
'*******************************************
'* ZIPファイル作成実行
'*******************************************
Sub CmdMake7Zip()
    Dim lngRow As Long          '開始行
    Dim lngRowMax As Long       '最終行
    Dim i As Long               '行指定用
    Dim strFoldFiles As String  '圧縮対象フォルダ&ファイル名
    Dim strDstFullPath As String 'ZIPのフルパス
    Dim strDstPath As String    'ZIPのパス
    Dim strZipName As String    'ZIPファイル名
    Dim strPW As String         'パスワード
    Dim strApndRep As String    '追加or置換
    Dim strErr As String        'エラーメッセージ
    Dim objFSO As FileSystemObject  'FileSystemObject
    Set objFSO = New FileSystemObject
    
    '7-Zip.dllのパス設定(Systmに無い場合のため)
    ChDrive ThisWorkbook.path
    ChDir ThisWorkbook.path
    
    lngRowMax = Cells(Rows.Count, 2).End(xlUp).Row  '対象データ最終行
    lngRow = 2  'データ開始行
        
    'ZIP圧縮ファイル名
    strDstFullPath = Trim(Cells(2, 9).Value)
    strDstPath = Left(strDstFullPath, InStrRev(strDstFullPath, "\")) 'ファイル名カット
    strZipName = Left(strDstFullPath, InStr(strDstFullPath, ".") - 1) '拡張子カット
    strZipName = Right(strZipName, Len(strZipName) - Len(strDstPath))
    '追加or置換判定(置換の場合ZIPファイルを削除)
    strApndRep = Cells(5, 9).Value
    If strApndRep = "置換" Then
        If objFSO.FileExists(strDstFullPath) Then
            On Error Resume Next
            objFSO.DeleteFile strDstFullPath, True
            If Err.Number <> 0 Then
                strErr = "置換ZIPファイルの事前削除に失敗!" _
                            & vbCrLf & Err.Description
                Err.Clear
                On Error GoTo 0
                Set objFSO = Nothing
                Exit Sub
            End If
            On Error GoTo 0
        End If
    End If
    'ログ用txtファイル見出し
    strcmd = "cmd sw1 sw2 sw3 PW ZIPファイル名 Path/FileName"
    '圧縮対象数分のループ処理
    For i = lngRow To lngRowMax
        '対象フォルダ&ファイル名の存在確認
        strFoldFiles = Trim(Cells(i, 2).Value)
        If Not objFSO.FileExists(strFoldFiles) Then
            If objFSO.FolderExists(strFoldFiles) Then
                'フォルダ指定はフォルダ内の全てを
                strFoldFiles = strFoldFiles & "\*"
            Else
                strErr = "圧縮対象が実在しません。" _
                                & vbCrLf & strFoldFiles
                Set objFSO = Nothing
                Exit Sub
            End If
        End If
        'パスワード(個別設定を優先する)
        strPW = Trim(Cells(i, 7).Value)
        If strPW = "" Then strPW = Trim(Cells(7, 9).Value)
        '-------------------------------------------
        '7-Zip.dllの処理へ
        Call CompressZIP(strFoldFiles, strDstFullPath, strPW)
        '-------------------------------------------
    Next
    'ZIP作成後ログをテキストファイルに書き出す
    Dim strPath As String
    strPath = strDstPath & strZipName & ".txt"
    
    With objFSO
        If Not .FileExists(strPath) Then
            .CreateTextFile (strPath)
        End If
        With .OpenTextFile(strPath, 8) '8:ForAppending
            .WriteLine strcmd
            .Close
        End With
    End With
    Set objFSO = Nothing
    MsgBox "圧縮処理が終了しました!" & vbCrLf & _
            "ZIPファイルを確認してください。"
End Sub

・2行目の「Public strcmd As String」は7-zip32.DLLが実行したコマンドの保存用変数
・74行目から86行目は「strcmd 」に保存された内容をテキストファイルに書き出す処理
71行目でZIPファイル作成処理を呼び出し設定データを引き渡して実行させています

圧縮対象ファイルやフォルダ設定のための各コード

'*******************************************
'* 圧縮対象ファイル選択指定
'*******************************************
Sub CmdSelectFiles()
    Dim n As Long
    Dim re As Long
    Dim i As Long

    '新規取得か追加取得かを選択
    n = Cells(Rows.Count, 2).End(xlUp).Row
    re = vbNo '初期化
    If n > 1 Then
        re = MsgBox("すでにデータがあります。" & _
                    "処理を選択してください。" & vbCrLf _
                    & "「はい]=追加取得,「いいえ]=新規取得", _
                    (vbYesNo + vbExclamation), "処理選択")
    End If
    '選択されたファイル名をセルに格納する処理
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True    '複数選択可
        .Filters.Clear  'フィルタを初期化してセット
        .Filters.Add "Microsoft Excelファイル", "*.xls?"
        .Filters.Add "全てのファイル", "*.*"
        .FilterIndex = 1
        .InitialFileName = ThisWorkbook.path '初期表示フォルダの設定
                        
        '新規の場合セルをクリアする
        If re = vbNo Then Range(Cells(2, 2), Cells(101, 8)).ClearContents
        If .Show = -1 Then  'ダイアログ表示
            For i = 1 To .SelectedItems.Count
                If re = vbYes Then
                    Cells(n + i, 2).Value = .SelectedItems(i)
                Else
                    '新規の場合
                    Cells(i + 1, 2).Value = .SelectedItems(i)
                End If
            Next i
        Else
            'キャンセルされた場合
            MsgBox "ファイル選択がキャンセルされました。", vbExclamation
            Exit Sub
        End If
    End With
End Sub
'*******************************************
'* ZIPファイルの保存先指定
'*******************************************
Sub CmdSelectSaveZip()
    Dim strFilename As String 'ファイル名
    
    strFilename = Application.GetSaveAsFilename( _
                    FileFilter:="ZIPファイル,*.zip,全てのファイル,*.*", _
                    FilterIndex:=1, _
                    InitialFileName:="ZIPファイル名.zip", _
                    Title:="保存ZIPファイルの指定")
    
    '選択されたファイル名をセルに格納
    If strFilename = "False" Then
        Cells(2, 9).Value = ""
    Else
        Cells(2, 9).Value = strFilename
    End If
End Sub
'*******************************************
'* 圧縮対象フォルダ選択指定
'*******************************************
Sub CmdSelectFolder()
    Dim strPathname As String ' フォルダ名
    Dim n As Long
    Dim re As Long
    
    '「フォルダ選択」ダイアログを表示(modFolderPicker1)
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "ZIP圧縮対象フォルダの参照"
        .AllowMultiSelect = False
        If .Show = False Then
            MsgBox "選択されませんでした"
            Exit Sub
        End If
        strPathname = .SelectedItems(1)
    End With
    'フォルダが選択されていたらセルに格納する処理
    n = Cells(Rows.Count, 2).End(xlUp).Row
    '新規取得か追加取得かを選択
    re = vbNo '初期化
    If n > 1 Then
        re = MsgBox("すでにデータがあります。" & _
                    "処理を選択してください。" & vbCrLf _
                    & "「はい]=追加取得,「いいえ]=新規取得", _
                    (vbYesNo + vbExclamation), "処理選択")
    End If
    If re = vbYes Then
        Cells(n + 1, 2).Value = strPathname
    Else
        '新規の場合セルをクリアする
        Range(Cells(2, 2), Cells(101, 8)).ClearContents
        Cells(2, 2).Value = strPathname
    End If
End Sub

・4行目が「圧縮対象ファイルの参照」ボタン用コード「CmdSelectFiles」です
 複数ファイルの選択が可能です
・48行目がZIPファイルの保存先指定用「参照」ボタン用「CmdSelectSaveZip」です
 作成するZIPファイル名と保存先フォルダを設定します
・67行目「圧縮対象フォルダの参照」ボタン用コード「CmdSelectFolder」です
 複数選択不可ですので、複数の場合は複数回実行してください

まとめ(おわりに)

基本事項の再確認と補足・感想など

統合アーカイバから7-ZIP32.DLL for windows 32bitsをダウンロードしてください
・パスワードは全体で設定可能ですが、「個別設定」が優先されます
・パスワード無しにする場合は、「全体」「個別」ともに空欄にしてください
実行したコマンドをテキストファイルにしておく目的は、パスワード設定を保存しておくためのものです。

・PWってホント忘れちゃうんですよね(^^;
・だからログをファイルに残す処理は、地味に欲しかった機能なんです(私事w)
・ZIPファイルの解凍については、Windowsで普通に簡単にできるのでカットしてます
・ただ、複数(大量)のZIPファイルをまとめて解凍することは次の機会に紹介します
今までの「分割処理」などに応用できそうですね(分割したファイルのZIP化)

今後の記事について

今回の記事はいかがだったでしょうか。お役に立てたなら幸いです(^^;
是非!サンプルがありますので使ってみてください(^^)/

【今後の記事内容はどうしようかなぁ・・・】
・複数(大量)のZIPファイルをまとめて解凍する
・高速化した「VlookUp関数」のVBAでの活用法を再検討してみたいと思います
・その他「小ネタいろいろ」などなど・・・・・
・今後これらのどれかについて記事にしていきたいと思います。ご期待ください(^^)/

スポンサーリンク
スポンサーリンク

サンプルファイルをダウンロードできます(下記リンク先へ)

記事で使用したサンプルファイルがダウンロードできるページを設置しています
こちら(このリンク先)からご利用ください