パスワード付きZipファイルメールを自動解凍する方法

こんにちは。カナメです。

2020年11月に、日本の内閣府、内閣官房がパスワード付きZipファイルメールを廃止すると発表しました。

とはいえ、現在でも完全になくなっているわけではありません。

私の業界ではいまだにZipファイルメールが飛び交っています。

PPAPと呼ばれるこのメール送信方法ですが、セキュリティ上の利点はあまりないといわれています。

何が大変かというと、このZipファイルメールの添付ファイルを見るためには、

・一度ファイルを保存して、

・拡張子を.zipに変えて（メールの受信セキュリティをくぐりぬけるため、拡張子が「.zi_」のように一文字変えてあるため）

・別メールからパスワードをコピペして解凍しないといけません。

私のデスクトップは一時置きファイルだらけになってしまいました。

そこで、何かいい方法はないかとインターネットで検索したら、

何名かのエンジニアの方々が、この問題に取り組んでいましたので

インターネットの情報を参考に、自分で作ってみることにしました。

できたものは、Outlookに組み込む形のVBAで作成したプログラムです。

例えば、パスワード付きZipファイルとパスワードのメールが届いたら、zipファイル付きのメールを別ウィンドウで開き、プログラムを起動すると・・・

こんな感じでメッセージが出て、

元のメールに解凍されたファイルが自動で添付されます。

環境条件

このプログラムが動く条件は、

・Windows10　64bit であること

・Dドライブがあること

です。

Dドライブがない場合は、Cドライブの容量を一部切り離してDドライブを作ることができます。

（Dドライブ　作成　などで検索すればやり方が出てきます）

必要なフリーソフト

このプログラムは2つのフリーソフトを連携しているため、事前にインストールが必要です

以下のURLからダウンロード可能です。

・７－Zip

圧縮・解凍ソフト 7-Zip (osdn.jp)

・７－Zip.DLL　（個人で製作されているソフトです）

http://akky.xrea.jp/

・今回自作したモジュール（3個） ※以下のリンクからダウンロードできます。

パスワード付zipファイルメール自動解凍VBA

パスワード付zipファイルメール自動解凍VBAのモジュールはこちらからダウンロードできます。 Outlook 2013,2016で動作...

kkz.tokyo

2021-09-17 16:21

7-zipをインストールする

ダウンロードしたexeファイルをダブルクリックしてProgram Fileにインストールします

7zip DLLを配置する

ファイル「7-zip32.dll」を　Cドライブ　→　Windows　→SysWOW64のフォルダ内にコピーします

Outlookにモジュールを組み込む

まずOutlookからメールを1通なんでもいいので別ウィンドウで開きます

タブの部分で右クリック→リボンのユーザー設定を選択

右のウィンドウの「開発」にチェックを入れて、OKを押す

開発タブをクリックして、VisualBasicのボタンをクリックします

VisualBasicEditer画面が開いたら、左上のProjectを右クリック

「ファイルのインポート」をクリック

今回作成したモジュール「AutoExtract1.bas」を選択し、OKを押す

こんな感じでインポートされます

同様の手順で、ファイル「DLL.bas」もインポートします

同様の手順で、ファイル「Progress.frm」もインポートします

※ファイル「Progress.frx」は、インポート作業をしなくても「Progress.frm」をインポートすれば一緒にインポートされます

保存ボタンを押します

マクロの無効化を解除する

Outlookでマクロが無効にされていると動かせませんので、マクロを有効化します。

Outlookの左上「ファイル」タブをクリック

「オプション」をクリック

セキュリティセンターをクリック

「セキュリティセンターの設定」をクリック

マクロの設定をクリック

→すべてのマクロに対して警告を表示する　のラジオボタンを選択

→ウィンドウ右下のOKを押す

マクロ起動ボタンを作る

メールの表示ウィンドウで作成します（受信トレイのウィンドウではありません）

なんでもいいので1通メールを別ウィンドウで開きます。

タブのあたりを右クリック　→　リボンのユーザー設定　をクリック

右ウィンドウで右クリック

新しいタブの追加　をクリック

新しいタブ（ユーザー設定）ができます（右クリック→名前の変更で「新しいタブ」の名前は変更できます）

（ここではとりあえずタブ名を”マクロ”としておきます）

