zipファイルの解凍

ファイル/フォルダをzipファイルに圧縮で書いた圧縮関数のペアとなる解凍の関数の実装。

圧縮の関数と同様に、Scripting.FileSystemObject、Shell.Applicationを使用。

zipファイルから直接コピーする実装にしようとしたけど、Scripting.FileSystemObjectでそのような実装ができなかったので、一旦、zipファイルの中身を全体をワークフォルダに解凍して、解凍したファイル/フォルダを展開先に移動するように実装。
展開先のフォルダが存在している場合は、ゴミファイルが残るので削除してから展開したりしてるので、思ったよりコードが大きくなった。
展開先のフォルダは引数(pthary)で指定。引数unzipfldはzipファイルの内容全体を解凍するワークフォルダを指定する。

コード

Public Function unzip(pthary() As String, zippth As String, unzipfld As String) As Boolean
    unzip = False
    On Error GoTo Err
    Dim sfo As Object, app As Object
    Set sfo = CreateObject("Scripting.FileSystemObject")
    Set app = CreateObject("Shell.Application")
    If is_folder(unzipfld) = True Then
        If delete_pth(unzipfld, sfo) = False Then
            Exit Function
        End If
    ElseIf Dir(unzipfld, vbNormal) <> "" Then
        Debug.Print "unzip(): フォルダ以外のファイル(" & unzipfld & ")が存在"
        Exit Function
    End If
    MkDir unzipfld
    Dim unzipfld_ As Variant, zippth_ As Variant
    unzipfld_ = sfo.GetAbsolutePathName(unzipfld)
    zippth_ = sfo.GetAbsolutePathName(zippth)
    app.Namespace(unzipfld_).CopyHere app.Namespace(zippth_).items, &H4 Or &H10
    unzip = move_pth4unzip(unzipfld_, pthary, sfo, app)
Err:
    If Err.Number <> 0 Then
        Debug.Print "unzip(): " & Err.Description
    End If
    Set sfo = Nothing
    Set app = Nothing
End Function

Private Function move_pth4unzip(unzipfld As Variant, pa() As String, sfo As Object, app As Object) As Boolean
    move_pth4unzip = False
    On Error GoTo Err
    Dim idx As Long, maxidx As Long
    maxidx = UBound(pa, 1)
    Dim f As Variant
    For Each f In app.Namespace(unzipfld).items
        Debug.Print f.Name
        For idx = 0 To maxidx
            If basename(pa(idx)) = f.Name Then
                Exit For
            End If
        Next
        If idx <= maxidx Then
            If move_pth4unzip1(CStr(unzipfld), f.Name, pa(idx), sfo) = False Then
                Exit Function
            End If
        Else
            Debug.Print "move_pth4unzip(): " & _
                    "zipファイルに展開対象外ファイル(=""" & f.Name & """)が含まれていた:=>を無視"
        End If
    Next
    move_pth4unzip = True
Err:
    If Err.Number <> 0 Then
        Debug.Print "move_pth4unzip(): " & Err.Description
    End If
End Function

Private Function move_pth4unzip1(fr_fld As String, fr_fn As String, to_pth As String, sfo As Object) As Boolean
    move_pth4unzip1 = False
    On Error GoTo Err
    If Dir(to_pth) <> "" Or is_folder(to_pth) = True Then
        If delete_pth(to_pth, sfo) = False Then
            Exit Function
        End If
    End If
    Dim fr_pth As String: fr_pth = fr_fld & "\" & fr_fn
    If is_folder(fr_pth) = True Then
        sfo.MoveFolder fr_pth, to_pth
    Else
        sfo.MoveFile fr_pth, to_pth
    End If
    move_pth4unzip1 = True
Err:
    If Err.Number <> 0 Then
        Debug.Print "move_pth4unzip1(): " & Err.Description
    End If
End Function

'「ファイル/フォルダをzipファイルに圧縮」の記事にあった関数と同じ関数
'⇒コメントアウトしている
'Public Function is_folder(pth As String) As Boolean
'    is_folder = CreateObject("Scripting.FileSystemObject").FolderExists(pth)
'End Function

Public Function basename(pth As String) As String
    Dim pth_ As String: pth_ = Trim(pth)
    If Right(pth_, Len("\")) = "\" Then
        pth_ = Left(pth_, Len(pth_) - Len("\"))
    End If
    Dim pos As Long
    pos = InStrRev(pth_, "\")
    If pos <> 0 Then
        basename = Right(pth_, Len(pth_) - pos)
    Else
        basename = pth_
    End If
End Function

Public Function delete_pth(pth As String, sfo As Object) As Boolean
    delete_pth = False
    On Error GoTo Err
    If Dir(pth) = "" And is_folder(pth) = False Then
        Debug.Print "delete_pth(): 対象パス(" & pth & ")が存在しない"
    Else
        If is_folder(pth) = True Then
            sfo.DeleteFolder pth
        Else
            Kill pth
        End If
    End If
    delete_pth = True
Err:
    If Err.Number <> 0 Then
        Debug.Print "delete_pth(): " & Err.Description
    End If
End Function