VBA ExcelからOutlookでメールを送信する

このチュートリアルでは、VBAを使用してExcelからOutlook経由でメールを送信する方法について説明します。

アクティブなワークブックを送信する

Function SendActiveWorkbook(strTo As String, strSubject As String, Optional strCC As String, Optional strBody As String) As Boolean
   On Error Resume Next
   Dim appOutlook As Object
   Dim mItem As Object
'Outlookの新しいインスタンスを作成する
   Set appOutlook = CreateObject("Outlook.Application")
   Set mItem = appOutlook.CreateItem(0)
   With mItem
     .To = strTo
     .CC = ""
     .Subject = strSubject
     .Body = strBody
     .Attachments.Add ActiveWorkbook.FullName
'すぐに送信する場合はsend、画面に表示する場合はdisplayを使う
     .Display 'または.Send
   End With
'オブジェクトのクリーンアップ
   Set mItem = Nothing
   Set appOutlook = Nothing
End Function

上記の関数は、以下のプロシージャを使用して呼び出すことができます。

Sub SendMail()
   Dim strTo As String
   Dim strSubject As String
   Dim strBody As String
'変数に値を入れる
   strTo = "jon.smith@gmail.com"
   strSubject = "添付ファイルをご確認ください"
   strBody = "ここにメール本文のテキストが入ります"
'電子メールを送信する関数を呼び出す
   If SendActiveWorkbook（strTo, strSubject, , strBody）=True Then
      Msgbox "電子メールの作成に成功しました"
   Else
      Msgbox "電子メールの作成に失敗しました！"
   End if
End Sub

事前バインディングを使用した Outlook オブジェクトライブラリの参照

上記のコードでは、Outlookオブジェクトを参照するために実行時バインディングを使用しています。 Excelへの参照を追加し、OutlookアプリケーションとOutlook Mail Itemを宣言するには、事前バインディングを使用します。 事前バインディングはコードの実行を高速化しますが、ユーザーがPC上で同じバージョンのMicrosoft Officeを持っている必要があるという制限があります。 [ツール]メニューから[参照]をクリックすると、参照ダイアログボックスが表示されます。

使用しているOfficeのバージョンに対応したMicrosoft Outlookオブジェクトライブラリへの参照を追加します。

その後、これらの参照を直接使用するようにコードを修正することができます。

事前バインディングの大きな利点は、使用可能なオブジェクトがドロップダウンリストに表示されることです。

アクティブなワークブックから単一のシートを送信する

単一のシートを送信するには、まず、既存のワークブックからそのシートだけを含む新しいワークブックを作成し、そのシートを送信する必要があります。

Function SendActiveWorksheet(strTo As String, strSubject As String, Optional strCC As String, Optional strBody As String) As Boolean
   On Error GoTo eh
'必要なオブジェクトを保持するために変数を宣言する
   Dim wbDestination As Workbook
   Dim strDestName As String
   Dim wbSource As Workbook
   Dim wsSource As Worksheet 
   Dim OutApp As Object
   Dim OutMail As Object
   Dim strTempName As String
   Dim strTempPath As String
'最初に保存先ワークブックを作成する
   Set wbDestination = Workbooks.Add
   strDestName = wbDestination.Name
'コピー元のワークブックとシートを設定する
   Set wbSource = ActiveWorkbook
   Set wsSource = wbSource.ActiveSheet
'アクティブシートを新しいワークブックにコピーする
   wsSource.Copy After:=Workbooks(strDestName).Sheets(1)
'仮の名前で保存
   strTempPath = Environ$("temp") & "\"
   strTempName = "List obtained from " & wbSource.Name & ".xlsx"
   With wbDestination
      .SaveAs strTempPath & strTempName
'保存先のワークブックにメールを送る
      Set OutApp = CreateObject("Outlook.Application")
      Set OutMail = OutApp.CreateItem(0)
      With OutMail
         .To = strTo
         .Subject = strSubject
         .Body = strBody
         .Attachments.Add wbDestination.FullName
'すぐに送信する場合はsend、画面に表示する場合はdisplayを使用する
         .Display 'または.Send
      End With
      .Close False
  End With
'メールに添付したtemp workbookを削除する
   Kill strTempPath & strTempName
'オブジェクトをクリーンアップしてメモリを解放する
   Set wbDestination = Nothing
   Set wbSource = Nothing
   Set wsSource = Nothing
   Set OutMail = Nothing
   Set OutApp = Nothing
Exit Function
eh:
   MsgBox Err.Description
End Function

この関数を実行するには、例えば以下のようなプロシージャが必要です。

Sub SendSheetMail()
   Dim strTo As String
   Dim strSubject As String
   Dim strBody As String
   strTo = "jon.smith@gmail.com"
   strSubject = "添付ファイルをご確認ください"
   strBody = "ここにメール本文のテキストが入ります"
   If SendActiveWorksheet(strTo, strSubject, , strBody) = True Then
      Msgbox "電子メールの作成に成功しました" 
   Else
      MsgBox "電子メールの作成に失敗しました！"
   End If
End Sub