【Excel VBA】Windowsの標準機能のみでExcelファイルをZIPファイルに圧縮する方法

質問させて下さい。

Lhaplus などを使用（導入）することなく、Windows7の標準機能のみでExcelファイルをZipファイルに圧縮する事は可能なのでしょうか？

マクロの動作としては、
１．作業中のBOOKから必要なシートのみをコピーし別BOOKとして保存
２．別BOOKとして保存したファイルを、同一フォルダ内にZipファイルとして圧縮
３．別BOOKを削除

上の１．と３．は出来たのですが、
２．の圧縮についてが、理解できずにおります。
自分なりに調べたところ、Lhaplus をShell関数などで指定し圧縮をする方法などは紹介されていたのですが、Windows7の標準機能のみZip圧縮を行う事は可能なのでしょうか？

ご存知の方がいましたら、ご教授いただければ幸いです。

No.3 ベストアンサー 回答者： WindFaller 回答日時： 2015/08/04 14:17

こんにちは。

>２．別BOOKとして保存したファイルを、同一フォルダ内にZipファイルとして圧縮
というのは、2007以降のOffice ファイルは、拡張子が変わっただけで、本来は、Zipファイルなのです。あえて、Zipで圧縮する必要があるか分かりませんが、アーカイブに格納ということで、やってみました。

#2さんのリンク先とは、仕組み自体は同じですが、
Set Shell = CreateObject("Shell.Application")
zFolder.CopyHere sFolderItem
で、ZIPフォルダが認識しないことでした。そこで、何度もやった結果、事前に参照設定することで解決しました。

'//
Sub Files2Zip()
　　Dim myPath As String
　　Dim ZipFName As String
　　Dim ZipFNameB As String
　　Dim FName As Variant
　　'要参照設定
　　'Microsoft Shell Controls and Automation
　　Dim objShell As Shell32.Shell　'レイトバインディングだと抜けがあります。
　　Dim ar As Variant, fn As String
　　Dim i As Long, j As Long, k As Long
　　myPath = ThisWorkbook.Path & "\" '任意の場合は、必ず末尾に￥を入れること
　　
　　ZipFNameB = myPath & "MyFilesABC" ' & ".zip" "圧縮名
　　ZipFName = ZipFNameB & ".zip"
　　
　　'一意の出力ファル名の決定
　　fn = Dir(ZipFName & ".zip")
　　Do Until fn = ""
　　　k = k + 1
　　　ZipFName = ZipFNameB & CStr(k) & ".zip"
　　　fn = Dir()
　　Loop
　　
　　FName = Application.GetOpenFilename(FileFilter:="Excel Files (*.xl*), *.xl*", _
　　　　　　　　　　MultiSelect:=True, Title:="圧縮ファイル選択")
　　If IsArray(FName) = False Then
　　　　Exit Sub
　　Else
　　　 Open ZipFName For Output As #1
　　　 Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
　　　 Close #1
　　　
　　　 Set objShell = New Shell32.Shell
　　　　For i = LBound(FName) To UBound(FName)
　　　　　　If IsBookOpen(FName(i)) = False Then
　　　　　　　'ファイルは必ず閉じた状態で使ってください 'ここで問題が発生することがある
　　　　　　　　objShell.Namespace(ZipFName).CopyHere FName(i)
　　　　　　　　Sleep 500
　　　　　　End If
　　　　Next i
　　End If
End Sub
Function IsBookOpen(ByVal FName As Variant)
Dim myFno As Integer
If Dir(FName) <> "" Then
　myFno = FreeFile
　On Error Resume Next
　Open FName For Binary Lock Read Write As #myFno
　Close #myFno
End If
　If Err.Number = 70 Then
　　IsBookOpen = True
　End If
End Function
'//

この回答へのお礼

ありがとうございます。
また、お礼が非常に遅くなり申し訳ございませんでした。
上記コードで問題なくwin7Excel2007で実行できました。

Print など使用した事のないステートメントや、
アーリーバインディング・レイトバインディングの違い。sleepとwaitの違いについても不勉強でしたので、これも含めて勉強していきたいと思います。

本当にありがとうございました。

お礼日時：2015/08/10 03:01

No.2 回答者： nicotinism 回答日時： 2015/08/04 11:37

こちらでは？

http://scripting.cocolog-nifty.com/blog/2007/11/ …

Windows7 64bit & Office2010 32bit で確認済み。

この回答へのお礼

ありがとうございます。
また、お礼が非常に遅くなり申し訳ございませんでした。

この件だけでなく、これから学んでいきたい事が非常に多く掲載されており、
非常に参考になりました。

本当にありがとうございました。

お礼日時：2015/08/10 03:04

No.1 回答者： usa3usa 回答日時： 2015/08/03 22:55

標準かわかりませんが、私のWin7では、

　右クリック - 送る - 圧縮(ZIP)フォルダー　
でZip圧縮を行う事は可能ですよ。

この回答へのお礼

ありがとうございます。
お礼が非常に遅くなり申し訳ございませんでした。

お礼日時：2015/08/10 03:06