【VBA】ZIP解凍の完了確認｜CopyHereの戻りを実測

VBAでZIPを解凍し、その直後にファイルを開く。この流れで気になるのが、解凍が終わる前に次の行へ進まないか、という点です。Shell.ApplicationのCopyHereには、完了を知らせる仕組みがありません。

そこで、実際にどう動くかを実機で測りました。この記事では、その結果と、念のため完了を確認するコード、Sleep APIを32bit・64bit両対応で宣言する方法をまとめます。

この記事の想定読者
困った場面：CopyHereの直後に処理を進めてよいのか
実測：今回の環境ではCopyHereは完了まで戻らなかった
念のため完了を確認するコード
アイテム数を数える方法の落とし穴
Sleep APIは#If VBA7で宣言する
よくある失敗
応用例
まとめ

この記事の想定読者

VBAでZIPを解凍し、続けて中のファイルを開いている人
CopyHereの直後に処理を進めて問題ないか、不安な人
Declare文を32bit・64bit両方のOfficeで使いたい人

困った場面：CopyHereの直後に処理を進めてよいのか

VBAには、ZIPを解凍する標準の命令がありません。Windowsのシェル機能（Shell.Application）を呼び出し、CopyHereでコピーする方法が定番です。

Sub UnzipNaive()
    Dim sh As Object, vZip As Variant, vDst As Variant
    Set sh = CreateObject("Shell.Application")
    vZip = "C:\work\data.zip"
    vDst = "C:\work\out"
    sh.Namespace(vDst).CopyHere sh.Namespace(vZip).Items, 20
    Workbooks.Open "C:\work\out\f1.xlsx"   ' 解凍は終わっているのか
End Sub

Microsoftの公式ドキュメントには、コピーが完了しても呼び出し元に通知されない、と書かれています。完了を待たずに次の行が動くのであれば、Workbooks.Openがファイルを見つけられない可能性があります。

実測：今回の環境ではCopyHereは完了まで戻らなかった

64bit版Office（Win64=True）で、ローカルのTEMPフォルダに解凍して測りました。データは乱数で作った、圧縮されにくいファイルです。

ZIPの中身	CopyHereが戻るまで	戻った時点で展開済み
大きいファイル3本（合計90MB）	約0.9〜1.1秒	3本中3本
小さいファイル3000個（各4KB）	約36〜39秒	3000個中3000個
大きいファイル1本（300MB）	約2.7秒	1本中1本
大きいファイル1本（1,000MB）	約8.6秒	1本中1本

CopyHereのフラグは、90MBと3000個では0・4・16・20・1024・1044の6通りで測りましたが、結果に違いはありませんでした（300MBと1,000MBはフラグ20のみ）。「展開済み」は、ZIPの中身と同じ名前・同じサイズで、ほかのプロセスが開いていないことで判定しています。

つまり今回の環境では、CopyHereの戻りを待つだけで足りました。ただし、ネットワークドライブ、1GBを超えるZIP、ウイルス対策ソフトが動く環境などは未検証です。

念のため完了を確認するコード

ZIPの中身（ファイル名とサイズ）は、解凍の前に読み取れます。展開先に同じ名前・同じサイズのファイルが全部そろい、開けるようになれば、完了とみなします。

#If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

' ZIPを展開先フォルダへ解凍し、全ファイルがそろうまで待つ。
' 完了したらTrue、タイムアウト・ZIPが開けない・展開先がないときはFalse。
' zipPath・destFolderは絶対パス。destFolderは存在するフォルダ。
Public Function UnzipAndWait(ByVal zipPath As String, ByVal destFolder As String, _
                             Optional ByVal timeoutSec As Long = 30) As Boolean
    Dim sh As Object, srcNs As Object, dstNs As Object
    Dim vZip As Variant, vDst As Variant
    Dim entries As Collection
    Dim t0 As Double

    If Right$(destFolder, 1) <> "\" Then destFolder = destFolder & "\"

    Set sh = CreateObject("Shell.Application")
    vZip = zipPath
    vDst = destFolder
    Set srcNs = sh.Namespace(vZip)
    Set dstNs = sh.Namespace(vDst)
    If srcNs Is Nothing Then Exit Function
    If dstNs Is Nothing Then Exit Function

    ' ZIPの中身（相対パスとサイズ）を先に控える
    Set entries = New Collection
    CollectZipItems srcNs, "", entries
    If entries.Count = 0 Then Exit Function

    dstNs.CopyHere srcNs.Items, 20   ' 4(進捗を出さない)+16(すべて「はい」)

    t0 = Timer
    Do
        If AllFilesReady(destFolder, entries) Then
            UnzipAndWait = True
            Exit Do
        End If
        If ElapsedSec(t0) > timeoutSec Then Exit Do
        Sleep 300
        DoEvents
    Loop
