メール作成クラス群は今……

メール作成クラス群は今……

とりあえず、一段落したので、現状をご報告。

結果的に、

  • IMailCreatableインターフェース
  • IMailSendableインターフェース
  • LotusNotesAppクラス
  • ThunderbirdAppクラス
  • OutlookAppクラス
  • Recipientクラス
  • Senderクラス
  • ErrorObjectクラス

という実に八つものクラスモジュールを用いる一大プロジェクトになってしまった。

いよいよ本格的にアドイン化を検討せねばならん。

各クラスの役割

簡単に各クラスの役割を紹介しておこう。

IMailCreatableインターフェース

こいつをImplementsしたクラスは、メール作成可能。LotusNotesAppThunderbirdAppOutlookAppの三つにImplementsしているので、こいつらのインスタンスIMailCreatable型変数に突っ込んでやると、createMailメソッドを実行すれば、各クラスのメール作成メソッドを実行してくれる。

IMailSendableインターフェース

こいつをImplementsしたクラスは、メール送信が可能。LotusNotesAppOutlookAppの二つにImplementsしているので、こいつらのインスタンスIMailCreatable型変数に突っ込んでやると、sendMailメソッドを実行すれば、各クラスのメール送信メソッドを実行してくれる。ThunderbirdAppクラスにはImplementsしていないので、IMailCreatable型変数に突っ込むことはできない(はず。実験はしていない。めんどくさいので。)。

LotusNotesAppクラス

Lotus Notesを操るためのクラス。メール作成と送信ができる。

ThunderbirdAppクラス

Thunderbirdを操るためのクラス。メール作成のみ可能。

OutlookAppクラス

Outlookを操るためのくらす。メール作成と送信ができる。

Recipientクラス

メール送信先のデータを格納するのに使う。

Senderクラス

メール発信者のデータを格納するのに使う。実質Lotus Notesのためにしか使わない。Lotus Notesの既定の署名をセットする方法がわかったら要らなくなるかも。

ErrorObjectクラス

メール作成、送信メソッドの返り値に用いる。メソッド実行中に発生したエラー情報を持ち帰ってくる、というイメージ。こんな使い方が必要なのかどうかはよくわからない。

ソースコード

めちゃくちゃ長くなるけど、ぶちまけておく。

IMailCreatableインターフェース
Option Explicit

Public Function createMail( _
            ByVal targetRecipient As Recipient, _
            ByVal currentSender As Sender, _
            ByVal mailSubject As String, _
            ByRef mailBody() As String, _
            ByRef attFilePath() As String, _
   Optional ByVal allowRetReceipt As Boolean = False) As ErrorObject
  
End Function
IMailSendableインターフェース
Option Explicit

Public Function sendMail() As ErrorObject

End Function
LotusNotesAppクラス
Option Explicit

Implements IMailCreatable
Implements IMailSendable

'Constants'
Private Const EMBED_ATTACHMENT As Long = 1454
Private Const MAIN_FONTSIZE As Double = 12
Private Const SUB_FONTSIZE As Double = 10

Private Const FAILED_TO_ATTACH As String = "ファイル添付失敗"
Private Const NOTES_NOT_AVAILABLE As String = "Lotus Notes使用不可"
Private Const FAILED_TO_CREATE As String = "LotusNotesメール作成失敗"
Private Const FAILED_TO_SEND As String = "LotusNotesメール送信失敗"

Private notesSession As Object
Private notesUIWorkspace As Object
Private notesDatabase As Object
Private notesDocument As Object
Private notesRichTextItem As Object
Private notesRichTextStyle As Object
Private notesEmbeddedObject As Object
Private notesUIDocument As Object

Private errorSource As String

Private Sub Class_Initialize()

End Sub

Private Sub Class_Terminate()
  Set notesSession = Nothing
  Set notesUIWorkspace = Nothing
  Set notesDatabase = Nothing
  Set notesDocument = Nothing
  Set notesRichTextItem = Nothing
  Set notesRichTextStyle = Nothing
  Set notesEmbeddedObject = Nothing
  Set notesUIDocument = Nothing
End Sub

