マクロ(VBA)でファイルをzip化して添付する方法(outlook)

以前公開したこの記事が意外と人気で、どういった検索ワードでこの記事に辿り着いているのか調べた時に、結構「vba outlook zip」というワードがあったので、結構需要があるのかなと思い、この記事を作成しています。

今回は、ファイルをzip化してメールに自動で添付する方法をご紹介します。

最初に断っておきますが、今回紹介するのはzip化するだけです。

パスワードの設定は諸々大変そう＆会社のパソコンでは実現が難しそうだった（アプリのインストール？）ため、今回は紹介ありません。その点はご了承ください。

このコードの使用は自己責任でお願いします。

マクロでzip化する前の準備

マクロでファイルのzip化をする場合、少しだけ準備が必要です。

それはライブラリの追加。

20秒で終わるので安心を。

ツール→参照設定を選択

windows Script Host Object Modelを選択

これだけで準備は完了です。

今回紹介するコード全文

今回は以前紹介したマクロを使ってメールを自動送信する方法のコードをベースにしています。

その記事をまだ確認されていない人はこちらの記事から確認をお願いします。

Sub Outlook_zip()

    Dim oApp
    Dim Wm_ITEM
    Dim Wm_TO
    Set oApp = GetObject(, "Outlook.Application")
    
    ''↑↑ガン無視↑↑
    
    Dim folder As String
    Dim FileName As String
    Dim row As Long
    Dim shname As String
    
    row = 2
    shname = "メール _いっぱいver"

Do Until row = 5
       
        '★★メール画面を開く
        Set Wm_ITEM = oApp.CreateItem(0)
        Wm_TO = ""
        WS_OutLk = ""
       
    If ThisWorkbook.Sheets(shname).Cells(row, 1) <> "" Then
        
        '★★宛先、CC、件名、本文を入力してるだけ★★
        
        Wm_ITEM.To = ThisWorkbook.Sheets(shname).Cells(row, 5)        '宛先
        Wm_ITEM.CC = ThisWorkbook.Sheets(shname).Cells(row, 6)        'CC
        Wm_ITEM.Subject = ThisWorkbook.Sheets(shname).Cells(row, 7)   '件名
        Wm_ITEM.Body = ThisWorkbook.Sheets(shname).Cells(row, 3) & _
                       ThisWorkbook.Sheets(shname).Cells(row, 4)      '社名+宛先名
        Wm_ITEM.Body = Wm_ITEM.Body _
                       & vbCrLf _
                       & ThisWorkbook.Sheets(shname).Cells(row, 8)    '社名+宛先名+本文
        
        '★★ファイル添付★★
    Dim inp As String
    Dim msg As String
    Dim Path       As String
    Dim Zippath    As String
    Dim Result     As Boolean
        
        folder = ThisWorkbook.Sheets(shname).Cells(row, 9).Value      '添付したいファイルの場所
        FileName = ThisWorkbook.Sheets(shname).Cells(row, 10).Value     '添付したいファイル名
        Path = folder & "\" & FileName
        
        msg = "zip化した後の名前を入力（拡張子なし）" & vbCrLf & _
          "zip前⇒" & FileName
        inp = InputBox(msg)
   
        Zippath = folder & "\" & inp & ".zip"
        Result = MakeZip(Path, Zippath)
        
        Wm_ITEM.Attachments.Add Zippath                 'ファイル添付
        Wm_ITEM.Display                                               '.displayで　表示
       
        '★★メール保存or送信★★慣れるまでは保存推奨！！
        Wm_ITEM.Save        '.Saveで保存下書きへ
'       Wm_ITEM.Send        '.Sendで送信※コメントを外すと送信されます

    End If
    
    row = row + 1
    
Loop


MsgBox "かんりょ"

End Sub

Sub Outlook_zip()

Dim oApp

Dim Wm_ITEM

Dim Wm_TO

Set oApp = GetObject(, "Outlook.Application")

''↑↑ガン無視↑↑

