1
6

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

More than 5 years have passed since last update.

zipファイルの解凍

Posted at

ファイル/フォルダを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
1
6
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
1
6

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?