VBAでZIPの圧縮・解凍をやらせてみる
自分がこれまで手掛けた特定企業向けの業務アプリケーションで非常に大がかりであったものは「酪農経営シミュレータ」「医薬品卸価格分析ツール」などがあります。これらは使う人によっていくつものパターンや分析を行う必要があるため、データを簡単にエクスポートし、簡単に入れ替えられるようにしておく必要がありました。今から10年以上前の話です。
Accessでこれらを作成するにあたり、Accessファイルでの管理は煩雑なので（いくつものaccdbファイルで構成されている為）、ZIP形式でまとめて出力や入力が出来るようにしてあります。これらのZIPファイルを相手に渡せば、忠実に計算結果を再現できるので非常に地味ながら重宝する機能です。そこで今回はこの部分を書いてみようと思います。
※今回のルーチンはファイルの指定やフォルダの指定などのダイアログを実装していないので、実用する場合にはファイル・フォルダ指定のダイアログ等が必要になるかと思います。
リンク
目次
今回使用するファイルやライブラリ
- ZIP出力・入力を装備したExcelファイル(64bitとして作成)
- 7zip32.dll - 32bit版VBAで動作する7zip形式を取り扱うDLL
- 7zip64.dll - 64bit版VBAで動作する7zip形式を取り扱うDLL
ソースコード
OS標準機能を使ったパターン
Windows7からはOS標準でZIPの圧縮・解凍の機能が使えるようになっているため、別途DLLがなくともZIPをVBAから扱えるようになっています。但し、標準機能なので、暗号化ZIPを作成・解凍する事は出来ません（sendkeyでパスワードを送る手段はありますが、賢明な方法とは言えません）。
圧縮をしてみる
圧縮は解凍よりも若干厄介です。こちらのサイトにVBSのパターンの圧縮用コードがありますが、VBAでも利用が可能です。同一ファイル名が先にあった場合には削除をし、圧縮時にエラーが発生した場合用にエラートラップをし、成功時にTrue、失敗時にはfalseを返すようにしています。
また、圧縮中にすべてのファイルの圧縮が完了するまでの100ms程度のsleepを入れているので、Generalプロシージャにkernel32のロードが必要です。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 |
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As Long) 'ここから圧縮ルーチン Public Function makezip(ByVal ZipPath, ByRef FileArray) As Boolean 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) .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 |
解凍をしてみる
今回は指定のフォルダがない場合には自動的にフォルダを作成し解凍を続行するようにしています。また、解凍時にエラーが発生した時用にエラートラップをし、成功時にはtrueを失敗時にはfalseを返すようにしています。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
'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 Err_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 Functio |
7zip.dllを使ったパターン
7zip.dllは非常に優れたライブラリで、7z形式だけでなく通常のZIP形式にも対応、また暗号化ZIPの作成・解凍にも対応している為、VBAで使う上ではとても良い選択肢です。32bit版と64bit版とでDLLが分かれているので、利用する場合にはExcel VBAがどちらで動いているのか？注意が必要です。また、7zipの様々なオプション指定により細かく圧縮・解凍する際に指示を与えられるので、オプションリストを見ておくと良いでしょう。
導入手順
外部DLLが必要になるので、7-zip32.dllもしくは7-zip64.dllをWindowsのSystem32ディレクトリ等に入れておく必要があります。ただし、32bit版は、64bit OSならば、c:¥Windows¥SysWow64へ入れ、32bit OSならば、c:¥windows¥system32に入れなければなりません。64bit版は、c:¥windows¥system32に入れることになります。
しかし、環境によってはSystem32ディレクトリに入れることが出来ない環境（管理者権限がない等）もあり得ます。
その場合、DLLを使う関数内で以下のコードを追記し、参照するディレクトリをカレントディレクトリに変更し、DLLはAccessファイルと同じディレクトリに入れておく事で利用する事が可能になります。Excelの場合には、ActiveWorkbook.Pathを使用します。
|
1 2 3 4 |
'DLL読み込みカレントディレクトリの変更等用 ChDrive Application.CurrentProject.Path ChDir Application.CurrentProject.Path ChDriver = Application.CurrentProject.Path |
また、利用する為にはGeneralプロシージャにDLL参照用の宣言が必要になります。下記は32bitおよび64bit両方に対応した宣言です。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 |
#If Win64 Then ' 64Bit 版 Private Declare PtrSafe Function SetCurrentDirectory Lib "kernel32" Alias "SetCurrentDirectoryA" (ByVal lpPathName As String) As LongPtr Public Declare PtrSafe Function UnZip Lib "unzip32" (ByVal hwnd As LongPtr, ByVal szCmdLine As String, ByVal szOutPut As String, ByVal wSize As LongPtr) As LongPtr Private Declare PtrSafe Function SevenZip Lib "7-zip64.dll" (ByVal hwnd As LongPtr, ByVal szCmdLine As String, ByVal szOutPut As String, ByVal dwsize As LongPtr) As LongPtr Private Declare PtrSafe Function SevenZipGetFileCount Lib "7-zip64.dll" (ByVal szArcName As String) As LongPtr #Else ' 32Bit 版 Private Declare Function SetCurrentDirectory Lib "kernel32" Alias "SetCurrentDirectoryA" (ByVal lpPathName As String) As Long Public Declare Function UnZip Lib "unzip32" (ByVal hwnd As Long, ByVal szCmdLine As String, ByVal szOutPut As String, ByVal wSize As Long) As Long 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 Private Declare Function SevenZipGetFileCount Lib "7-zip32.dll" (ByVal szArcName As String) As Long #End If |
実際に使ってみる
圧縮をしてみる
今回は適当なディレクトリにファイルを突っ込んで、フォルダを圧縮してみたいと思います。今回は通常通りのzip形式で、暗号化ZIPとして生成します。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 |
Function SevenZipCompress(filename As Variant, inffilename As Variant, strPass As Variant) 'ファイル圧縮処理 Dim cmdlin As String ' DLLに渡すコマンド Dim FileName2 As String ' 書庫ファイル名(拡張子のみを変更) Dim CurMem As String ' カレント Dim DirMem As String ' フォルダ名 Dim FileMem As String ' ファイル名 Dim SevenZipOpt As String '圧縮レベルなどの設定 SevenZipOpt = GetSevenZipOption(1, strPass) ' フォルダ取得処理 CurMem = GetDirectoryMemberSplit(filename, DirMem, FileMem) 'ファイルネームは牧場名を付与する FileName2 = inffilename 'コマンドライン作成 '<!-- #Release 1.1dで変更・追加されたコード --> cmdlin = "a " & SevenZipOpt & Chr(34) & FileName2 & Chr(34) & " " & Chr(34) & CurMem & Chr(34) & " " & Chr(34) & FileMem & Chr(34) & " " & "-ms=off" SevenZipcmp cmdlin, FileName2 '<!-- #Release 1.1cで変更・追加されたコード(終了) --> End Function Function GetSevenZipOption(Opt1 As Integer, strPass As Variant) As String 'プルダウンやスクロールバーで選択したオプションによって 'コマンドラインオプションを変更する。 Dim compoption As Variant Select Case Opt1 Case 0 compoption = "-m0=LZMA -mx=9" Case 1 compoption = "-m0=PPMd " Case 2 compoption = "-m0=BZip2 " Case 3 compoption = "-m0=Deflate " Case 4 compoption = "-m0=BCJ -m1=LZMA " Case 5 compoption = "-m0=BCJ2 -m1=LZMA " Case 6 compoption = "-m0=Copy " End Select 'パスワード付オプションで指定(mori51) GetSevenZipOption = "-t7z " & compoption & " -p" & strPass & " " End Function Private Sub SevenZipcmp(cmdlin As String, filename As String) '実際の圧縮処理 Dim ret As LongPtr 'DLLの返却値 Dim Choice As Integer '上書き確認の選択内容を格納 Dim cmdLen As LongPtr 'コマンドラインの文字数を格納 Dim buf As String * 32767 'バッファ If Dir(filename, vbNormal) <> "" Then '上書き確認処理 Choice = MsgBox(filename & "はすでに存在しています。" & vbCrLf & _ "ファイルを上書きしますか?" & vbCrLf & _ "(はいで上書き,いいえで圧縮中止)", _ vbYesNo + vbInformation, "上書き確認") Else Choice = 0 End If Select Case Choice Case vbYes 'はいを選んだ場合、もとの書庫を削除する。 Kill filename Case vbNo 'キャンセルを選んだ場合、メッセージを出し、処理せずにプロシージャから抜ける MsgBox "圧縮をキャンセルしました。", vbCritical, "Failed" Exit Sub End Select 'ここでDLLを読み出して、圧縮処理を行う。 ret = SevenZip(Application.hwnd, cmdlin, buf, Len(buf)) 'If ret <> 0 Then ' '失敗メッセージ ' MsgBox "圧縮に失敗しました。Error Code:0x" & Hex(ret), vbCritical, "Failed" 'End If End Sub 'フォルダを暗号化ZIPで圧縮するテスト Function test7zipComp() '変数の宣言 Dim filepath As Variant '作成するファイルのパス（拡張子まで含む） Dim folderpath As Variant '圧縮するフォルダのパス（ファイル単体も可） Dim strPass As Variant '設定するパスワード Dim ret As Variant 'ファイルのパスを格納 filepath = "ここに作成するZIPファイルのフルパスを拡張子まで含めて入力" folderpath = "圧縮対象とするフォルダのフルパス" strPass = "設定するパスワード" 'ZIP解凍を実行 ret = SevenZipCompress(folderpath, filepath, strPass) End Function Public Function GetDirectoryMemberSplit(filename As Variant, MakeDir As String, MakeFile As String) ' 拡張子を除いたファイル名を取得および分割させる自前の関数。 ' ちなみにMakeDirやMakeFileは分割されたファイル名を格納される。 Dim z As Integer ' 圧縮ファイル名の文字操作に利用 Dim p As Integer ' 圧縮ファイル名の文字操作に利用 Dim Fn As String ' 圧縮ファイルのあるパス名 Dim Fl As String ' 圧縮ファイル名 ' 念のため変数をすべて初期化 MakeDir = "" MakeFile = "" Fn = "" Fl = "" p = 0 z = 0 ' ""の位置を取得し、位置を変数に格納 Do While Mid(filename, Len(filename) - z, 1) <> "" Or Len(filename) <= z z = z + 1 If Mid(filename, Len(filename) - z, 1) = "." And p = 0 Then ' "."の位置を取得し、位置を変数に格納 p = z + 1 End If Loop ' フォルダ名を取得 Fl = Left(filename, Len(filename) - z) ' ファイル名を取得 Fn = Right(filename, z) ' 引数と格納バッファに格納する。 MakeFile = Fn MakeDir = Left(Fn, Len(Fn) - p) GetDirectoryMemberSplit = Fl End Function |
- 暗号化のオプションは、cmdlinの中にある「-p」です。これに間を空けずにパスワードを繋げるのがポイントです。この部分がなければ、通常のZIPファイルの圧縮となります（よってその場合、引数にstrPassも不要になる）
- SevenZipに渡すまでの間の処理で、2つの作業用関数を使用しています（SevenZipcmpとGetSevenZipOption）
- SevenZip関数に渡す場合、ウィンドウハンドルを渡す必要がありますが、Excelの場合はApplication.hwnd、Accessの場合はApplication.hWndAccessAppで渡します。
- 圧縮実行時のfolderpathは今回はフォルダを指定していますが、ファイル単体を指定しても圧縮してくれます。
- 今回は圧縮オプションとして7zip互換のLZMAで圧縮レベル9で実行しています。
解凍をしてみる
今回はExcelで暗号化ZIPを解凍してみようと思います。今回は通常通りのzip形式です。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 |
'7zipで解凍をする Function sevenzipmelt(archivepath As Variant, strPass As Variant) As Variant Dim cmdlin As String ' DLLに渡すコマンドライン。 Dim ret As Variant ' DLLの返却値 Dim Fl As String ' カレントフォルダ名 Dim Fn As String ' 作成フォルダ名 Dim dummy As String ' ダミー変数 Dim pbsl As String ' "\"を格納する変数 Dim aa As String aa = String(32767, " ") filename = archivepath ' フォルダ取得処理 Fl = GetDirectoryMemberSplit(filename, Fn, dummy) ' "\"が存在？ pbsl = Getpbsl(Fl & Fn) ' 仕様上、フォルダを作らないと解凍できないので、格納ファイルが2個以上あるときはフォルダを作成 ' なお、フォルダが存在していたら作らないでおく。 If SevenZipGetFileCount(filename) >= 2 And Dir(Fl & Fn, vbDirectory) = "" Then MkDir Fl & Fn End If 'パスワード付き7zipの解凍コマンドライン cmdlin = "x " & Chr(34) & filename & Chr(34) & " " & "-aoa -p" & strPass & " -o" & Chr(34) & Fl & Fn & "\" & Chr(34) ' DLLに値を渡す。 ret = SevenZip(Application.hwnd, cmdlin, aa, 32767) 'Access VBAの場合はhwndは以下のように渡す 'SevenZip(Application.hWndAccessApp, cmdlin, aa, 32767) '解凍先フォルダを返す sevenzipmelt = Fl & Fn End Function Public Function GetDirectoryMemberSplit(filename As Variant, MakeDir As String, MakeFile As String) ' 拡張子を除いたファイル名を取得および分割させる自前の関数。 ' ちなみにMakeDirやMakeFileは分割されたファイル名を格納される。 Dim z As Integer ' 圧縮ファイル名の文字操作に利用 Dim p As Integer ' 圧縮ファイル名の文字操作に利用 Dim Fn As String ' 圧縮ファイルのあるパス名 Dim Fl As String ' 圧縮ファイル名 ' 念のため変数をすべて初期化 MakeDir = "" MakeFile = "" Fn = "" Fl = "" p = 0 z = 0 ' "\"の位置を取得し、位置を変数に格納 Do While Mid(filename, Len(filename) - z, 1) <> "\" Or Len(filename) <= z z = z + 1 If Mid(filename, Len(filename) - z, 1) = "." And p = 0 Then ' "."の位置を取得し、位置を変数に格納 p = z + 1 End If Loop ' フォルダ名を取得 Fl = Left(filename, Len(filename) - z) ' ファイル名を取得 Fn = Right(filename, z) ' 引数と格納バッファに格納する。 MakeFile = Fn MakeDir = Left(Fn, Len(Fn) - p) GetDirectoryMemberSplit = Fl End Function Public Function Getpbsl(filename As String) As String 'パスの区切り文字チェック処理 If Right(filename, 1) = "\" Then Getpbsl = "" Else Getpbsl = "\" End If End Function '7zipで暗号化ZIPを解凍する Function test7zipmelt() '変数の宣言 Dim filepath As Variant Dim strPass As Variant Dim ret As Variant 'ファイルのパスを格納 filepath = "ここにZIPファイルのフルパスを入れる" strPass = "ここに暗号パスワードを入れる" 'ZIP解凍を実行 ret = sevenzipmelt(filepath, strPass) End Function |
- 暗号化のオプションは、cmdlinの中にある「-p」です。これに間を空けずにパスワードを繋げるのがポイントです。この部分がなければ、通常のZIPファイルの解凍となります（よってその場合、引数にstrPassも不要になる）
- SevenZipに渡すまでの間の処理で、2つの作業用関数を使用しています（GetpbslとGetDirectoryMemberSplit）
- SevenZip関数に渡す場合、ウィンドウハンドルを渡す必要がありますが、Excelの場合はApplication.hwnd、Accessの場合はApplication.hWndAccessAppで渡します。
初めまして。
まさに自分がやりたいことを掲載されていたので、参考にさせていただいております。
まだまだ勉強中で、知識が足らず困っております。
もしよければご教授いただけませんでしょうか？
やりたいこととしましては、outlookのメールを受信した際にパスワードのかかった添付ファイル（ZIPファイル）を自動保存し、別送のパスワードで解凍をVBAで行いたいと考えております。
現状、添付ファイルを自動的に保存することはできている状態です。
上記を参考にし、エクセルVBAで解凍はできました。
outlookでやろうとするとデバックしてしまいます。
コードを見ていないので推測なのですが
コードのどのあたりでデバッグで止まるのか？というのがわかると良いのですが
当方のコードは64bitコード/32bitコードを判定しての共用コードなのでありえる事象としては
１．Outlook VBA実行環境が32bit版のOutlookである
2.暗号化ZIPの解凍には7-zip64.dllが必要ですが、32bitの場合は7-zip32.dllが必要
3.VBAから見て、2.のDLLが見つからない（カレントディレクトリもしくは、32bitだとsystem32ディレクトリ内にDLLが入っていない）
4.64bitの場合、カレントディレクトリもしくはSysWOW64のディレクトリ内にDLLが入っていない
のいくつかになるかなぁと思います。DLLの呼び出し宣言はPtrSafeつけるかつけないかが、64bit/32bitの違いなので、おそらくは3.4.あたりかなぁと思います。
ただ、Outlookの場合、カレントディレクトリと呼べるものがないので、system32もしくはSysWOW64に7-zipのそれぞれのバージョンのDLLが入っていないとか。
どうでしょう？