Public Function IMailCreatable_createMail( _
            ByVal targetRecipient As Recipient, _
            ByVal currentSender As Sender, _
            ByVal mailSubject As String, _
            ByRef mailBody() As String, _
            ByRef attFilePath() As String, _
   Optional ByVal allowRetReceipt As Boolean = False) As ErrorObject
  On Error Resume Next
  Call Err.Clear
  'メール作成準備'
  Set notesSession = CreateObject("Notes.NotesSession")
  Set notesUIWorkspace = CreateObject("Notes.NotesUIWorkspace")
  Set notesDatabase = notesSession.getDatabase("", "")
  Call notesDatabase.openMail
  If Err.Number > 0 Then errorSource = NOTES_NOT_AVAILABLE: GoTo ErrorHandler
  
  '受信確認設定準備'
  Dim retReceipt As String
  retReceipt = ""
  If allowRetReceipt Then retReceipt = "1"
  'データベースに文書を作成して、新規文書を表す NotesDocument オブジェクトを返す。'
  '新規文書をディスクに保存するには、Save を呼び出す必要がある。'
  Set notesDocument = notesDatabase.createDocument()
  '文書に題名・宛先・受信確認有無を設定'
  '// 2019/06/30訂正ここから。//'
  With notesDocument
    .Subject = mailSubject
    'SendTo、CopyTo、BlindCopyToには、アドレスの配列を渡す。'
    .SendTo = Split(targetRecipient.MailAddress, ",")
    If targetRecipient.CC <> "" Then .CopyTo = Split(targetRecipient.CC, ",")
    If targetRecipient.BCC <> "" Then .BlindCopyTo = Split(targetRecipient.BCC, ",")
    .ReturnReceipt = retReceipt
  End With
  '// 2019/06/30訂正ここまで。//'
  '文書にリッチテキストアイテムを作成する'
  Set notesRichTextItem = notesDocument.createRichTextItem("BODY")
  Set notesRichTextStyle = notesSession.createRichTextStyle("BODY")
  notesRichTextStyle.FontSize = MAIN_FONTSIZE
  'メール本文の左肩部分を作成する'
  Set notesRichTextItem = getHeaderAppendedRichTextItem(notesRichTextItem, _
                                                        targetRecipient)
  'メール本文の本体部分を作成する'
  Set notesRichTextItem = getMailBodyAppendedRichTextItem(notesRichTextItem, _
                                                          mailBody())
  '本文以外のフォントサイズを設定'
  notesRichTextStyle.FontSize = SUB_FONTSIZE
  Call notesRichTextItem.appendStyle(notesRichTextStyle)
  If Err.Number > 0 Then errorSource = FAILED_TO_CREATE: GoTo ErrorHandler
  '添付ファイルを追加する'
  Set notesRichTextItem = getFileAttachedRichTextItem(notesRichTextItem, _
                                                      attFilePath())
  If Err.Number > 0 Then errorSource = FAILED_TO_ATTACH: GoTo ErrorHandler
  '署名を附加する'
  Set notesRichTextItem = getSignAppendedRichTextItem(notesRichTextItem, _
                                                      currentSender)
  'メールを保存する'
  Call notesDocument.Save(False, False)
  'メールを編集状態にする'
  Set notesUIDocument = notesUIWorkspace.EditDocument(True, notesDocument, False)
  If Err.Number > 0 Then errorSource = FAILED_TO_CREATE: GoTo ErrorHandler
ErrorHandler:
  Dim ret As ErrorObject
  Set ret = ErrorObject.getInstance(number__:=Err.Number, _
                                    description__:=Err.Description)
  ret.Source = errorSource
  Set IMailCreatable_createMail = ret
  Set ret = Nothing
  Call Err.Clear
End Function

Private Function getHeaderAppendedRichTextItem( _
          ByVal targetNotesRichTextItem As Object, _
          ByVal targetRecipient As Recipient) As Object
'メール本文の左肩部分を作成して返す'
  Dim ret As Object
  Set ret = targetNotesRichTextItem
  With targetRecipient
    Call ret.appendStyle(notesRichTextStyle)
    Call ret.appendText(.CompanyName)
    Call ret.addNewLine(1)
    Call ret.appendText(" " & .JobTitle & " " & .Name & " 様")
    Call ret.addNewLine(3)
  End With
  Set getHeaderAppendedRichTextItem = ret
