OUTLOOKでBCCに複数アドレスの自動設定をするには？

質問

OUTLOOK2007でBCCに複数アドレスの自動設定したいのですが、
ネット見つけた下記マクロではアドレス1件しか設定することができません。複数（3件）設定するにはどうやって記述したら良いのでしょうか？マクロ全く初心者です。よろしくお願いします。

回答No.2

noname#90572

たびたびすみません。

BCCを付けないと結局は送信できないため、修正しました。

送信時のメッセージで
はい　を押すと　ＢＣＣつけて送信
いいえ　を押すと　そのまま送信
キャンセル　を押すと　送信中止
になります。

'====コード　ここから===========================================
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

Dim objMe As Recipient
Dim idx As Byte, idy As Byte
Dim msgRtn As Integer
Dim BccArray As Variant
Dim ChkFlg As Boolean
Dim strAddress(2) As String
Dim myStr As String

strAddress(0) = "hogehoge1@okwave.jp" '←１つ目のメールアドレス
strAddress(1) = "hogehoge2@okwave.jp" '←２つ目のメールアドレス
strAddress(2) = "hogehoge3@okwave.jp" '←３つ目のメールアドレス

'--確認部分（ここから）----
For idx = LBound(strAddress) To UBound(strAddress)
　　myStr = myStr & vbCrLf & strAddress(idx)
Next

msgRtn = MsgBox("BCC欄に" & myStr & "をセットして送信しますか？" & vbCrLf & vbCrLf & _
"はい：BCCにセットして送信する" & vbCrLf & "いいえ：このまま送信する" & vbCrLf & "キャンセル：送信を中止する", 67, "送信確認")
If msgRtn = vbNo Then
　　Cancel = False
　　Exit Sub
ElseIf msgRtn = vbCancel Then
　　Cancel = True
　　Exit Sub
End If
'--確認部分（ここまで）----

If Item.BCC = Empty Then
　　For idx = LBound(strAddress) To UBound(strAddress)
　　　　Set objMe = Item.Recipients.Add(strAddress(idx))
　　　　objMe.Type = olBCC
　　　　objMe.Resolve
　　　　Set objMe = Nothing
　　Next
Else
　　BccArray = Split(Item.BCC, ";")
　　For idx = LBound(strAddress) To UBound(strAddress)
　　　　ChkFlg = False
　　　　For idy = LBound(BccArray) To UBound(BccArray)
　　　　　　If strAddress(idx) = Trim(BccArray(idy)) Then
　　　　　　　ChkFlg = True
　　　　　　　Exit For
　　　　　　End If
　　　　Next
　　　　If ChkFlg = False Then
　　　　　Set objMe = Item.Recipients.Add(strAddress(idx))
　　　　　objMe.Type = olBCC
　　　　　objMe.Resolve
　　　　　Set objMe = Nothing
　　　　End If
　　Next
End If

End Sub
'====コード　ここまで===========================================

お礼

flow1997様

回答ありがとうございました。
無事に目的の操作を設定することができました。
しかも「確認メッセージ」が表示されるようにご配慮頂き
大変助かります。
本当にありがとうございました！！
（質問に答える前にお礼となってしまいすみません。）

回答No.1

noname#90572

こんばんは。

>ネット見つけた下記マクロ
載っていませんが、これのことでしょうか？

outlookでのBCC自動設定
http://okwave.jp/qa2333273.html

少し変えてみました。
送るメールすべてにＢＣＣが追加され即送信されてしまうので、場合によっては大問題になりかねませんので。
確認メッセージを出してます。
いいえを押せば、送信しません。
必要なければ、確認部分を消してください。

Alt + F11　で Visual Basic Editorを開き、

VBAProject
　＋Microsoft Office Outlook Objects
　　＋ThisOutlookSession　　　←ココをダブルクリックし、右側の欄に下記を貼り付けます

'====コード　ここから===========================================
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

Dim objMe As Recipient
Dim idx As Byte, idy As Byte
Dim msgRtn As Integer
Dim BccArray As Variant
Dim ChkFlg As Boolean
Dim strAddress(2) As String

strAddress(0) = "hogehoge1@okwave.jp" '←１つ目のメールアドレス
strAddress(1) = "hogehoge2@okwave.jp" '←２つ目のメールアドレス
strAddress(2) = "hogehoge3@okwave.jp" '←３つ目のメールアドレス

If Item.BCC = Empty Then
　　For idx = LBound(strAddress) To UBound(strAddress)
　　　　Set objMe = Item.Recipients.Add(strAddress(idx))
　　　　objMe.Type = olBCC
　　　　objMe.Resolve
　　　　Set objMe = Nothing
　　Next
Else
　　BccArray = Split(Item.BCC, ";")
　　For idx = LBound(strAddress) To UBound(strAddress)
　　　　ChkFlg = False
　　　　For idy = LBound(BccArray) To UBound(BccArray)
　　　　　　If strAddress(idx) = Trim(BccArray(idy)) Then
　　　　　　　ChkFlg = True
　　　　　　　Exit For
　　　　　　End If
　　　　Next
　　　　If ChkFlg = False Then
　　　　　Set objMe = Item.Recipients.Add(strAddress(idx))
　　　　　objMe.Type = olBCC
　　　　　objMe.Resolve
　　　　　Set objMe = Nothing
　　　　End If
　　Next
End If

'--確認部分（ここから）----
msgRtn = MsgBox("BCC欄にセットしました。" & vbCrLf & "ただちに送信しますか？", 68, "送信確認")
If msgRtn = vbNo Then
　　Cancel = True
End If
'--確認部分（ここまで）----
End Sub
'====コード　ここまで===========================================
上書き保存して閉じます。
取り扱いにはご注意ください。