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