End Function

Private Function getMailBodyAppendedRichTextItem( _
                   ByVal targetNotesRichTextItem As Object, _
                   ByRef mailBody() As String) As Object
'メール本文の本体部分を作成して返す'
  Dim ret As Object
  Set ret = targetNotesRichTextItem
  Dim i As Long
  For i = LBound(mailBody) To UBound(mailBody)
    If mailBody(i) = "" Then GoTo Continue
    Call ret.appendText(mailBody(i))
    Call ret.addNewLine(2)
Continue:
  Next
  Call ret.addNewLine(2)
  Set getMailBodyAppendedRichTextItem = ret
End Function

Private Function getFileAttachedRichTextItem( _
                   ByVal targetNotesRichTextItem As Object, _
                   ByRef attFilePath() As String) As Object
'添付ファイルを添付する'
  Dim ret As Object
  Set ret = targetNotesRichTextItem
  Dim tmp As Long
  tmp = UBound(attFilePath)
  If tmp = 0 And attFilePath(tmp) = "" Then GoTo Finalizer
  Dim i As Long
  For i = LBound(attFilePath) To UBound(attFilePath)
    If attFilePath(i) = "" Then GoTo Continue
    Set notesEmbeddedObject = ret.EmbedObject(EMBED_ATTACHMENT, _
                                              "", _
                                              attFilePath(i))
    Call ret.addTab(1)
    Call ret.addNewLine(2)
Continue:
  Next
Finalizer:
  Set getFileAttachedRichTextItem = ret
End Function

Private Function getSignAppendedRichTextItem( _
                   ByVal targetNotesRichTextItem As Object, _
                   ByVal currentSender As Sender) As Object
'送信者の署名を附加する'
  Dim ret As Object
  Set ret = targetNotesRichTextItem
  With currentSender
    Call ret.addNewLine(3)
    Call ret.appendText("===============================")
    Call ret.addNewLine(1)
    Call ret.appendText(.CompanyName)
    Call ret.addNewLine(1)
    Call ret.appendText(" " & .DivisionName)
    Call ret.addNewLine(1)
    Call ret.appendText("  " & .JobTitle & "  " & .Name)
    Call ret.addNewLine(1)
    Call ret.appendText(.ZipCode)
    Call ret.addNewLine(1)
    Call ret.appendText(" " & .Address)
    Call ret.addNewLine(1)
    Call ret.appendText(" TEL   " & .PhoneNumber)
    Call ret.addNewLine(1)
    Call ret.appendText(" FAX   " & .FaxNumber)
    Call ret.addNewLine(1)
    Call ret.appendText(" Email " & .MailAddress)
    Call ret.addNewLine(1)
    Call ret.appendText("===============================")
    Call ret.addNewLine(1)
  End With
  Set getSignAppendedRichTextItem = ret
End Function

Public Function IMailSendable_sendMail() As ErrorObject
  On Error Resume Next
  Call CallByName(notesUIDocument, "Send", VbMethod, False)
  Call notesUIDocument.Save  'ここで保存しておくと、閉じるときのメッセージ表示を防げる'
  Call notesUIDocument.Close(True)
  If Err.Number > 0 Then errorSource = FAILED_TO_SEND
ErrorHandler:
  Dim ret As ErrorObject
  Set ret = ErrorObject.getInstance(number__:=Err.Number, _
                                    description__:=Err.Description)
  ret.Source = errorSource
  Set IMailSendable_sendMail = ret
  Set ret = Nothing
  Call Err.Clear
End Function
ThunderbirdAppクラス
Option Explicit

Implements IMailCreatable

'Constants'
Private Const TB_NOT_AVAILABLE As String = "Thunderbird実行不可"
Private Const FAILED_TO_CREATE As String = "Thunderbirdメール作成失敗"

'Module Level Variables'
Private exePath As String
Private isAvailable As Boolean

Private errorSource As String

