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

excel-vba-lhaplus-zip.vba

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

作者のブログにも掲載しています。
https://tanaka-misaki.blogspot.jp/2011/12/vbalhapluszip.html