Excel VBA で既存の圧縮ファイルにパスワードを付加する方法を教えてください

Question

＝＝＝＝＝＝＝＝＝＝＝＝＝
実現したいこと
＝＝＝＝＝＝＝＝＝＝＝＝＝

既存のZIPファイルに任意のパスワードを設定することです
現時点で、以下の二つのことは実現できているのですが、既存のZIPにパスワードを付加する機能を実装したいので方法をご教授ください
恐らく、WinZipのコマンドラインで何かできそうな気がするのですが発見できませんでした。

なお、制約条件は、圧縮ソフトを使う場合にはWinZipを使うことです

＝＝＝＝＝＝＝＝＝＝＝＝＝
現時点で実装できていること
＝＝＝＝＝＝＝＝＝＝＝＝＝
方法１
Scripting.FileSystemObjectのオブジェクトを利用して空のZIPファイルを作成し、Shell.ApplicationのオブジェクトのNamespace.CopyHereで圧縮したいファイルを追加していくこと（パスワードはなし）

方法２
WinZIPのコマンドラインをShellで起動して、ひとつづパスワード付の圧縮ファイルを追加していく方法
Shell ("C:\Program Files\WinZip\WINZIP64.EXE -min -a -s" & Password & " " & Target & " " & Source)

＝＝＝＝＝＝＝＝＝＝＝＝＝
実現したい理由
＝＝＝＝＝＝＝＝＝＝＝＝＝
なぜ既存のZIPファイルにパスワードをかける方法がほしいかというと
方法１ではフォルダ構造を保ちながらフォルダ毎圧縮できるのですが、方法２ではターゲットにフォルダを指定してもフォルダ内のファイルをひとつづつパスワードをつけて圧縮してしまいます。またフォルダが入れ子になっている場合には無視されます。それにこの方法の場合、いくつかフォルダを指定して一つの圧縮ファイルに詰め込む場合、仮にフォルダ内にたまたま同一名称のファイルがあると圧縮過程で上書きされてしまいます。なお、方法１では、フォルダ構造を維持したまま圧縮できます。そのため、方法１で作成した圧縮ファイル（パスワード無）に後からパスワードが付加できると嬉しいと思ったのです。

英語のサイトなど調べたのですがうまく見つかりませんでした
ご教授どうぞよろしくお願いいたします

↓　

papinianus様のアドバイスにより
Shell ("C:\Program Files\WinZip\WINZIP64.EXE -min -a -r -s" & Password & " " & Target & " " & Source)とすることで解決しましたが、以下のようなエラーメッセージが出るようになりました。なお、圧縮時の作業を待つためのWindowsのAPIを利用しています。
圧縮ファイル自体は正しく作成されているので問題はないように見えるのですが、エラーメッセージが出ないほうがきれいなので気になります。
よろしくお願いします。

Action: Add (and replace) files
Include subfolders: yes
Save full path: no
Adding 02POWER WORD.pptx
Adding 03POWER WORD.pptx
Adding Bkup
Adding Bkup\SecurePDFFiles from PPT_01.xlsmThe following file is open by another program. If that program
writes to the file while WinZip is zipping the file, the zipped
file may be corrupt: "P:\My Documents\Macro\パワポのPDF化\SecurePDFFiles from PPT_04.xlsm".
Adding 結果
Total bytes=98371650, Compressed=24560041 -> 75 percent savings.

Comments

[papinianus]

winzipで階層を保って一気にzipにできればいいんですよね？−ｒオプションでは？←winzipってパッケージになってたんですね。多分-rだと思いますが、検証できないので、無視してくださいな。

[taka_]

はいそうです。ヒントをいただいて試しに、Shell ("C:\Program Files\WinZip\WINZIP64.EXE -min -a -r -s" & Pwd & " " & Tgt & " " & So)としたらうまくできました。ありがとうございます。ところでこの処理をソースを変えて連続してループ処理しようと思うのですが、前の圧縮処理が終わっていないのに次の処理が始まって中途半端な圧縮ファイルになるので、Shellの処理が終わるまで待つ命令セットを加えれば完璧な気がします。ありがとうございます。大変助かりました。

[papinianus]

自己解決にしておいてください

[taka_]

ありがとうございます。WindowsAPIを使って処理終了を待つ処理を加えてうまくいっているのですが、毎回必ず以下のエラーが出ます。これをでなくすることは可能でしょうか？エラーメッセージ　WinZip encountered problems during this operation. Would you like to view the detailed results of the last operation showing the specific error endountered?

[papinianus]

そこには、エラーの具体的な内容が書いてないので(詳細なエラーを見たい？としか書いてない)、分かりません。もし詳細なエラーが見られるのであれば、質問に追記してください(ここはデフォルトで閉じられるので)

[taka_]

Save full path: no が具体的なエラーになっています

