Outlookのメールを作成するクラスを作った

Outlookのメールを作成するクラスを作った

一気にOutlook版も行っちゃうよ！

今回も、

akashi-keirin.hatenablog.com

このときのRecipientクラス、Senderクラスと併用するのが前提。

ソースコード

クラスモジュール　OutlookApp

Option Explicit

Implements IMailCreatable

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

'Constructor'
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

'Methods'
Public Sub 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)
  If Not isAvailable Then Exit Sub
  '本文文字列の作成'
  '左肩部分の作成'
  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
  Dim targetMailItem As MailItem
  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
    '添付ファイルの設定'
    For i = LBound(attFilePath) To UBound(attFilePath)
      If attFilePath(i) <> "" Then _
        Call .Attachments.Add(attFilePath(i))
    Next
    '受信確認設定    ……(*)'
    If allowRetReceipt Then _
      .ReadReceiptRequested = True
  End With
End Sub

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

Outlookの場合、受信確認をオンにするのは非常に簡単。

(*)のところの２行（実質１行）

If allowRetReceipt Then _
      .ReadReceiptRequested = True

こんだけ。

MailItemオブジェクトのReadReceiptRequestedプロパティをTrueにしてやるだけでよい。

使ってみる

Thunderbird同様、Outlookも家のPCにフツーに入っているので、実験可能。

ちゃんと動いた。

createMailメソッドの第６引数allowRetReceiptをTrueにして実行したので、このように「開封確認の要求」にチェックが入っている。

おわりに

これで、普段使っているメールアプリが出揃ったぞ。