Public Sub init(ByVal ThunderbirdExePath As String)
  isAvailable = False
  exePath = ThunderbirdExePath
  Dim fsObj As New FileSystemObject
  If fsObj.FileExists(exePath) Then isAvailable = True
End Sub

Public Function IMailCreatable_createMail( _
            ByVal targetRecipient As Recipient, _
            ByVal currentSender As Sender, _
            ByVal mailSubject As String, _
            ByRef mailBody() As String, _
            ByRef attFilePath() As String, _
   Optional ByVal allowReturnReceipt As Boolean = False) As ErrorObject
  If Not isAvailable Then errorSource = TB_NOT_AVAILABLE: GoTo ErrorHandler
  On Error Resume Next
  Call Err.Clear
  'Shell関数の引数を作る'
  Dim thunderbirdPath As String
  thunderbirdPath = exePath & " -compose "
  '件名をセット'
  If mailSubject = "" Then mailSubject = "無題"
  '左肩部分をセット'
  Dim bodyString As String
  With targetRecipient
    bodyString = .CompanyName & "%0A" & " " & _
                 .JobTitle & " " & _
                 .Name & " 様"
  End With
  '左肩部分の下に2行文空行をセット'
  bodyString = bodyString & "%0A" & "%0A" & "%0A"
  '本文をbodyStringに連結していく'
  Dim i As Long
  For i = LBound(mailBody) To UBound(mailBody)
    If mailBody(i) <> "" Then _
      bodyString = bodyString & mailBody(i) & "%0A" & "%0A"
  Next
  bodyString = Replace(bodyString, ",", ",")
  bodyString = Replace(bodyString, "vblf", "%0A")
  '添付ファイルフルパスをつなぐ'
  Dim attFilesString As String
  For i = LBound(attFilePath) To UBound(attFilePath)
    If attFilePath(i) <> "" Then _
      attFilesString = attFilesString & attFilePath(i) & ","
  Next
  '右端の「,」を除去する'
  If Right(attFilesString, 1) = "," Then
    attFilesString = Left(attFilesString, Len(attFilesString) - 1)
  End If
  '両端を「'」で囲む''
  attFilesString = "'" & attFilesString & "'"
  'メールを作成する'
  With targetRecipient
    Call Shell(thunderbirdPath & _
               "to=" & Replace(.MailAddress, ",", ";") & "," & _
               "cc=" & Replace(.CC, ",", ";") & "," & _
               "bcc=" & Replace(.BCC, ",", ";") & "," & _
               "subject=""" & mailSubject & """," & _
               "body=""" & bodyString & """," & _
               "attachment=""" & attFilesString & """")
  End With
  If Err.Number > 0 Then errorSource = FAILED_TO_CREATE: GoTo ErrorHandler
ErrorHandler:
  Dim ret As ErrorObject
  Set ret = ErrorObject.getInstance(number__:=Err.Number, _
                                    description__:=Err.Description)
  ret.Source = errorSource
  Set IMailCreatable_createMail = ret
  Set ret = Nothing
  Call Err.Clear
End Function
OutlookAppクラス
Option Explicit

Implements IMailCreatable
Implements IMailSendable

'Constants'
Private Const OUTLOOK_NOT_AVAILABLE As String = "Outlook使用不可"
Private Const FAILED_TO_CREATE As String = "Outlookメール作成失敗"
Private Const FAILED_TO_SEND As String = "Outlookメール送信失敗"

'Module Level Variables'
Private olApp As Outlook.Application
Private isAvailable As Boolean
Private targetMailItem As MailItem

Private errorSource As String

Private Sub Class_Initialize()
  On Error Resume Next
  Call Err.Clear
  isAvailable = False
  Set olApp = GetObject(, "Outlook.Application")
  Call Err.Clear
  If olApp Is Nothing Then
    Set olApp = getCurrentOutlook
  End If
  Err.Clear
  If olApp Is Nothing Then Exit Sub
  isAvailable = True
End Sub

Public Function IMailCreatable_createMail( _
            ByVal targetRecipient As Recipient, _
            ByVal currentSender As Sender, _
            ByVal mailSubject As String, _
            ByRef mailBody() As String, _
            ByRef attFilePath() As String, _
   Optional ByVal allowRetReceipt As Boolean = False) As ErrorObject
  If Not isAvailable Then errorSource = OUTLOOK_NOT_AVAILABLE: GoTo ErrorHandler
  On Error Resume Next
  Call Err.Clear
  '本文文字列の作成'
  '左肩部分の作成'
  Dim leftHeaderString As String
  With targetRecipient
    leftHeaderString = .CompanyName & vbCrLf & " " & _
                       .JobTitle & " " & _
                       .Name & " 様" & _
                       vbCrLf & vbCrLf & vbCrLf
  End With
  '本文をbodyStringに連結していく'
  Dim bodyString As String
  Dim i As Long
  For i = LBound(mailBody) To UBound(mailBody)
    If mailBody(i) <> "" Then _
      bodyString = bodyString & mailBody(i) & vbCrLf & vbCrLf
  Next
  Set targetMailItem = olApp.CreateItem(olMailItem)
  With targetMailItem
    'デフォルトの署名文字列を取得するために一旦RichText形式にする'
    .BodyFormat = olFormatRichText
    Call .Display
    'この時点ではBodyプロパティには署名文字列しか入っていないので、'
    '署名文字列を変数に入れる。'
    Dim senderSign As String
    senderSign = .Body
    'ここでHTML形式に変える'
    .BodyFormat = olFormatHTML
    .To = Replace(targetRecipient.MailAddress, ",", ";")
    .CC = Replace(targetRecipient.CC, ",", ";")
    .BCC = Replace(targetRecipient.BCC, ",", ";")
    .Subject = mailSubject
    '左肩、本文、署名の順にBodyプロパティに書き込む'
    .Body = leftHeaderString & _
            bodyString & vbCrLf & vbCrLf & _
            senderSign
    If Err.Number > 0 Then errorSource = FAILED_TO_CREATE: GoTo ErrorHandler
    '添付ファイルの設定'
    For i = LBound(attFilePath) To UBound(attFilePath)
      If attFilePath(i) <> "" Then _
        Call .Attachments.Add(attFilePath(i))
    Next
    '受信確認設定'
    If allowRetReceipt Then _
      .ReadReceiptRequested = True
  End With
  If Err.Number > 0 Then errorSource = FAILED_TO_CREATE: GoTo ErrorHandler
ErrorHandler:
  Dim ret As ErrorObject
  Set ret = ErrorObject.getInstance(number__:=Err.Number, _
                                    description__:=Err.Description)
  ret.Source = errorSource
  Set IMailCreatable_createMail = ret
  Set ret = Nothing
  Call Err.Clear
End Function

Private Function getCurrentOutlook() As Outlook.Application
  Dim targetOutlook As New Outlook.Application
  Dim currentNameSpace As Outlook.Namespace
  Set currentNameSpace = targetOutlook.GetNamespace("MAPI")
  Dim targetFolder As Outlook.Folder
  If targetOutlook.Explorers.Count > 0 Then
    Set targetFolder = _
          targetOutlook.Explorers.Item(1).CurrentFolder
  Else
    Set targetFolder = _
          currentNameSpace.GetDefaultFolder(olFolderInbox) 
          '既定のフォルダー olFolderInbox=6 指定'
  End If
  Call targetFolder.Display
  Set getCurrentOutlook = targetOutlook
End Function

Public Function IMailSendable_sendMail() As ErrorObject
  Call targetMailItem.Send
  If Err.Number > 0 Then errorSource = FAILED_TO_SEND
ErrorHandler:
  Dim ret As ErrorObject
  Set ret = ErrorObject.getInstance(number__:=Err.Number, _
                                    description__:=Err.Description)
  ret.Source = errorSource
  Set IMailSendable_sendMail = ret
  Set ret = Nothing
  Call Err.Clear
End Function
Recipientクラス
Option Explicit

Private mailAddress_ As String
Private companyName_ As String
Private jobTitle_ As String
Private name_ As String
Private CC_ As String
Private BCC_ As String
Private isInitialized_ As Boolean

Public Property Get MailAddress() As String
  MailAddress = mailAddress_
End Property
Public Property Get CompanyName() As String
  CompanyName = companyName_
End Property
Public Property Get JobTitle() As String
  JobTitle = jobTitle_
End Property
Public Property Get Name() As String
  Name = name_
End Property
Public Property Get CC() As String
  CC = CC_
End Property
Public Property Get BCC() As String
  BCC = BCC_
End Property
Public Property Get IsInitialized() As Boolean
  IsInitialized = isInitialized_
End Property

Public Sub init(ByVal mailAddress__ As String, _
                ByVal companyName__ As String, _
                ByVal jobTitle__ As String, _
                ByVal name__ As String, _
       Optional ByVal CC As String = "", _
       Optional ByVal BCC As String = "")
  mailAddress_ = mailAddress__
  companyName_ = companyName__
  jobTitle_ = jobTitle__
  name_ = name__
  CC_ = CC
  BCC_ = BCC
  isInitialized_ = True
End Sub
Senderクラス
Option Explicit

Private companyName_ As String
Private divisionName_ As String
Private jobTitle_ As String
Private name_ As String
Private zipCode_ As String
Private address_ As String
Private phoneNumber_ As String
Private faxNumber_ As String
Private mailAddress_ As String

Public Property Get CompanyName() As String
  CompanyName = companyName_
End Property
Public Property Get DivisionName() As String
  DivisionName = divisionName_
End Property
Public Property Get JobTitle() As String
  JobTitle = jobTitle_
End Property
Public Property Get Name() As String
  Name = name_
End Property
Public Property Get ZipCode() As String
  ZipCode = zipCode_
End Property
Public Property Get Address() As String
  Address = address_
End Property
Public Property Get PhoneNumber() As String
  PhoneNumber = phoneNumber_
End Property
Public Property Get FaxNumber() As String
  FaxNumber = faxNumber_
End Property
Public Property Get MailAddress() As String
  MailAddress = mailAddress_
End Property

Public Sub init(ByVal companyName__ As String, _
                ByVal divisionName__ As String, _
                ByVal jobTitle__ As String, _
                ByVal name__ As String, _
                ByVal zipCode__ As String, _
                ByVal address__ As String, _
                ByVal phoneNumber__ As String, _
                ByVal faxNumber__ As String, _
                ByVal mailAddress__ As String)
  companyName_ = companyName__
  divisionName_ = divisionName__
  jobTitle_ = jobTitle__
  name_ = name__
  zipCode_ = zipCode__
  address_ = address__
  phoneNumber_ = phoneNumber__
  faxNumber_ = faxNumber__
  mailAddress_ = mailAddress__
End Sub
ErrorObjectクラス
Option Explicit

'///Attribute VB_PredeclaredId = True///'

Private number_ As Long
Private description_ As String
Private lastDllError_ As Long
Private source_ As String

Public Property Get Number() As Long
  Number = number_
End Property
Public Property Let Number(ByVal value_ As Long)
  number_ = value_
End Property

Public Property Get Description() As String
  Description = description_
End Property
Public Property Let Description(ByVal value_ As String)
  description_ = value_
End Property

Public Property Get LastDllError() As Long
  LastDllError = lastDllError_
End Property
Public Property Let LastDllError(ByVal value_ As Long)
  lastDllError_ = value_
End Property

Public Property Get Source() As String
  Source = source_
End Property
Public Property Let Source(ByVal value_ As String)
  source_ = value_
End Property

Public Sub clearError()
  number_ = 0
  description_ = ""
  lastDllError_ = 0
  source_ = ""
  Call Err.Clear
End Sub
Public Sub raiseError( _
             Optional ByVal number__ As Long, _
             Optional ByVal source__ As Long, _
             Optional ByVal description__ As String)
  If number__ > 0 Then number_ = number__
  If source__ > 0 Then source_ = source__
  If description__ <> "" Then description_ = description__
  If number_ = 0 Then Exit Sub
  Call Err.Raise(number_, source_, description_)
End Sub

Public Function getInstance( _
                  ByVal number__ As Long, _
         Optional ByVal description__ As String, _
         Optional ByVal source__ As String, _
         Optional ByVal lastDllError__ As Long) As ErrorObject
  Dim ret As New ErrorObject
  ret.Number = number__
  ret.Description = description__
  ret.Source = source__
  ret.LastDllError = lastDllError__
  Set getInstance = ret
End Function

おっそろしく長いwww

使い方

使い方の一例を示す。

標準モジュールに次のコードを書く。

Private Enum MailApp
  maLotusNotes
  maThunderbird
  maOutlook
End Enum

Private mailCreator As IMailCreatable
Private mailSender As IMailSendable
Private notesApp As LotusNotesApp
Private tbApp As ThunderBirdApp
Private olApp As OutlookApp

Public Sub test()
  Call createMailCaller(maLotusNotes)
  Call createMailCaller(maOutlook, True)
End Sub

Private Sub createMailCaller(ByVal targetApp As MailApp, _
                    Optional ByVal isToSend As Boolean = False)
  '送信先情報をセット'
  Dim targetRecipient As Recipient
  Set targetRecipient = New Recipient
  Call targetRecipient.init("hoge@foobar.XXXX.com", _
                            "有限会社 大企業", _
                            "取締役社長", _
                            "一堂 零", _
                            "fuga@foobar.XXXX.com", _
                            "hage@foobar.XXXX.com")
  '送信者情報をセット'
  Dim currentSender As Sender
  Set currentSender = New Sender
  Call currentSender.init("財団法人", _
                          "日本相撲協会", _
                          "理事長", _
                          "保志 信芳", _
                          "130-0015", _
                          "東京都墨田区両国横網1-1-1", _
                          "03-XXXX-XXXX", _
                          "03-XXXX-XXXX", _
                          "toukaioozumou@sagami.com")
  'メール本文情報をセット'
  Dim mailBody(3) As String
  mailBody(0) = "ち~んw"
  mailBody(1) = "( ´,_ゝ`)プッ"
  mailBody(2) = "(゚∀゚)アヒャ"
  mailBody(3) = "( ´_ゝ`)フーン"
  '添付ファイル情報をセット'
  Dim attFilePaths(0) As String
  attFilePaths(0) = "X:\アホの坂田.jpg"
  '指定のメールアプリに応じてインスタンス化'
  Select Case targetApp
    Case maLotusNotes
      Set mailCreator = New LotusNotesApp
    Case maThunderbird
      Dim tbApp As New ThunderBirdApp
      Call tbApp.init("C:\Program Files (x86)\Mozilla Thunderbird\thunderbird.exe")
      Set mailCreator = tbApp
    Case maOutlook
      Set mailCreator = New OutlookApp
  End Select
  'メール作成'
  Dim result As ErrorObject
  Set result = mailCreator.createMail( _
                              targetRecipient, _
                              currentSender, _
                              "ち~んw", _
                              mailBody, _
                              attFilePaths, _
                              False)
  If result.Number > 0 Then GoTo ErrorHandler
  'isToSendがFalseなら抜ける'
  If Not isToSend Then Exit Sub
  'isToSendがTrueならメール送信'
  'mailSender型変数に代入'
  Set mailSender = mailCreator
  Set result = mailSender.sendMail
  If result.Number > 0 Then GoTo ErrorHandler
  Exit Sub
ErrorHandler:
  'エラーが生じていたら、エラーに応じた文字列を出力'
  With result
    Debug.Print .Number & ":" & .Description & " by " & .Source
  End With
End Sub

本来、Private createMailCallerメソッド内部の諸データは、引数で持たせるべきだけれど、めんどくさいのでジカ書き。

許してちょ。

使ってみる

testを実行してみる。

まず、

Call createMailCaller(maLotusNotes)

を実行したところで、

f:id:akashi_keirin:20190503102752j:plain

こうなる。

家のPCにはLotus Notesが入っていないので、当然こうなる。

次に、

Call createMailCaller(maOutlook, True)

を実行して、メールが送られた。Outlookの送信履歴を見ると、

f:id:akashi_keirin:20190503102755j:plain

ちゃんとメールが送信されている。

当然、デタラメなメールアドレスなので、MAILER-DAEMONが返ってきましたけどw

おわりに

ここまで読んでくれた人はいるのだろうか……。