View difference between Paste ID: Pc6m00hj and 6PN6fDJb
SHOW: | | - or go back to the newest paste.
1
Public Sub SendEmailImpl(ByRef EmailAdressTo)
2-
Public Sub メール()
2+
3
    Dim NotDB As Object     ' lotus.NOTESDATABASE
4
    Dim NotDoc As Object    ' lotus.NOTESDOCUMENT
5
    Dim NotItem As Object ' lotus.NOTESRICHTEXTITEM
6
    Dim NotAtt As Object    ' lotus.NOTESEMBEDDEDOBJECT
7
    Dim AttFName As String  ' 添付ファイル名(フルパス)
8
9
    ' Notesのセッションを起動する
10
    Set NotSet = CreateObject("Notes.NotesSession")
11
    ' NotesDatabaseオブジェクトを作成し、そのデータベースを開く
12
    Set NotDB = NotSet.GETDATABASE("", "")
13
    ' NotesDBをユーザーのメールDBに割り当てた後に開く
14
    NotDB.OpenMail
15
16
    ' NotesDBに文書を作成し、新規文書をオブジェクト変数にセットする
17
    Set NotDoc = NotDB.CREATEDOCUMENT()
18
    ' 件名をセットする
19
    NotDoc.Subject = "今日は当番です。"
20
    ' 宛先をセットする
21
    NotDoc.SendTo = Array(EmailAdressTo)
22-
    NotDoc.SendTo = Array("[email protected]")
22+
    'NotDoc.CopyTo = Array(EmailAdressCC)
23-
    NotDoc.CopyTo = Array("[email protected]")
23+
24
25
    ' 文書にリッチテキストアイテムを作成する
26
    Set NotItem = NotDoc.CreateRichTextItem("BODY")
27
    ' 本文をセットする
28
    With NotItem
29
        .APPENDTEXT "今日は当番日です。"
30
        .ADDNEWLINE 1
31
        .APPENDTEXT "よろしくお願いいたします。"
32
        .ADDNEWLINE 2
33
        ' 添付ファイル名をセットする
34
'        AttFName = "D:\TEST\Book1.xls"
35
        ' ファイルを添付する
36
'        Set NotAtt = .EmbedObject(EMBED_ATTACHMENT, "", AttFName)
37
        .ADDTAB 1
38
        .ADDNEWLINE 1
39
    End With
40
41
    ' メールを送信する
42
    NotDoc.Send False
43
44
    ' オブジェクト変数を解放する
45
    Set NotAtt = Nothing
46
    Set NotItem = Nothing
47
    Set NotDoc = Nothing
48
    Set NotDB = Nothing
49
    Set NotSet = Nothing
50
51
    MsgBox "メール発信", vbOKOnly + vbInformation
52
53
End Sub
54
Sub SendEmail
55
    ' @type {variant[5]}
56
    Dim SendLists(4)' 5組あるとする
57-
Copy ToはCCです。
57+
    '適当にでっち上げで作ったEmailAdress、適当に変えるべし。
58
    SendLists(0) = Array("[email protected]", "[email protected]")
59-
よろしくお願いいたします。
59+
    SendLists(1) = Array("[email protected]", "[email protected]")
60
    SendLists(2) = Array("[email protected]", "[email protected]")
61
    SendLists(3) = Array("[email protected]", "[email protected]")
62
    SendLists(4) = Array("[email protected]", "[email protected]")
63
64
    Const BeginDate = DateValue("2017/01/02")'2017/01/02は月曜日、適当に変えるべし。
65
66
    If Weekday(Date) = vbSunday And Weekday(Date) = vbSunday Then
67
        '土日だから死スべし、慈悲はない
68
    End If
69
70
    Const WeekDiff = DateDiff("w", Date, BeginDate)'これconstにできるのかね?わからん。
71
72
    If WeekDiff < 0 Then
73
        'BeginDateの設定がおかしい。起算日より前らしいで、今日は。
74
    End If
75
76
    Dim Email
77
    '基準日(BeginDate)からの経過週をSendListsの要素数で割ったあまりに
78
    '今日の曜日(月曜日起算なので-2)を足してSendListsの要素数で割ったあまりを求めるのはだるいので
79
    '基準日(BeginDate)からの経過週に今日の曜日を足してSendListsの要素数で割ったあまりが送信対象の配列のoffset
80
    'UBoundは配列の最大要素番号を返すんだってね、VBS作ったやつは頭がオカシイのでは?
81
    For Each Email In SendLists((WeekDiff + Weekday(Date) - 2) Mod (UBound(SendLists) + 1))
82
        SendEmailImpl Email' CCに入れる条件が謎なので一件づつToにぶち込んでバラバラに送信
83
    Next
84
End Sub