q12169744517

Public Sub SendEmailImpl(ByRef EmailAdressTo)
    Dim NotSet As Object    ' lotus.NOTESSESSION
    Dim NotDB As Object     ' lotus.NOTESDATABASE
    Dim NotDoc As Object    ' lotus.NOTESDOCUMENT
    Dim NotItem As Object ' lotus.NOTESRICHTEXTITEM
    Dim NotAtt As Object    ' lotus.NOTESEMBEDDEDOBJECT
    Dim AttFName As String  ' 添付ファイル名(フルパス)

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

    ' NotesDBに文書を作成し、新規文書をオブジェクト変数にセットする
    Set NotDoc = NotDB.CREATEDOCUMENT()
    ' 件名をセットする
    NotDoc.Subject = "今日は当番です。"
    ' 宛先をセットする
    NotDoc.SendTo = Array(EmailAdressTo)
    'NotDoc.CopyTo = Array(EmailAdressCC)
    'NotDoc.blindCopyTo = Array("xxx@xxx")

    ' 文書にリッチテキストアイテムを作成する
    Set NotItem = NotDoc.CreateRichTextItem("BODY")
    ' 本文をセットする
    With NotItem
        .APPENDTEXT "今日は当番日です。"
        .ADDNEWLINE 1
        .APPENDTEXT "よろしくお願いいたします。"
        .ADDNEWLINE 2
        ' 添付ファイル名をセットする
'        AttFName = "D:\TEST\Book1.xls"
        ' ファイルを添付する
'        Set NotAtt = .EmbedObject(EMBED_ATTACHMENT, "", AttFName)
        .ADDTAB 1
        .ADDNEWLINE 1
    End With

    ' メールを送信する
    NotDoc.Send False

    ' オブジェクト変数を解放する
    Set NotAtt = Nothing
    Set NotItem = Nothing
    Set NotDoc = Nothing
    Set NotDB = Nothing
    Set NotSet = Nothing

    MsgBox "メール発信", vbOKOnly + vbInformation

End Sub
Sub SendEmail
    ' @type {variant[5]}
    Dim SendLists(4)' 5組あるとする
    '適当にでっち上げで作ったEmailAdress、適当に変えるべし。
    SendLists(0) = Array("connossixe-2899@yopmail.com", "Ressill1967@superrito.com")
    SendLists(1) = Array("creraposla@housat.com", "zuavuwrm@vomoto.com")
    SendLists(2) = Array("ivlayva2i4@g0b8oz.com", "_jof_19@d-yatzic-j.com")
    SendLists(3) = Array("kp3aw1csd365@1ce5b51f4.com", "lcpobyc@v8rl8bz.com")
    SendLists(4) = Array("d2m8qp.jq6_vxn2@8odkq2max.com", "v8mupqj3kzek0@td6dzh4v.com")

    Const BeginDate = DateValue("2017/01/02")'2017/01/02は月曜日、適当に変えるべし。

    If Weekday(Date) = vbSunday And Weekday(Date) = vbSunday Then
        '土日だから死スべし、慈悲はない
    End If

    Const WeekDiff = DateDiff("w", Date, BeginDate)'これconstにできるのかね？わからん。

    If WeekDiff < 0 Then
        'BeginDateの設定がおかしい。起算日より前らしいで、今日は。
    End If

    Dim Email
    '基準日(BeginDate)からの経過週をSendListsの要素数で割ったあまりに
    '今日の曜日(月曜日起算なので-2)を足してSendListsの要素数で割ったあまりを求めるのはだるいので
    '基準日(BeginDate)からの経過週に今日の曜日を足してSendListsの要素数で割ったあまりが送信対象の配列のoffset
    'UBoundは配列の最大要素番号を返すんだってね、VBS作ったやつは頭がオカシイのでは？
    For Each Email In SendLists((WeekDiff + Weekday(Date) - 2) Mod (UBound(SendLists) + 1))
        SendEmailImpl Email' CCに入れる条件が謎なので一件づつToにぶち込んでバラバラに送信
    Next
End Sub