Attribute VB_Name = "AutoExtract1"
Option Explicit


 Sub 自動解凍()

Dim objIns As Inspector

Dim myMail As Object 'MailItemだと会議開催通知がエラーになる
Dim passMail As Object
Dim myPassword() As Variant
Dim cPass As String
Dim f As Integer
Dim next_time As Date

Set objIns = Application.ActiveInspector


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

'添付ファイル有無
If myMail.Attachments.Count > 0 Then
'    MsgBox "This mail has an / some attachement files"
    
        '拡張子が.zi_ であったらメッセージを出す
        If Right(myMail.Attachments(1).FileName, 4) = ".zi_" 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(1).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)


    'プログレスバーを準備
    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)
        
        myExec = myWsh.Run("%ComSpec%  /C cd C:\Program Files\7-Zip & 7z.exe e " & ZIP_PATH & " -y -p" & cPass & " -o" & TGT_PATH & " > " & "D:\out.txt", 0, True)
        
            '一時フォルダにファイルがあり、かつファイルサイズが0出ない場合、解凍できたと判断し修了する
            Dim ext As String
            
            ext = Dir(TGT_PATH & "\*.*")
            
            If ext <> "" Then
                If FileLen(TGT_PATH & "\" & ext) <> 0 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"
                Kill "D:\out.txt"
                Set FSO = Nothing
                
                Set myMail = Nothing
                Set myWsh = Nothing
                
                'プログレスバーを閉じる
                Progress.SelfClose

                
            Exit Sub
                End If
            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"
                Kill "D:\out.txt"
                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
    
    
    
For Each tgtItem In passMail
   
    
    'メール本文を取得
    myBody = tgtItem.Body
    
    '正規表現で検索
    Set myRE = CreateObject("VBScript.RegExp")
        
        With myRE
            .Pattern = "\S[!-~]{4,24}"  '空白、改行等を含まない半角英数字で4〜16桁の文字列を検索
            .IgnoreCase = False
            .Global = True
        End With
        
        
    Set myMatches = myRE.Execute(myBody)
        c = myRE.Execute(myBody).Count
'        MsgBox c
        
        c = c + t

        
        ReDim Preserve passN(c)
        
        For Each myMatch In myMatches
            
            passN(i) = myMatch.Value
        
            i = i + 1
        
        Next myMatch
        
        t = UBound(passN)
        
Next tgtItem
        

Dim passD() As Variant

ReDim passD(t, 1)

For v = 0 To t
    passD(v, 0) = passN(v)
Next v


        
For q = 0 To 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