ファイル圧縮時のエラー発生

質問

office2016

あるフォルダから必要なファイルがc:\work配下へコピーされていて、
このフォルダ配下の圧縮ファイルをc:\logフォルダへファイル名log.zipとして登録するマクロを実行すると、ファイルが見つからないか、読み取りのアクセス許可がありません
と表示されることがあります。
同じファイルで実行した時、エラー発生しないときもあります。

実施した例は、下記で、それぞれの容量は１KBです。
c:\workに
test1.txt
test2.txt
test3.txt
があって、
マクロ実行すると
c:\workの中は空になり、
c:\log配下にlog.zipファイルが作成されるマクロとしています。

実行マクロは下記です。

Sub zip()
fpath = "C:\work\"

'空のZIPファイル作成
Set fso = CreateObject("Scripting.FileSystemObject")

Set ts = fso.CreateTextFile("c:\log\" & "log.zip")

msg = "PK" & Chr(5) & Chr(6) & String(18, 0)

ts.Write (msg)
ts.Close

'フォルダオブジェクト取得
Set sh = CreateObject("Shell.Application")

Set fol = sh.Namespace("c:\log\" & "log.zip")

'サンプル：フォルダ内のファイルを圧縮
FName = Dir(fpath & "*.*")
Do While (FName <> "")
fol.MoveHere fpath & FName 'ZIPへファイル追加
FName = Dir()
Loop

End Sub

デバッグモードで実行する分には、
ファイルが見つからないか、読み取りのアクセス許可がありません
というエラーは発生しません。

何が原因なのでしょう？また、対策を教えていただきたく。
また、WEBから参照したマクロなのですが、
msg = "PK" & Chr(5) & Chr(6) & String(18, 0)

ts.Write (msg)
ts.Close
の部分の意味も教えていただけたらと思います。

回答No.1

nishi6 · ベストアンサー

提示のコードは多分「Option Explicit」が宣言されていないので、変数が唐突に表れて見づらいですね。宣言する癖をつけて、しっかり変数の意味を捉えないと、何をやっているか分からなくなるでしょう。

zipファイルを作るコードを書いてみました。質問にある機能（提示のコート）は実現しているはずです。

＞c:\workの中は空になり・・・
提示のコードで、消しているようには見えません。怖いので、回答のコードも消していません。

＞msg = "PK" & Chr(5) & Chr(6) & String(18, 0)・・・・
先頭4バイトでZIP形式ファイルを示しています。 普通は"PK" & Chr(3) & Chr(4) ですが、5,6ということは、セントラルディレクトリエントリと呼ばれる構造になります。「ZIP (ファイルフォーマット) - Wikipedia」を見てください。
ts.Write (msg)　空のzipファイルを作り、
ts.Close　でそのzipファイルを閉じています。

＞ファイルが見つからないか、読み取りのアクセス許可がありません
＞と表示されることがあります。
＞同じファイルで実行した時、エラー発生しないときもあります。
質問者さんの実行環境が分からないので、回答のコードでは、コピー終了まで待機するようにしてみました。結果を確かめてください。
zipPath(zipファイルのパス)とsrcPath(元ファイルのパス)は設定してください。パスの最後に「￥(半角)」はありません。
当方、Win10、Excel2010です。

Sub makeZip()
　'// 初期化
　Dim objFSO As Object
　Dim objShell As Object
　　Set objFSO = CreateObject("Scripting.FileSystemObject")
　　Set objShell = CreateObject("Shell.Application")

　Dim zipPath As String　 '// 圧縮ファイルのパス
　Dim zipFName As String　'// 圧縮ファイル名
　Dim srcPath As String　 '// 元ファイルのパス
　　zipPath = "N:\++++\++++\zip"
　　zipFName = "sample.zip"
　　srcPath = "N:\++++\++++\src"

　'// ZIPファイルの作成(ZIPファイルがあれば削除)
　If objFSO.FileExists(srcPath) Then
　　objFSO.DeleteFile srcPath
　End If
　'// 空のZIPファイルを作成する
　Dim objEmp As Object
　　Set objEmp = objFSO.CreateTextFile(zipPath & "\" & zipFName, True)
　　objEmp.Write "PK" & Chr(5) & Chr(6) & String(18, 0)
　　objEmp.Close

　'// ZIPファイルに元ファイルをコピー
　Dim objZip As Object
　Dim srcFNAME As String
　Dim srcCnt As Integer
　Set objZip = objShell.Namespace(objFSO.GetAbsolutePathName( _
　　　　　　　　　　　　　　　　　zipPath & "\" & zipFName))
　srcFNAME = Dir(srcPath & "\" & "*.txt")
　Do While (srcFNAME <> "")
　　objZip.CopyHere srcPath & "\" & srcFNAME
　　srcCnt = srcCnt + 1
　　　'// 待機(コピーの終了まで)
　　　Do While objZip.Items().Count < srcCnt
　　　　　DoEvents
　　　Loop

　　srcFNAME = Dir()
　Loop
　MsgBox "終了しました。"
End Sub

お礼

回答ありがとうございます。
分かりやすい説明で助かりました。(^^)

補足

＞c:\workの中は空になり・・・
提示のコードで、消しているようには見えません
→
fol.MoveHere fpath & FName 'ZIPへファイル追加
の部分で移動してます

なので提示いただいたコード
objZip.CopyHere srcPath & "\" & srcFNAME
は
objZip.MoveHere srcPath & "\" & srcFNAME
としました。