Excel VBAメモ 外部DLLを使わずにzip形式の圧縮ファイルを作ってみる
少し前に圧縮ファイルを展開するのを記事にしたんだけど(記事はここ)、逆もやってみたくなるのも自然な流れ?
ポイントはこんな感じ。
- 空のzip形式圧縮ファイルを作成する
※ファイルを作るときは圧縮ファイルとして認識させるためのおまじないを書き込む - zip形式の圧縮ファイルをフォルダーにみたててファイルをコピーする
※ファイルがコピーされたかどうかをチェックする必要がある - 外部のDLLを使わない
今回のコードの動きとしてはこんな感じ。
- デスクトップに圧縮ファイルを作成する
- 圧縮ファイルに入れるファイルはデスクトップにある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
圧縮ファイルの中にコピーするファイルはこんな感じ。
で、実行するとこんな感じ。
デスクトップに圧縮ファイルができとる。
中身を見てるとちゃんとファイルがコピーされとる。
展開してみると展開できる。
んまま、明日への自分へのメモってことで。
ディスカッション
コメント一覧
AddItemにForreahで追加すると、2回目の呼び出し後から下記のコードで永遠と止まってしまいます。何か知見をお持ちでしょうか?
Do While objCompress.Items().count < nCounter
DoEvents
Loop
コメントありがとうございます。
申し訳ありませんが、AddItemに関連する記述を具体的に教えていただけないでしょうか?
追記です。
コピー元のファイルが存在するかをチェックしてみてもらえないでしょうか?
参考にさせていただきましたが、以下のループでエラーが発生するため、
DoEventsをCall Sleep(300)に変更して対応しています。
Do While objCompress.Items().Count < nCounter
DoEvents
Loop
おそらくですが、処理が速すぎてobjCompress.Items().Countを参照するときに
アクセスエラーになっているようです。
コピーファイルが大きく、ファイル数が多いと発生しやすい、気がします。
修正前のソースだと、私の環境では100%エラーになります。
Sleep(100)でも同様のエラーが発生します。
私の場合はSleep(200)なら大丈夫そうですが、今は余裕を見てSleep(300)にしています。
状況に応じてウエイトを大きくする必要があるかもしれません。
Sleepだとタイムラグがあるので、もっとスマートな方法があるといいのですが。
返信が遅くなり大変失礼しました。
コメントありがとうございます!
当時の記憶が…ご指摘のとおりあるサイズが大きくファイル数が多いと、Windows側のファイルのコピー処理が完了していないにもかかわらずVBAの処理が進んでしまいエラーになってしまいます。
一方で当時調べた限りでは、VBAにファイルのコピー処理が完了したかどうかを判定する便利な関数がなく、記事に記載の方法となった経緯があります。
せっかくコメントいただいたのもご縁ですので、いつかはお約束できませんが何かスマートな方法がないか調べてみます。
あれ?コメントできたのかな。