[[20221202095302]]　『複数のファイル(イエローフォルダ)にユニークパス』（パック）　ページの最後に飛ぶ

『複数のファイル(イエローフォルダ)にユニークパスワードを設定する方法』（パック）

下記のコードで

Aセル　Bセル

1.pdf asfty
2.pdf rthui
3.pdf certy

現在格納ファイルの中身

実行前
1.pdf
2.pdf
3.pdf
合計3ファイル

実行後
1.pdf
2.pdf
3.pdf
1.zip（パスワード付）
2.zip（パスワード付）
3.zip（パスワード付）
合計6ファイル

pdf→3ファイル
zipファイル→3ファイル（パスワード付与付）
出来るのですが
pdfに直接パスワードをかけるのではなく
(イエローフォルダ)に直接パスワードをかけたいのですが
フリーソフトを検索してもみつかりません。
出来れば7zipに対応している
暗号化方式　AES-256で対応したいのですが
アドバイスいただけたら助かります。

↓

希望格納ファイルの中身

実行前
1（イエローフォルダ）
2（イエローフォルダ）
3（イエローフォルダ）
合計3ファイル

Aセル　Bセル

1 　　asfty
2 　　rthui
3 　　certy

実行後
1（イエローフォルダ）
2（イエローフォルダ）
3（イエローフォルダ）
1.zip（パスワード付）
2.zip（パスワード付）
3.zip（パスワード付）
合計6ファイル

Option Explicit

 Public Const zipCom = "C:\Program Files\7-Zip\7z.exe"
 Public wsh
 Public fso As Scripting.FileSystemObject

 Sub MakeZIPFiles()
    Dim srcWS As Worksheet
    Set srcWS = ActiveSheet

    Set wsh = CreateObject("WScript.Shell")
    Set fso = CreateObject("Scripting.FileSystemObject")

    Dim lastRow
    lastRow = srcWS.Cells(Rows.Count, "A").End(xlUp).Row

    Dim r
    Dim srcPath
    For r = 1 To lastRow
        srcPath = ThisWorkbook.Path & "\" & srcWS.Cells(r, "A").Value
        makeZipFile srcPath, srcWS.Cells(r, "B").Value
    Next
    MsgBox "処理が完了しました。"
End Sub

Sub makeZipFile(srcPath, passWord)

    If fso.FileExists(srcPath) = False Then
        If MsgBox(srcPath & "がありません。" & vbNewLine & "処理を続けますか?", vbYesNo) = vbNo Then End
        Exit Sub
    End If

    If passWord = "" Then
        If MsgBox(fso.GetFile(srcPath).Name & "のパスワードがありません。" & vbNewLine & "処理を続けますか?", vbYesNo) = vbNo Then End
        Exit Sub
    End If

    Dim com
    com = """" & zipCom & """ a -y -p" & passWord & " """ & Replace(srcPath, fso.GetExtensionName(srcPath), "zip") & """ """ & srcPath & """"
    wsh.Run com, 0, True
 End Sub

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

＞＞フリーソフトを検索してもみつかりません。
ひばら　さん　の
アタッシュケース
は、試されましたですか。＾＾
他の事は？？？ｗ、私の理解を高く超えています。
ごめん下さいませ。でわ、お知らせまで。m(__)m
（隠居Z） 2022/12/02(金) 10:23:23

 Sub makeZipFile は FileExistsとかGetFileとか、ファイルにしか対応してないので、
 フォルダに対応するようにすればいいのでは？
（´・ω・`） 2022/12/02(金) 10:29:43

（´・ω・`）様
返信ありがとうございます。
＞フォルダに対応するようにすればいいのでは？
フォルダに対応にするために
考慮しているのですが
現状分からなくで困ってます。
（パック） 2022/12/02(金) 10:46:39

（隠居Z）様
ご連絡ありがとうございます。
別件でアタッシュケースは使用してますが
大量のユニークキーを設定できるか調べてみますが
現状方法が分かりません。
（パック） 2022/12/02(金) 10:48:55

 テスtしてないですけど、雰囲気だけ見てください

 Sub makeZipFile(srcPath, passWord)
    If FSO.FolderExists(srcPath) = False Then
        If MsgBox(srcPath & "がありません。" & vbNewLine & "処理を続けますか?", vbYesNo) = vbNo Then End
        Exit Sub
    End If
    If passWord = "" Then
        If MsgBox(FSO.GetFolder(srcPath).Name & "のパスワードがありません。" & vbNewLine & "処理を続けますか?", vbYesNo) = vbNo Then End
        Exit Sub
    End If
    Dim com
    com = """" & zipCom & """ a -y -p" & passWord & " """ & srcPath & "zip" & """ """ & srcPath & """"
    wsh.Run com, 0, True
 End Sub
（´・ω・`） 2022/12/02(金) 11:09:17

助かります。参考にさせて頂きます。どうもありがとうございました。
（パック） 2022/12/02(金) 18:14:07

コメント返信：

[ 一覧(最新更新順) ]

[[20221202095302]] 『複数のファイル(イエローフォルダ)にユニークパス』（パック） ページの最後に飛ぶ

[[20221202095302]]　『複数のファイル(イエローフォルダ)にユニークパス』（パック）　ページの最後に飛ぶ