右ウィンドウで「新しいグループ（ユーザー設定）」を選択した状態で

左ウィンドウのコマンドの選択のプルダウンをクリック

「マクロ」を選択する

先程組み込んだマクロ「自動解凍」が出てきますので、クリックして

「追加」ボタンを押す

これでマクロボタンができましたので、OKを押す

メールのウィンドウに新しいタブができて、そこをクリックするとマクロ起動ボタンができています

これで設定は完了です。

一度Outlookを閉じて、再起動します。

使ってみよう

Outlookを立ち上げます

zipファイルが添付されているメールを別ウィンドウで開きます

（このとき、同じ差出人で、メール受信前後1時間以内にパスワードメールが来ていることが前提です）

メールのタブに、先程作成した新しいタブができているはずです

自動解凍のマクロ起動ボタンを押します

最初の1回目だけ、マクロを有効にするか確認するメッセージが出るので

「マクロを有効にする」をクリック

解凍に成功すると「解凍されました」のメッセージが出て、解凍されたファイルが添付ファイルに追加されます

これでもう、めんどくさいパスワード解凍作業から解放されますね！

こういう場合は解凍できない

このプログラムは、残念ながらすべてのzipファイルが解凍できるわけではありません。

パスワードに「”」ダブルコーテーションが入っていると、解凍できません
パスワードが全角だと解凍できません
”パスワードはabcです”のようにパスワードの文字列が本文につなげられている場合は解凍できません（ただし全角の”「”　、”【”　のカギかっこでパスワードが区切られている場合は解凍できます
パスワードメールの差出人がzipファイルのメールの差出人と違うと、解凍できません

私の力では今のところこれ以上のコードが書けません・・・

こうしたら解けるようになるよ！という達人の方がいらっしゃいましたら、ぜひ教えてください。

進捗バーが最後まで行って「解凍できませんでした」というメッセージが出たら

残念ですが手動で解凍するしかありません

パスワードの候補が多すぎると時間がかかるときがあります。

その時は「中止」ボタンを押すと中断できます。

どうやってパスワードを解除しているの？

今回作成したプログラムがどういう動きをしているかといいますと、こんな感じです

１．メールの添付ファイルが、拡張子が “.zip” “.ZIP” “.zi_” “.zi”のいずれかであるかどうか確認する

２．zipファイルが見つかったら、Dドライブに一時的に保存する

３．メールの受信時間の前後1時間に、同じ差出人のメールがあるか確認する

４．同じ差出人のメールが見つかったら、メールの本文の中に、”パスワード” “Password” “password” “PASS”　の文字があるか探す

５．もし見つかったら、その行に「,【　カギかっこがあるか探して、かっこ内の文字列をパスワード候補にする

６．見つからなかったら、本文内の文字列で4～24文字の半角英数字の文字列をランダムに抽出する

７．複数のパスワード候補を、パスワードが長くて、複雑なものから順番にパスワードを入れて、解凍を試みる

８．解凍に成功したらファイルをメールに添付する

最も難しいのは、パスワードを解凍するのにかかる時間を短縮にするために、パスワードの複雑なものから順番に解凍を試みるところでした。

これはインターネットにYoshinari Nomuraさんという方が「パスワードは別途お送りします」をなんとかしたい

というブログで書かれており、パスワード別送添付メールの問題点と受信側での対策についてという論文を出されていましたので、こちらのロジックを使用させていただきました。

「glima」という自動解凍ソフトをGitHubで発表されていましたが、私はRubyが理解できなかったので、仕事で使うOutlookで何とか自動解凍ができないかと思い、今回VBAで作成しました。

その他、Outlook　VBAの自動解凍については、タナイさんのブログthanaism.comの

「パスワード別送メールのzipを自動で解凍したい」のエントリを参考にさせていただきました。

プログレスバーの作成は　エクセルの神髄　第26回.プログレスバーを自作する　から作成

当初はコマンドラインで7-zipを動かしていたのですが、仕様なのか3割くらい（パスワードが正しくても）解凍できないzipファイルがあり、困り果てていたところ、

7-zipでDLLを作成されていたAkkyWareHOUSE にたどり着き、hatenachips というサイトでDLLを使った7-zipの動かし方を使うことで、解決することができました。