Dim folder As String

Dim FileName As String

Dim row As Long

Dim shname As String

row = 2

shname = "メール _いっぱいver"

Do Until row = 5

'★★メール画面を開く

Set Wm_ITEM = oApp.CreateItem(0)

Wm_TO = ""

WS_OutLk = ""

If ThisWorkbook.Sheets(shname).Cells(row, 1) <> "" Then

'★★宛先、CC、件名、本文を入力してるだけ★★

Wm_ITEM.To = ThisWorkbook.Sheets(shname).Cells(row, 5) '宛先

Wm_ITEM.CC = ThisWorkbook.Sheets(shname).Cells(row, 6) 'CC

Wm_ITEM.Subject = ThisWorkbook.Sheets(shname).Cells(row, 7) '件名

Wm_ITEM.Body = ThisWorkbook.Sheets(shname).Cells(row, 3) & _

ThisWorkbook.Sheets(shname).Cells(row, 4) '社名+宛先名

Wm_ITEM.Body = Wm_ITEM.Body _

& vbCrLf _

& ThisWorkbook.Sheets(shname).Cells(row, 8) '社名+宛先名+本文

'★★ファイル添付★★

Dim inp As String

Dim msg As String

Dim Path As String

Dim Zippath As String

Dim Result As Boolean

folder = ThisWorkbook.Sheets(shname).Cells(row, 9).Value '添付したいファイルの場所

FileName = ThisWorkbook.Sheets(shname).Cells(row, 10).Value '添付したいファイル名

Path = folder & "\" & FileName

msg = "zip化した後の名前を入力（拡張子なし）" & vbCrLf & _

"zip前⇒" & FileName

inp = InputBox(msg)

Zippath = folder & "\" & inp & ".zip"

Result = MakeZip(Path, Zippath)

Wm_ITEM.Attachments.Add Zippath 'ファイル添付

Wm_ITEM.Display '.displayで　表示

'★★メール保存or送信★★慣れるまでは保存推奨！！

Wm_ITEM.Save '.Saveで保存下書きへ

' Wm_ITEM.Send '.Sendで送信※コメントを外すと送信されます

End If

row = row + 1

Loop

MsgBox "かんりょ"

End Sub

Function MakeZip(a_Path As String, a_Zippath As String) As String
    Dim sh      As New IWshRuntimeLibrary.WshShell
    Dim ex      As WshExec
    Dim Cmd    As String
    
    Cmd = "Compress-Archive -Path " & a_Path & " -DestinationPath " & a_Zippath & " -Force"
    Set ex = sh.Exec("powershell -NoLogo -ExecutionPolicy RemoteSigned -Command " & Cmd)
    
    MakeZip = True
          
End Function

Function MakeZip(a_Path As String, a_Zippath As String) As String

Dim sh As New IWshRuntimeLibrary.WshShell

Dim ex As WshExec

Dim Cmd As String

Cmd = "Compress-Archive -Path " & a_Path & " -DestinationPath " & a_Zippath & " -Force"

Set ex = sh.Exec("powershell -NoLogo -ExecutionPolicy RemoteSigned -Command " & Cmd)

MakeZip = True

End Function

ファイルをzip化するマクロ

今回はファイルを添付する前に、そのファイルをzip化しています。

具体的にzip化している箇所は↓の場所です。

        Result = MakeZip(Path, Zippath)

1	Result = MakeZip(Path, Zippath)

の場所からfunction MakeZipに飛びます。

Function MakeZip(a_Path As String, a_Zippath As String) As String
    Dim sh      As New IWshRuntimeLibrary.WshShell
    Dim ex      As WshExec
    Dim Cmd     As String
    
    Cmd = "Compress-Archive -Path " & a_Path & " -DestinationPath " & a_Zippath & " -Force"
    Set ex = sh.Exec("powershell -NoLogo -ExecutionPolicy RemoteSigned -Command " & Cmd)
    
    MakeZip = True
          
End Function