LotusNotesのメールを作成するクラスを作ってみた

LotusNotesのメールを作成するクラスを作ってみた

作ってみた。

しかし、LotusNotesは職場のPCに入っているので、全く実験できていない。

ちゃんと動くかどうかまるで未検証。

とりあえずコードだけぶちまけておいて、動作確認ができ次第修正していくことにする。

内容

LotusNotesAppクラス

メールを作成するメインのクラス。

IMailCreatableインターフェース

今後、LotusNotes以外のメールアプリもクラス化していく予定なので、インターフェースを持たせておく。

Recipientクラス

メールの送り先に関する情報をまとめたクラス。

Senderクラス

メールの送り手に関する情報をまとめたクラス。

ざっとこんな感じ。

ソースコード

クラスモジュール　LotusNotesApp

Option Explicit

Implements IMailCreatable

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

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 isAvailable As Boolean

Public Property Get NotesSession() As Object
  Set NotesSession = notesSession_
End Property
Public Property Get NotesUIWorkspace() As Object
  Set NotesUIWorkspace = notesUIWorkspace_
End Property

Public Sub init()
  Set notesSession_ = CreateObject("Notes.NotesSession")
  Set notesUIWorkspace_ = CreateObject("Notes.NotesUIWorkspace")
  Set notesDatabase_ = notesSession_.getDatabase("", "")
  '現在のユーザーのメールデータベースに割り当て、そのデータベースを開く'
  Call notesDatabase_.openMail
  isAvailable = True
End Sub

Private Sub Class_Initialize()
  isAvailable = False
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
End Sub

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 retReceipt As String
  retReceipt = ""
  If allowRetReceipt Then retReceipt = "1"
  'データベースに文書を作成して、新規文書を表す NotesDocument オブジェクトを返す。'
  '新規文書をディスクに保存するには、Save を呼び出す必要がある。'
  Set notesDocument = notesDatabase_.createDocument()
  '文書に題名・宛先・受信確認有無を設定'
  With notesDocument
    .Subject = mailSubject
    .SendTo = targetRecipient.MailAddress
    If targetRecipient.CC <> "" Then .CopyTo = targetRecipient.CC
    If targetRecipient.BCC <> "" Then .BlindCopyTo = targetRecipient.BCC
    .ReturnReceipt = retReceipt
  End With
  '文書にリッチテキストアイテムを作成する'
  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)
  '添付ファイルを追加する'
  Set notesRichTextItem = getFileAttachedRichTextItem(notesRichTextItem, _
                                                      attFilePath())
  '署名を附加する'
  Set notesRichTextItem = getSignAppendedRichTextItem(notesRichTextItem, _
                                                      currentSender)
  'メールを保存する'
  Call notesDocument.Save(False, False)
  'メールを編集状態にする'
  Set notesUIDocument = notesUIWorkspace_.EditDocument(True, notesDocument, False)
End Sub

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

※2019.4.28 23:15ごろ、一部を修正しました。

クラスモジュール　IMailCreatable

Option Explicit

Public Sub createMail(ByVal targetRecipient As Recipient, _
                      ByVal currentSender As Sender, _
                      ByVal mailSubject As String, _
                      ByRef mailBody() As String, _
                      ByRef attFilePath() As String, _
                      ByVal allowRetReceipt As Boolean)

End Sub

クラスモジュール　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, _
                ByVal CC As String, _
                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

※2019.4.28 23:15ごろ、一部を修正しました。

とりあえず

RecipientクラスとSenderクラスは、LotusNotesAppクラスのcreateMailメソッドの引数にする。

LotusNotesAppクラスのcreateMailメソッドは、引数としてRecipientクラスのインスタンス、Senderクラスのインスタンス、メールの件名、メール本文（文字列データの配列）、添付ファイルのフルパスを格納した配列、受信確認の有無を渡すと、添付ファイル付きのメールを作成して表示する。

最初にも書いたように、全然動作確認ができていないので、ご了承ください。

追記

ほんの少しだけ動作確認をした結果、一部コードを修正しました。