こんにちは。

株式会社エス・スリーのスタッフです。

今日は、GW中に家族から相談を受けた、タイトルの内容について。
相談者はoutlookなどの普通のメーラーでなく、Notesのメールに埋め込みたいということで苦労している様子でした。
埋め込みたい画像は、同じEXCEL上の固定範囲とのこと。

私自身はNotesの使用経験が無く、
Notesって体験版があるのかな？と探してみても見つからず、
机上の推論状態でのvbaコード作成となりました笑

最初はこちらのブログ記事を参考に作成してみたのですが、
「IDファイルがみつかりません」といったエラーが出るという報告があがってきました。
Notesへのログイン周りだとは思うものの、試せないので何とも言えない状態です。

再びWEB上を探り、こちらのコードを発見。
このコードにはログイン処理が書かれていません。
先ほどのコードとの差に疑問は湧き出してきますが、
とりあえずこちらの生地を参考に、
範囲画像コピー＆保存部分の処理を追加し、相談者に渡しました。

結果は、動いたとのこと。
いまいち把握しきれずモヤモヤとはしますが、一件落着となりました。

渡したコードは末尾に書いておきます。
outlook版とnotes版を切り替えるようにしています。

最後になりますが、notesってIBM製品ではなくなっていたんですね。
今回初めて知りました。

それでは、最後までお読みいただき、ありがとうございました。

Option Explicit
Const imgFileName = "test"
Const ext = ".png"

Sub main()

    Call createJpg(ActiveSheet.Name, imgFileName)
    
    'outlook
    Call sendMail2
    
    'Notes
    'Call sentNotesMail
    
End Sub


'outlook版
Sub sendMail2()

Dim objOutlook As Outlook.Application
Dim objMail As Outlook.MailItem
Dim wsMail As Worksheet
Dim TempFilePath As String
Dim xHTMLBody As String
Dim toAddress As String

toAddress = "hogehoge@gmail.com"

Set objOutlook = New Outlook.Application
Set objMail = objOutlook.CreateItem(olMailItem)


TempFilePath = Environ$("temp") & "\"
    xHTMLBody = "" _
            & "
" _
            & "貼り付けテスト
 " _
            & "
" _
            & "" _
            & "
です"
    With objMail
        .Subject = ""
        .HTMLBody = xHTMLBody
      .Attachments.Add TempFilePath & imgFileName & ext, olByValue
        .To = toAddress
        .CC = " "
        .Send
    End With

Set objOutlook = Nothing
MsgBox "送信完了"

End Sub

'セル範囲の画像保存
Sub createJpg(SheetName As String, nameFile As String)
    Dim xRgPic As Range
    Dim xShape As Shape
    Dim xRange As String
    xRange = "A1:E16"
    ThisWorkbook.Activate
    Worksheets(SheetName).Activate
    Set xRgPic = ThisWorkbook.Worksheets(SheetName).Range(xRange)
    xRgPic.copyPicture (xlPrinter)
    With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
        .Activate
        For Each xShape In ActiveSheet.Shapes
            xShape.Line.Visible = msoFalse
        Next
        .Chart.Paste
        .Chart.Export Environ$("temp") & "\" & nameFile & ext, "png"
    End With
   Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub

'Notes版
Sub sendNotesMail()

Dim TempFilePath As String
Dim tempFullPath As String
Dim t As notesEmbeddedObject

    TempFilePath = Environ$("temp") & "\"
    tempFullPath = TempFilePath & imgFileName & ext

    Dim wkNSes As Object    ' lotus.NOTESSESSION
    Dim wkNDB As Object     ' lotus.NOTESDATABASE
    Dim wkNDoc As Object    ' lotus.NOTESDOCUMENT
    Dim wkNRtItem As Object ' lotus.NOTESRICHTEXTITEM
    Dim wkNAtt As Object    ' lotus.NOTESEMBEDDEDOBJECT

    '追加
    Dim ws As Object 'NotesUIWorkspace
    Dim uidoc As Object
    
    ' Notesのセッションを起動する
    Set wkNSes = CreateObject("Notes.NotesSession")
    '追加
    Set ws = CreateObject("Notes.NotesUIWorkspace")
    
    ' NotesDatabaseオブジェクトを作成し、そのデータベースを開く
    Set wkNDB = wkNSes.GETDATABASE("", "")
    ' NotesDBをユーザーのメールDBに割り当てた後に開く
    wkNDB.OpenMail

    ' NotesDBに文書を作成し、新規文書をオブジェクト変数にセットする
    Set wkNDoc = wkNDB.CREATEDOCUMENT()
    ' 件名をセットする
    wkNDoc.Subject = "テスト(タイトル)"
    ' 宛先をセットする
    wkNDoc.SendTo = Array("abc@def.ghi.com")
    'wkNDoc.CopyTo = Array("xxx@xxx")
    'wkNDoc.blindCopyTo = Array("xxx@xxx")

    ' 文書にリッチテキストアイテムを作成する
    Set wkNRtItem = wkNDoc.CreateRichTextItem("BODY")
    ' 本文をセットする

    With wkNRtItem
        .APPENDTEXT "本文（１行目）"
        .ADDNEWLINE 1
        .APPENDTEXT "本文（２行目）"
        ' ファイルを添付する
        Set wkNAtt = .EmbedObject(EMBED_OBJECT, "", tempFullPath)
        .ADDTAB 1
        .ADDNEWLINE 1
    End With
    ' メールを保存する。
    wkNDoc.Save False, False
    ' メールを編集状態にする
    Set uidoc = ws.EDITDOCUMENT(True, wkNDoc, False)

    ' オブジェクト変数を解放する
    Set wkNAtt = Nothing
    Set wkNRtItem = Nothing
    Set wkNDoc = Nothing
    Set uidoc = Nothing
    Set wkNDB = Nothing
    Set wkNSes = Nothing
    Set ws = Nothing
          
End Sub