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


仕事でVBAからファイル圧縮できたら便利だと思い、ちょっと乱暴ですが、VBAからLhaplusを起動してZIP圧縮をするプログラムを書きました。Lhaplusをインストールして、パスを通してから使ってください(環境変数)。

このコードを書くにあたり、下記のサイトを参考にさせていただきました。
このコードは、Windows7/Excel2007/Lhaplus1.59で動作確認しました。

2011/12/21コード修正しました。(パスにスペースが含まれても大丈夫なようにダブルクォーテーションを追加など)

Option Explicit
 
Sub test()
 
    'パスは適宜書き換えて使ってください
    Call zipByLhaplus("C:\Temp\テスト.txt", "C:\Temp")
     
End Sub
 
'Lhaplusを使ってファイルを圧縮する
'Lhaplus.exeが入っているディレクトリにパスを通してから実行
Private Sub zipByLhaplus(ByVal targetPath As String, _
        ByVal destinationPath 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 & """" & _
            " " & """" & 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


COMMENTS

名前

Android,8,Canon,1,EOS Kiss X7,1,Excel,3,GIMP,5,Git,3,Git Bash,3,Inkscape,3,iPhone,1,Kindle,2,PC,4,SSH,3,Thinkpad X240,1,Thinkpad X260,2,TOEFL,1,TOEIC,4,VBA,4,VBScript,2,WEB制作,3,Windows,3,Windows 10,1,インターネットバンキング,1,カメラ,1,デザイン,1,圧縮&解凍,2,英語,8,撮影機材,1,雑感,1,資格,13,情報処理技術者試験,5,電子書籍,2,読書,1,簿記,2,
ltr
item
勉強とガジェット: VBAからLhaplusを使ってZIP圧縮を行う
VBAからLhaplusを使ってZIP圧縮を行う
https://2.bp.blogspot.com/-FJPrN36ML2w/WENSGr50HYI/AAAAAAABwNY/ERYJQR7Ni0wwotjDcK1jV28L5psmikf7gCLcB/s400/workbook-1205068_1920.jpg
https://2.bp.blogspot.com/-FJPrN36ML2w/WENSGr50HYI/AAAAAAABwNY/ERYJQR7Ni0wwotjDcK1jV28L5psmikf7gCLcB/s72-c/workbook-1205068_1920.jpg
勉強とガジェット
http://tanaka-misaki.blogspot.com/2011/12/vbalhapluszip.html
http://tanaka-misaki.blogspot.com/
http://tanaka-misaki.blogspot.com/
http://tanaka-misaki.blogspot.com/2011/12/vbalhapluszip.html
true
8692194293250221214
UTF-8
Loaded All Posts Not found any posts VIEW ALL Readmore Reply Cancel reply Delete By Home PAGES POSTS View All RECOMMENDED FOR YOU LABEL ARCHIVE SEARCH ALL POSTS Not found any post match with your request Back Home Sunday Monday Tuesday Wednesday Thursday Friday Saturday Sun Mon Tue Wed Thu Fri Sat January February March April May June July August September October November December Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec just now 1 minute ago $$1$$ minutes ago 1 hour ago $$1$$ hours ago Yesterday $$1$$ days ago $$1$$ weeks ago more than 5 weeks ago Followers Follow THIS CONTENT IS PREMIUM Please share to unlock Copy All Code Select All Code All codes were copied to your clipboard Can not copy the codes / texts, please press [CTRL]+[C] (or CMD+C with Mac) to copy