[papinianus]

エラーではなく出力に見えます。前は出てなかったのでしょうか？

Answer 1

質問に記載した通りのエラーメッセージが出るという状況は解消していないのですが、エラーが出ても作成されたZIPファイルには問題が観察されないので、みなさんの参考までに自己解決結果を載せます

WinZipを使うため、その処理が終了したかどうかの確認処理などの処理が含まれています
インプット情報として、シート名：Zip化のA列にZip化したいファイルのフォルダ名、B列にファイル名、セルF2にZipファイルの保存先、セルF3にZipファイル名、セルF4にパスワードが入力されていることを前提にしています。

Option Explicit

'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
'Shell関数を使って外部ソフトを動かすため、外部ソフトの終了待ちをさせたいために必要なパート
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Declare PtrSafe Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, _
ByVal dwMilliseconds As Long) As Long
Declare PtrSafe Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

'--- API 定数の宣言 ---
Public Const PROCESS_ALL_ACCESS As Long = &H1F0FFF
Public Const INFINITE As Long = &HFFFF

'参照コード
'http://www.memecode.com/docs/winzip.html
'winzip encrypt vba

Public Sub CreateZipPW()

Dim FSO As FileSystemObject
Dim WkR As Range
Dim DestFolderPath
Dim DestFilePath
Dim DestFileName
Dim InpFile
Dim InpFilePath
Dim I As Long
Dim Password


Set FSO = CreateObject("Scripting.FileSystemObject")

'＝＝＝＝＝＝＝＝＝＝＝＝
'　初期情報取得
'＝＝＝＝＝＝＝＝＝＝＝＝

With Sheets("ZIP化")
    
    '連続ZIP処理するファイル、フォルダの情報が格納してあるセルから情報取得　InpFile
    Set WkR = .Range("A1").CurrentRegion
    Set WkR = WkR.Offset(1, 0).Resize(WkR.Rows.Count - 1, WkR.Columns.Count)
    InpFile = WkR.Value
    
    'Zipファイルの保存フォルダの取得
    DestFolderPath = .Range("F2")
    
    'ZIPファイルの保存フォルダが空欄の場合、ダイアログボックスで指定
    If DestFolderPath = "" Then
        DestFolderPath = AddPathSeparator(SetFolder())
        .Range("F2") = DestFolderPath
    Else
        DestFolderPath = AddPathSeparator(DestFolderPath)
    End If
    
    'ZIPファイル名の取得
    DestFileName = .Range("F3")
    If DestFileName = "" Then
        DestFileName = AddZipExtent(FSO.GetBaseName(DestFolderPath))
    Else
        DestFileName = AddZipExtent(DestFileName)
    End If
    
    'ZIPファイルのフルパス
    DestFilePath = DestFolderPath & DestFileName
    
    'ZIPファイルのパスワード
    Password = .Range("F4")
    
End With


'＝＝＝＝＝＝＝＝＝＝＝＝
'　ZIP化処理
'　Zip化がファイルなのか、フォルダなのかで初期処理をしてループ
'＝＝＝＝＝＝＝＝＝＝＝＝

For I = 1 To UBound(InpFile)

    If InpFile(I, 2) = "" Then
        
        InpFilePath = InpFile(I, 1)
    
    Else
        
        InpFilePath = InpFile(I, 1) & "\" & InpFile(I, 2)
    
    End If
    
    Call ZipPW(InpFilePath, DestFilePath, Password)
    
Next I

'ZipFileOrFolder "C:\Test\Files" 'フォルダ圧縮
MsgBox "処理が終了しました。", vbInformation + vbSystemModal

End Sub

Public Sub ZipPW(Source, Target, Password)
Dim Pwd As String
Dim So As String
Dim Tg As String
Dim TaskID As Long
Dim hProc As Long

'http://staff.uob.edu.bh/files/600435156_files/The_Comp_lab_3.pdf

So = Chr$(34) & Source & Chr$(34)
Tg = Chr$(34) & Target & Chr$(34)

If Password = "" Then
    TaskID = Shell("C:\Program Files\WinZip\WINZIP64.EXE -min -a -r " & Tg & " " & So)
Else
    Pwd = Chr$(34) & Password & Chr$(34)
    TaskID = Shell("C:\Program Files\WinZip\WINZIP64.EXE -min -a -r -s" & Pwd & " " & Tg & " " & So)
End If

'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
'圧縮プロセスが終了したか確認
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
'プロセスハンドルの取得
hProc = OpenProcess(PROCESS_ALL_ACCESS, 0, TaskID)
' プロセスハンドルが返されたかを判定
If hProc <> 0 Then
    ' プロセスのシグナル待ち
    Call WaitForSingleObject(hProc, INFINITE)
    ' プロセスクローズ
    CloseHandle hProc
End If

End Sub