End Function

Private Sub CollectZipItems(ByVal ns As Object, ByVal relPath As String, ByVal entries As Collection)
    Dim it As Object, nm As String
    For Each it In ns.Items
        nm = Mid$(it.Path, InStrRev(it.Path, "\") + 1)
        If it.IsFolder Then
            CollectZipItems it.GetFolder, relPath & nm & "\", entries
        Else
            entries.Add Array(relPath & nm, CDbl(it.Size))
        End If
    Next it
End Sub

Private Function AllFilesReady(ByVal destFolder As String, ByVal entries As Collection) As Boolean
    Dim e As Variant
    For Each e In entries
        If Not IsFileReady(destFolder & e(0), CDbl(e(1))) Then Exit Function
    Next e
    AllFilesReady = True
End Function

' ファイルが存在し、サイズが一致し、ほかのプロセスが開いていなければTrue
Private Function IsFileReady(ByVal filePath As String, ByVal expectSize As Double) As Boolean
    Dim fn As Integer
    On Error GoTo EH
    If FileLen(filePath) <> expectSize Then Exit Function
    fn = FreeFile
    Open filePath For Binary Access Read Lock Read Write As #fn
    Close #fn
    IsFileReady = True
    Exit Function
EH:
    IsFileReady = False
End Function

Private Function ElapsedSec(ByVal t0 As Double) As Double
    Dim e As Double
    e = Timer - t0
    If e < 0 Then e = e + 86400   ' 日付をまたいだ場合
    ElapsedSec = e
End Function

使い方は次のとおりです。展開先のフォルダは先に作っておきます。

If UnzipAndWait("C:\work\data.zip", "C:\work\out") Then
    Workbooks.Open "C:\work\out\f1.xlsx"
Else
    MsgBox "解凍が完了しませんでした"
End If

再現用の最小コードで、CopyHereだけの場合とUnzipAndWaitを使った場合を比べると、次のとおりでした。

CopyHereが戻った時点で3ファイルとも展開済みで、UnzipAndWaitの戻り値もTrueだったイミディエイトウィンドウの出力 — 再現用の最小コードの実行結果（64bit版Office）

ZIPの中にフォルダがあっても、相対パスでたどって照合します。今回の環境では、どちらのZIPでも戻り値はTrueで、所要時間はCopyHereの所要とほぼ同じでした（90MBで約0.9〜1.2秒）。壊れたZIPと存在しない展開先は、待たずにFalseで戻りました。

上限（既定30秒）に達したらFalseを返します。この分岐は、今回の環境では待ちが発生せず、動作を確認できていません。

アイテム数を数える方法の落とし穴

解凍の前後で展開先のアイテム数を比べ、増えたら完了とする方法もあります。ただし、展開先に同名のファイルが残っていると、数が変わらず検知できません。同じZIPを再展開して10秒見ましたが、数は増えませんでした。

ZIPと同名のフォルダが現れるのを待つ方法も試しました。ただ、今回の環境ではどの方法も、調べた時点で解凍が終わっていたため、判定方法としての優劣は付けられませんでした。そこで、中身の名前とサイズで照合する方法を載せています。

Sleep APIは#If VBA7で宣言する

VBAにはSleepがありません。Windows APIを宣言して使います。64bit版Officeでは、Declare文にPtrSafeが必要です。

#If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

#If VBA7は、Office 2010以降のVBAで真になります
64bit版でDeclareにPtrSafeがないと、コンパイルエラーになると公式に書かれています
Sleepの引数は時間なのでLongのままです。LongPtrはポインタやハンドル用です

今回は64bit版（VBA7・Win64とも真）で、Sleep 300が約0.32秒で動きました。32bit版は未検証です。64bit版Officeで古いコードが動かない例は、ScriptControlが64bit Officeで使えない時の代替コードでも扱っています。

よくある失敗

展開先に前回のファイルが残っている：確認の条件は「同名・同サイズのファイルがある」ことなので、解凍前から成立してしまいます。展開先は空のフォルダにします
展開先のフォルダがない：先に作っておきます。ない場合は、待たずにFalseで戻ります
ZIPの中にZIPがある：この記事の方法では対象外です。内側のZIPは別に解凍します