VBAからLhaplusを使ってZIP圧縮を行う

VBAからLhaplusを起動してZIP圧縮をするプログラムを書きました。オプションでパスワードを付けることもできます。

Lhaplusをインストールして、パスを通してから使ってください（環境変数）。パスの通し方は別記事「Lhaplusのインストールディレクトリにパスを通す（VBAからLhaplusを使う準備）」で解説しています。

このコードを書くにあたり、下記のサイトを参考にさせていただきました。

MS-DOSコマンドの標準出力を取得する・・・WScript.Shellの使い方を参考にさせていただきました。
vbaでパスワード付き圧縮ファイル作成・・・中身が空のテキストファイルにはパスワードを付けられないことをこちらで知りました。

このコードは、Windows7/Excel2007/Lhaplus1.59で動作確認しました。その後、2018年にコードを修正した際は、Windows10/Exel2016/Lhaplus1.74で動作確認しました。

更新履歴

2011/12/21	コード修正しました。（パスにダブルクォーテーションを追加など）
2018/02/18	コードをGistに置きました。
2018/05/22	コード修正しました。（パスワード対応）

	Option Explicit

	Sub test()

	'パスは適宜書き換えて使ってください

	'パスワード「abcd」でフォルダをZIP圧縮する場合
	Call zipByLhaplus("C:\Temp\テスト", "C:\Temp", "abcd")

	'パスワードなしでフォルダをZIP圧縮する場合
	Call zipByLhaplus("C:\Temp\テスト", "C:\Temp")

	'パスワード「abcd」でファイルをZIP圧縮する場合
	Call zipByLhaplus("C:\Temp\テスト.txt", "C:\Temp", "abcd")

	'パスワードなしでファイルをZIP圧縮する場合
	Call zipByLhaplus("C:\Temp\テスト.txt", "C:\Temp")

	End Sub

	'Lhaplusを使ってファイルを圧縮する
	'Lhaplus.exeが入っているディレクトリにパスを通してから実行
	'引数は、圧縮したいファイルORフォルダ、圧縮したZIPの置き場所、パスワード（オプション）です。
	Private Sub zipByLhaplus(ByVal targetPath As String, _
	ByVal destinationPath As String, Optional ByVal zipPassword As String = "")

	'処理待ちを15秒までとする（適宜書き換え）
	Const WAITING_LIMIT_MILLISEC As Double = (0.25 / (24 * 60))

	Dim FSO As Object
	Dim WSH As Object
	Dim wExec As Object
	Dim startTime As Date
	Dim fileName As String
	Dim tempString As String

	Set FSO = CreateObject("Scripting.FileSystemObject")

	'指定されたパスをチェックする
	If Not (FSO.FileExists(targetPath) Or FSO.FolderExists(targetPath)) Then
	MsgBox "ZIP圧縮対象のファイルまたはフォルダが存在しないため" _
	& "処理を終了します。", vbCritical
	GoTo FNC_End
	End If
	If Not (FSO.FolderExists(destinationPath)) Then
	MsgBox "ZIP圧縮先のフォルダが存在しないため処理を終了します。"
	GoTo FNC_End
	End If
	If FSO.GetFolder(destinationPath).Attributes <> 16 Then
	MsgBox "ZIP圧縮先のフォルダが書き込み可能なフォルダではないため" _
	& "処理を終了します。", vbCritical
	GoTo FNC_End
	End If

	'ZIP圧縮した時のファイル名を作成する（ざっくり）
	fileName = targetPath
	fileName = Mid(fileName, InStrRev(fileName, "\") + 1)
	If fileName Like "." Then
	fileName = Left(fileName, InStrRev(fileName, ".") - 1)
	End If
	fileName = fileName & ".zip"

	'ZIP圧縮後のファイルが存在している場合終了
	If FSO.FileExists(destinationPath & "\" & fileName) Then
	MsgBox "ZIP圧縮先のフォルダに同名のZIPファイルが存在しているため" _
	& "処理を終了します。", vbCritical
	GoTo FNC_End
	End If

	'シェルオブジェクトを作成する
	Set WSH = CreateObject("WScript.Shell")

	'シェルオブジェクトに渡す文字列を作る
	tempString = "Lhaplus.exe /c:zip /o:" & _
	"""" & destinationPath & """"

	'パスワードの指定があれば追加
	If zipPassword <> "" Then
	tempString = tempString & " /p:" & zipPassword
	End If

	tempString = tempString & " " & """" & targetPath & """"

	'Lhaplusで圧縮を行う
	On Error Resume Next
	Set wExec = WSH.Exec(tempString)
	If Err.Number <> 0 Then
	On Error GoTo 0
	MsgBox "Lhaplusの呼び出しに失敗しました。"
	GoTo FNC_End
	End If
	On Error GoTo 0

	startTime = Now

	'処理が終了するまでWindowsに制御を戻す
	Do While wExec.Status = 0
	DoEvents

	'処理が長かったら終了
	If (Now - startTime) >= WAITING_LIMIT_MILLISEC Then
	MsgBox "処理待ちが長くなったので" _
	& "いったん中断します。", vbInformation
	Exit Do
	End If
	Loop

	MsgBox "圧縮処理が完了しました。"

	FNC_End:
	Set FSO = Nothing
	Set wExec = Nothing
	Set WSH = Nothing
	End Sub