zip形式で圧縮する。（CopyHereメソッド）
VBAを利用してzip形式でファイルを圧縮するにはCopyHereメソッド利用することでzipファイルを作成することができます。
FileSystemObjectのCreateTextFileで空のzipファイルを作成した後にCopyHere メソッドを利用してそのzipファイルに指定したフォルダ、ファイルをコピーしてzipファイルを作成（圧縮）させます。
ファイルの圧縮中に次のファイルのコピーや処理を終了させないために、CopyHere メソッドの利用後に排他制御処理を付けています。この処理がないとファイルの読み取りエラーなどが発生し正常にzipファイルの作成ができなくなります。
なお、このCopyHereメソッドを利用したzipファイルの作成は現在Microsoftの公式サポートで非推奨の方法となっています。
「CopyHere メソッドから Zip ファイルを処理することはできません」
下記のサンプルコードではシートに記載された複数のフォルダ、ファイルに対して圧縮処理を実行しています。
●指定した複数のファイルをzipに圧縮
'*****************************************************************
' zip圧縮処理
'*****************************************************************
Sub makeZip()
'ZIPファイルのパスを設定
Dim sZipFile As Variant
sZipFile = "C:\VBA\ZipTest.zip"
'FileSystemObjectの作成
Dim oFso As Object
Set oFso = CreateObject("Scripting.FileSystemObject")
'ファイルの存在確認
If chkExistsFile(sZipFile) Then
Dim lRtn As Long
lRtn = MsgBox("同名のZIPファイルが既に存在してます。" & vbCrLf & _
"削除して処理を継続しますか？", vbYesNo)
Select Case lRtn
Case 6 'Yes
Call oFso.DeleteFile(sZipFile)
Case 7 'No
Exit Sub
End Select
End If
'zipファイルの作成
With oFso.CreateTextFile(sZipFile, True)
.Write "PK" & Chr(5) & Chr(6) & String(18, 0)
.Close
End With
'Shell.Applicationオブジェクトの作成
Dim oShell As Object
Set oShell = CreateObject("Shell.Application")
Dim sTarget As String
Dim i As Long: i = 1
'圧縮対象のファイルパスを取得と圧縮
Do While True
'ファイルパスを取得
sTarget = Trim(Sheets("Sheet1").Cells(i, 1).Value)
'対象がなくなればループを抜ける
If sTarget = "" Then: Exit Do
'ZIPに格納
oShell.Namespace(sZipFile).CopyHere (sTarget)
'圧縮中のZipファイルの排他制御チェック(排他中はループ処理を継続)
Do Until chkFileLock(sZipFile): Loop
i = i + 1
Loop
Set oFso = Nothing
Set oShell = Nothing
MsgBox "終了"
End Sub
'*****************************************************************
' ファイルの存在確認
'-----------------------------------------------------------------
' 第１引数：確認したいファイルのパス
'-----------------------------------------------------------------
' 戻り値 ：確認結果（True:ファイルあり、False:ファイルなし）
'*****************************************************************
Function chkExistsFile(getFilePath) As Boolean
'FileSystemObjectの作成
Dim oFso As Object
Set oFso = CreateObject("Scripting.FileSystemObject")
'ファイルの存在確認
If oFso.FileExists(getFilePath) Then
chkExistsFile = True
End If
End Function
'*****************************************************************
' 排他制御チェック
'-----------------------------------------------------------------
' 第１引数：確認したいファイルのパス
'-----------------------------------------------------------------
'*****************************************************************
Function chkFileLock(getFilePath) As Boolean
On Error Resume Next
'100ミリ秒待機
Application.Wait [Now()] + 0.1 / 86400
'FileSystemObjectの作成
Dim oFso As Object
Set oFso = CreateObject("Scripting.FileSystemObject")
'ファイルを開けるか確認
Dim iomode: iomode = 8 'Appendingモード
oFso.OpenTextFile(getFilePath, iomode, False).Close
'排他制御状態の場合はエラー
If Err.Number = 0 Then
chkFileLock = True
End If
End Function
■実行結果
