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

VBA

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

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

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

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

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

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

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

で、実行するとこんな感じ。
デスクトップに圧縮ファイルができとる。

中身を見てるとちゃんとファイルがコピーされとる。

展開してみると展開できる。

んまま、明日への自分へのメモってことで。