Excel VBAメモ外部DLLを使わずにzip形式の圧縮ファイルを作ってみる

2018/11/29

少し前に圧縮ファイルを展開するのを記事にしたんだけど(記事はここ)、逆もやってみたくなるのも自然な流れ？
ポイントはこんな感じ。

空のzip形式圧縮ファイルを作成する
※ファイルを作るときは圧縮ファイルとして認識させるためのおまじないを書き込む
zip形式の圧縮ファイルをフォルダーにみたててファイルをコピーする
※ファイルがコピーされたかどうかをチェックする必要がある
外部のDLLを使わない

今回のコードの動きとしてはこんな感じ。

デスクトップに圧縮ファイルを作成する
圧縮ファイルに入れるファイルはデスクトップにある３つのファイルをコピーする

で、コードはこんな感じ。
コピーするファイルの数は３個ってことにする。

Public Function Method()
    ' --------------------------------------------------
    '
    ' 変数を定義する
    '
    Dim bResult As Boolean
    Dim objFileSystemObject As Object
    Dim objShell As Object
    Dim objStream As Object
    Dim objCompress As Object
    Dim strCompressFilePath As String
    Dim objSourceFilePaths As Collection
    Dim objValue As Variant
    Dim nCounter As Integer
    
    ' --------------------------------------------------
    '
    ' 変数を初期化する
    '
    
    ' オブジェクトを初期化する
    Set objFileSystemObject = CreateObject("Scripting.FileSystemObject")
    Set objShell = CreateObject("Shell.Application")
    ' 圧縮ファイルのパス
    strCompressFilePath = "C:\Users\tetsuyanbo\Desktop\sample.zip"
    ' 入れるファイルのパス
    Set objSourceFilePaths = New Collection
    objSourceFilePaths.Add "C:\Users\tetsuyanbo\Desktop\first.txt"
    objSourceFilePaths.Add "C:\Users\tetsuyanbo\Desktop\second.txt"
    objSourceFilePaths.Add "C:\Users\tetsuyanbo\Desktop\third.txt"
    
    ' --------------------------------------------------
    '
    ' 圧縮ファイルを作成する
    '
    
    ' 既に圧縮ファイルがある場合は削除する
    bResult = objFileSystemObject.FileExists(strCompressFilePath)
    If bResult = True Then
        objFileSystemObject.DeleteFile strCompressFilePath
    End If
    
    ' 空の圧縮ファイルを作成する
    Set objStream = objFileSystemObject.CreateTextFile(strCompressFilePath, True)
    objStream.Write "PK" & Chr(5) & Chr(6) & String(18, 0)
    objStream.Close
    
    ' 圧縮ファイルをフォルダーにみたててファイルをコピーする
    Set objCompress = objShell.Namespace(objFileSystemObject.GetAbsolutePathName(strCompressFilePath))
    For Each objValue In objSourceFilePaths
        objCompress.CopyHere objValue
        nCounter = nCounter + 1
        ' コピーが終わるまで待つ(ファイル数とリストサイズが一緒になるまで待つ)
        Do While objCompress.Items().Count < nCounter
            DoEvents
        Loop
    Next
    
    ' --------------------------------------------------
    '
    ' オブジェクトを破棄する
    '
    If Not objFileSystemObject Is Nothing Then
        Set objFileSystemObject = Nothing
    End If
    If Not objShell Is Nothing Then
        Set objShell = Nothing
    End If
    If Not objStream Is Nothing Then
        Set objStream = Nothing
    End If
End Function

圧縮ファイルの中にコピーするファイルはこんな感じ。