いやあすごい人がいるもんですね（私はプログラマではなく、素人です）

2023年7月更新

Office365（Microsoft365）の方はこちらを使ってください

それでは、また。

ソースコードはこちら

1.AutoExtract1.bas



Option Explicit

Sub 自動解凍() 'パスワード付zipメール自動解凍（メインモジュール）

Dim objIns As Inspector

Dim myMail As Object
Dim passMail As Object
Dim myPassword() As Variant
Dim cPass As String
Dim f As Integer
Dim next_time As Date
Dim ii As Integer
Dim ath As Integer
Dim athf As Integer

Set objIns = Application.ActiveInspector

'メールIDを取得
Set myMail = objIns.CurrentItem

'添付ファイル有無
If myMail.Attachments.Count > 0 Then
    
    'ファイルの添付がいくつあるか確認
    ath = myMail.Attachments.Count
    
    '何番目のファイルがzipファイルか確認
    For ii = 1 To ath
        '拡張子が.zi_,.zip,.zi_p であったらメッセージを出す
        If Right(myMail.Attachments(ii).FileName, 4) = ".zi_" Or _
           Right(myMail.Attachments(ii).FileName, 4) = ".zip" Or _
           Right(myMail.Attachments(ii).FileName, 5) = ".ZIP" Or _
           Right(myMail.Attachments(ii).FileName, 3) = ".zi" Then
        athf = ii
        End If
    Next
    
        If athf <> 0 Then
        'パスワードの記載されているメールを探す→Function findPassMailへ
        Set passMail = findPassMail(myMail)
        
            If passMail Is Nothing Or passMail.Count = 0 Then
                    MsgBox "パスワードメールが見つかりません"
                    Exit Sub
            End If
        'パスワード候補の配列を入れる→Function getRegExpへ
        myPassword() = getRegExp(passMail)
         
        'もしDドライブにtmp000フォルダがあったら削除する (エラー回避)
            Dim wt As String
            wt = Dir("D:\tmp000", vbDirectory)
            If wt <> "" Then
                Dim FSO As Object
                Set FSO = CreateObject("Scripting.FileSystemObject")
                FSO.DeleteFolder "D:\tmp000"
            End If
        
        'Dドライブに一時フォルダ作成
        CreateObject("Scripting.FilesystemObject").createFolder "D:\tmp000"
        
        '7-Zipを動かす
        Const ZIP_PATH As String = "D:\tmp000.zip"
        Const TGT_PATH As String = "D:\tmp000\"
        Const EXE_7ZIP As String = "C:\Program Files\7-Zip\7z.exe"
        
        myMail.Attachments(athf).SaveAsFile ZIP_PATH
        
        Dim myWsh As Object
        
        Set myWsh = CreateObject("WScript.Shell")
        
        Dim myExec As String
        Dim myCmd As String
        Dim result As String
        Dim ss As String
        Dim flg As Integer
        Dim C As Integer
                        
        If Dir(EXE_7ZIP) <> "" Then
            myCmd = """ &  EXE_7ZIP & """
        Else
            Exit Sub
        End If
        
        'パスワード候補を一つずつ入れる
        C = UBound(myPassword)
        
        '1個もパスワードが抽出できなかった場合、終了する
        If C = 0 Then
        MsgBox "パスワードが見つかりませんでした"
        Exit Sub
        End If
        

    'プログレスバーを準備
    Dim Progress As New Progress
    
    With Progress
        .MaxValue = C
        .BackColor = RGB(222, 222, 222)
        .Interactive = True
        .ShowModeless "開始します"
    End With
    

    
        On Error GoTo myError: '中断したらエラーを回避して終了

        For f = 0 To C
        'プログレスバーの表記
        
        Progress.Value f, f & "件試行中‥/パスワード候補" & Progress.MaxValue & "件中"

        cPass = myPassword(f, 0)
        
        If ExtractZIP(TGT_PATH, ZIP_PATH, cPass) Then
        
    
        End If
        
            '一時フォルダにファイルがあり、かつファイルサイズが0でない場合、解凍できたと判断し修了する
            Dim ext As String
            
            ext = Dir(TGT_PATH & "\*.*")
            
            If ext = "" Then 'ファイルが無かったら、フォルダがないか調べる　解凍したらフォルダだった場合
                        
             With CreateObject("Scripting.FileSystemObject")
                    If .GetFolder(TGT_PATH).SubFolders.Count <> 0 Then
        
                            Dim fd As Object
                            Dim exb As String
                            Dim FlgT As Boolean
        
                            'フォルダ内のファイルをTmpフォルダにコピー
                            For Each fd In .GetFolder(TGT_PATH).SubFolders
        
                             exb = Dir(fd.Path & "\*.*")
                            Do While exb <> ""
                                 If FileLen(fd.Path & "\" & exb) <> 0 Then 'ファイルサイズが0じゃないファイルがあったらフラグをTrue
                                    FlgT = True
                                     .CopyFile fd.Path & "\" & exb, TGT_PATH & exb 'Tmpフォルダにファイルをコピーする
                                 End If
                                 exb = Dir()
                             Loop
        
                            Next fd
                       
                      End If
                End With
           Else 'ファイルがあった場合
            
            
                If FileLen(TGT_PATH & "\" & ext) <> 0 Then 'ファイルサイズが0じゃないファイルがあったらフラグをTrue
                    FlgT = True
                End If

           End If
           
           
           If FlgT = True Then
        

            MsgBox "解凍できました"
            
            '作成中　元のメールに、解凍したファイルを添付する（元のメールは削除しない　念のため）
            Dim tgtFilename As String
            
            tgtFilename = Dir(TGT_PATH & "\*.*", vbNormal)
            
            Do While tgtFilename <> ""
                  Name TGT_PATH & "\" & tgtFilename As TGT_PATH & "\" & tgtFilename
                  myMail.Attachments.Add TGT_PATH & "\" & tgtFilename
                tgtFilename = Dir()
            Loop
            
            'フラグを付ける
            myMail.FlagStatus = 1
            myMail.FlagRequest = "自動解凍しました"
            myMail.Save
            
            '　Dドライブの一時フォルダ、ファイルを削除する
                'tmpフォルダ削除
                Set FSO = CreateObject("Scripting.FileSystemObject")
                FSO.DeleteFolder "D:\tmp000"
                Kill "D:\tmp000.zip"
                Set FSO = Nothing
                
                Set myMail = Nothing
                Set myWsh = Nothing
                
                'プログレスバーを閉じる
                Progress.SelfClose
            Exit Sub
                End If
            
        
        '次のパスワードを試す
        Next f
        flg = 1
        End If
End If

If flg = 1 Then
            '　Dドライブの一時フォルダ、ファイルを削除する
                'tmpフォルダ削除
                
                Set FSO = CreateObject("Scripting.FileSystemObject")
                FSO.DeleteFolder "D:\tmp000"
                Kill "D:\tmp000.zip"
                Set FSO = Nothing
                
                'プログレスバーを閉じる
                Progress.SelfClose

MsgBox "解凍できませんでした"
            'フラグを付ける
            myMail.FlagStatus = 2
            myMail.FlagRequest = "解凍できませんでした"
            myMail.Save
End If

myError:

Set myMail = Nothing
Set myWsh = Nothing

End Sub

'パスワードのメールを特定する
Private Function findPassMail(ByVal myMail) As Items


Dim myItems As Items
Dim tgtItem As Object
Dim myFolder As Folder
Dim bb As Items
Dim cd As Items
Dim sdr As String
Dim canD As Items


'対象メールの差出人を取得
'sdr = myMail.SenderEmailAddress

'メールの親フォルダを特定
Set myFolder = myMail.Parent
Set myItems = myFolder.Items

'受信フォルダを絞り込み
Set bb = minimizeSearchRange(myMail, myItems)

Set findPassMail = bb

End Function

'前後1時間のメールから送信者が同じメールを検索する
Private Function minimizeSearchRange(ByVal myMail, myItems) As Items

    Dim myDateFrom As Date
    Dim myDateTo As Date
    Dim strFilter As String
    Dim Str As String
    Dim zzz As Items
        
   
    myDateFrom = DateAdd("h", -1, myMail.ReceivedTime)
    myDateTo = DateAdd("h", 1, myMail.ReceivedTime)
     strFilter = "[SenderEmailAddress] = " & "'" & myMail.SenderEmailAddress & "'" & " AND [受信日時] >= '" & Format(myDateFrom, "yyyy/mm/dd hh:mm") & "' AND [受信日時] < '" & Format(myDateTo, "yyyy/mm/dd hh:mm") & "'"
   
    Set zzz = myItems.Restrict(strFilter)
    
    '添付ファイルのついているメールは除く
     strFilter = "@SQL=urn:schemas:httpmail:hasattachment= False "
    
    Set minimizeSearchRange = zzz.Restrict(strFilter)
    
 
End Function
'
'パスワードメールの本文からパスワード候補を検索
Private Function getRegExp(ByVal passMail As Object) As Variant()

    Dim myBody As String
    Dim myRE As Object
    Dim myMatches As Object
    Dim myMatch As Object
    Dim C As Integer
    Dim passN() As Variant 'パスワード候補の配列
    Dim i As Integer
    Dim ln As Integer
    Dim g As String
    Dim h As String
    Dim entP As Long
    Dim b As Integer
    Dim lg As Long
    Dim t As Long
    Dim tgtItem As MailItem
    Dim q As Integer
    Dim ps As String
    Dim v As Integer
    Dim passF() As Variant 'パスワード候補の配列2
    
    
    
For Each tgtItem In passMail
   
    
    'メール本文を取得
    myBody = tgtItem.Body
    
    
'パスワード候補文字列切り出し
'---------------------------------------------------

Dim lines() As String
Dim ww As Integer
Dim cn As Integer
Dim pw As String
Dim L As Integer
Dim Psc As Integer
Dim ed As Integer
Dim mojs As Integer
Dim lnn As Integer
Dim lstr As String



'本文を1行ずつ配列に入れる
lines = Split(myBody, vbCrLf)

'パスワード,もしくはPassword,もしくはpassword　を含む行を特定する
For ww = 0 To UBound(lines)

If InStr(lines(ww), "パスワード") <> 0 Or _
   InStr(lines(ww), "Password") <> 0 Or _
   InStr(lines(ww), "PASS") <> 0 Or _
   InStr(lines(ww), "password") <> 0 Then
   
   
   
   ''パスワード'という文字以降の文字列を対象にする
   If InStr(lines(ww), "パスワード") <> 0 Then
    lnn = InStr(lines(ww), "パスワード")
   ElseIf InStr(lines(ww), "Password") <> 0 Then
    lnn = InStr(lines(ww), "Password")
   ElseIf InStr(lines(ww), "password") <> 0 Then
    lnn = InStr(lines(ww), "password")
   ElseIf InStr(lines(ww), "PASS") <> 0 Then
    lnn = InStr(lines(ww), "PASS")

   End If
   
   lstr = Mid(lines(ww), lnn)
   
   
   
   'パスワードとの区切り":"を特定
   cn = InStr(lstr, ":")
   
   '見つからなかったら全角の：も探す
    If cn = 0 Then
        cn = InStr(lstr, "：")
    End If
    
    'それでも見つからなかったら「カッコを探す　かっこの場合は終わりの」カッコとじを除く
    If cn = 0 Then
        cn = InStr(lstr, "「")
        
            If cn <> 0 Then
                ed = InStr(lstr, "」")
                mojs = ed - cn - 1
            End If
        
    End If
    
    'それでも見つからなかったら【カッコを探す　かっこの場合は終わりの】カッコとじを除く
    If cn = 0 Then
        cn = InStr(lstr, "【")
        
            If cn <> 0 Then
                ed = InStr(lstr, "】")
                mojs = ed - cn - 1
            End If
        
    End If

   
   '：以降の文字列をパスワード候補とする
   If mojs <> 0 Then
        pw = Mid(lstr, cn + 1, mojs)
        Else
        pw = Mid(lstr, cn + 1)
   End If
   
   
   '空白を削除
   pw = Replace(pw, " ", "")
   pw = Replace(pw, "　", "")
   
   'nullの場合は適当な文字を入れる(DLLでパスワード入力ダイアログを出さないため）
   If pw = "" Then
   pw = "n"
   End If
   
   'パスワード候補のｶｳﾝﾀ
   L = L + 1
   
   '配列に入れる
   ReDim Preserve passN(Psc + L)
   passN(Psc + L) = pw
   
End If

mojs = 0 '文字数ﾘｾｯﾄ

Next ww

'カウンタの保存
Psc = Psc + L
    
'---------------------------------------------------
    
    
'他のパスワード候補の切り出し

    '正規表現で検索
    Set myRE = CreateObject("VBScript.RegExp")
        
        With myRE
            .Pattern = "\S[!-~]{3,24}"  '空白、改行等を含まない半角英数字で4〜24桁の文字列を検索
            .IgnoreCase = False
            .Global = True
        End With
        
    Set myMatches = myRE.Execute(myBody)
        C = myRE.Execute(myBody).Count
'        MsgBox c
        
        C = C + t
        
        ReDim Preserve passF(C)
        
        passF(0) = "n" 'Empty値を入れないように適当な値を入れる(DLLでパスワード入力ダイアログを出さないため）
        
        For Each myMatch In myMatches
        
                    
            
            '配列に入れる
            passF(i + t + 1) = myMatch.Value
            
            passF(i + t + 1) = Replace(passF(i + t + 1), "　", "") '全角空白があったら削除
        
            i = i + 1
        
        Next myMatch
        
        t = UBound(passF)
        
        L = 0
        i = 0
        
Next tgtItem
        

'2次元配列を作成し、データを移行　passNとpassF →passD
Dim passD() As Variant
Dim kz As Integer


ReDim passD(Psc + t, 1)

passD(0, 0) = "n" 'Empty値を入れないように適当な値を入れる(DLLでパスワード入力ダイアログを出さないため）


'パスワード候補2を入れる
'本文からパスワード候補として切り出した文字列は正しいパスワードである確率が高いのでエントロピーを高スコアにする
For v = 1 To Psc
    passD(v, 0) = passN(v)
    passD(v, 1) = 100
Next v

'パスワード候補1を入れる
For v = Psc + 1 To Psc + t
    passD(v, 0) = passF(kz + 1)
    kz = kz + 1
Next v

'それ以外の文字列はエントロピーを計算する
For q = Psc + 1 To Psc + t
    ps = passD(q, 0)
    
            '文字列のエントロピー計算
            ln = Len(ps) 'パスワード候補の文字長さ
            
            '対数で取得
            lg = Log(ln + 1) / Log(2)
            
            '隣り合う文字が違っているほどエントロピーは高いとする
            For b = 1 To ln
                g = Mid(ps, b, 1)
                    If g Like "[a-z]" Then
                        g = "a"
                        ElseIf g Like "[A-Z]" Then
                        g = "A"
                        ElseIf g Like "[0-9]" Then
                        g = "1"
                        Else
                        g = "other"
                    End If
                
                h = Mid(ps, b + 1, 1)
                    If h Like "[a-z]" Then
                        h = "a"
                        ElseIf h Like "[A-Z]" Then
                        h = "A"
                        ElseIf h Like "[0-9]" Then
                        h = "1"
                        Else
                        h = "other"
                    End If
                    
                If g <> h Then
                entP = entP + 1
                End If
                
            Next b
            '計算結果を配列2次元目に入れる
            entP = entP + lg
            passD(q, 1) = entP
            entP = 0
            
        Next q
        
'エントロピーの高い順に配列をソート（バブルソート）
Dim vSwap
Dim m As Integer
Dim j As Integer
Dim k As Integer

For m = LBound(passD, 1) To UBound(passD, 1)

    For j = LBound(passD) To UBound(passD) - 1
        
        If passD(j, 1) < passD(j + 1, 1) Then
                
            For k = LBound(passD, 2) To UBound(passD, 2)
            
                vSwap = passD(j, k)
                
                passD(j, k) = passD(j + 1, k)
                passD(j + 1, k) = vSwap
            
            Next k
        End If
    Next j
Next m
        
        '戻り値（2次元配列）を入れる
        getRegExp = passD()
        
        
Set myRE = Nothing
Set myMatches = Nothing

        
End Function

2.DLL.bas




Option Explicit
 'パスワード付zipメール自動解凍（DLL用モジュール）
Private Declare Function SevenZip Lib "7-zip32.dll" ( _
    ByVal hWnd As Long, _
    ByVal szCmdLine As String, _
    ByVal szOutput As String, _
    ByVal dwSize As Long) As Long
 
 
'ZIPファイルを解凍
'引数 sDstPath：解凍先のフォルダーのパス
'     sZIPFile：ZIPファイルのパス
'     sPassWord：パスワード　省略可
'返り値　成功したら True、失敗したらFalse
Public Function ExtractZIP( _
    sDstPath As String, sZIPFile As String, Optional sPassWord As String = "") As Boolean
Dim sCmd As String
    sCmd = "X -hide -aoa "
    If sPassWord <> "" Then sCmd = sCmd & "-P" & sPassWord & " "
    sCmd = sCmd & Q2(sZIPFile) & " -o" & Q2(sDstPath)
    ExtractZIP = DoSevenZip(sCmd) = 0
End Function
 
Private Function DoSevenZip(sCmd As String) As Long
Dim sRet As String * 1024
    DoSevenZip = SevenZip(0, sCmd, sRet, 1024)
'    If DoSevenZip <> 0 Then MsgBox (Left(sRet, InStr(sRet, vbNullChar) - 1))
End Function
 
Public Function Q2(ByVal Text As String) As String
    Q2 = """" & Replace(Text, """", """""") & """"
End Function

3.Progress.frm




Option Explicit
'パスワード付zipメール自動解凍（プログレスバー用フォーム）

Public isCancel As Boolean '中断時にTrueにする

Private pProgressBar As MSForms.Label 'ラベル：動的追加

Private pMaxValue As Long 'プログレスバー最大値
Private pBarColor As Long 'プログレスバー色
Private pCurValue As Double 'プログレスバー現在値

Private pInteractive As Long '割り込み

'最大値プロパティ
Public Property Let MaxValue(aMaxValue As Long)
    pMaxValue = aMaxValue
End Property

Public Property Get MaxValue() As Long
    MaxValue = pMaxValue
End Property

'プログレスバー色プロパティ
Public Property Let BarColor(aBarColor As Long)
    pBarColor = aBarColor
End Property

'割り込み拒否プロパティ
Public Property Let Interactive(aInteractive As Boolean)
    pInteractive = aInteractive
End Property

'フォーム表示入り口
Public Sub ShowModeless(Optional ByVal strTitle As String = "")
    'ラベルコントロール追加
    Set pProgressBar = Me.FrameProgress.Controls.Add("Forms.Label.1", "lblProgress")
        If pBarColor = 0 Then
            pBarColor = RGB(0, 0, 128)
            pProgressBar.Width = 0
            pProgressBar.Height = Me.FrameProgress.Height
            pProgressBar.BackColor = pBarColor
        End If
        'プログレスバーの背景をへこます
        Me.FrameProgress.SpecialEffect = fmSpecialEffectSunken
        
        '割り込み拒否の設定
        If pInteractive = False Then
            Me.Enabled = False
'            Application.Interactive = False
'            Application.EnableCancelKey = xlDisabled
        End If
        
        'フォームをモードレスで表示
        Me.Caption = ""
        Me.Show vbModeless
        
        
End Sub

'プログレス進捗：指定値
Public Sub Value(ByVal aValue As Double, Optional ByVal strTitle As String = "")

    'プログレスバー値変更
    pCurValue = aValue
    
    '最大値判定
    If pCurValue > pMaxValue Then
        pCurValue = pMaxValue
    End If
    
    'プログレスバー描画
    pProgressBar.Width = pCurValue * Me.FrameProgress.Width / pMaxValue
        If Me.Caption <> strTitle Then
            Me.Caption = strTitle
        End If
        
    DoEvents
End Sub

'フォーム終了
Public Sub SelfClose()
    Unload Me
End Sub

'中止ボタン
Private Sub CommandButton1_Click()

If MsgBox("処理を中断しますか?", vbYesNo, "中断確認") = vbYes Then
    Unload Me
End If

End Sub


'正規終了以外をキャンセル
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = vbFormControlMenu Then
        If pInteractive Then
            If MsgBox("処理を中断しますか?", vbYesNo, "中断確認") = vbYes Then
                isCancel = True
            Else
                Cancel = True
            End If
        Else
            Cancel = True
        End If
    End If
End Sub

'フォーム終了時に割り込み拒否を戻す
Private Sub UserForm_Terminate()
    If pInteractive = False Then

    End If
      
End Sub